diff --git a/.Rbuildignore b/.Rbuildignore index 2814b11b1187b7963ea8c1cf6a04e019ebe4392b..6008b579d5dd55cd0c61aa4e05404c8437d91f3f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,5 +12,6 @@ vignettes # unit tests should be ignored when building the package for CRAN ^tests$ # CDO is not in windbuilder, so we can test the unit tests by winbuilder -# but test-CDORemap.R needs to be hidden +# but test-CDORemap.R and test-Load.R needs to be hidden #tests/testthat/test-CDORemap.R +#tests/testthat/test-Load.R diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3eb90d50935404fa29137db76f00eae65305193a..8ffc555de890974f6ebbe3a6f0948a0cc52c2886 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,7 +3,7 @@ stages: build: stage: build script: - - module load R/3.6.1-foss-2015a-bare + - module load R/4.1.2-foss-2015a-bare - module load CDO/1.9.8-foss-2015a - R CMD build --resave-data . - R CMD check --as-cran --no-manual --run-donttest s2dv_*.tar.gz diff --git a/DESCRIPTION b/DESCRIPTION index e8382cd0b7f07c91ba1223f52002a40090724ab1..3a79ba60fd249bcc9da43aa9aa078b9b3997566e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: s2dv Title: A Set of Common Tools for Seasonal to Decadal Verification -Version: 1.2.0 +Version: 1.3.0 Authors@R: c( person("BSC-CNS", role = c("aut", "cph")), person("An-Chi", "Ho", , "an.ho@bsc.es", role = c("aut", "cre")), @@ -10,7 +10,8 @@ Authors@R: c( person("Carlos", "Delgado", , "carlos.delgado@bsc.es", role = "ctb"), person("Llorenç", "Lledó", , "llorenc.lledo@bsc.es", role = "ctb"), person("Andrea", "Manrique", , "andrea.manrique@bsc.es", role = "ctb"), - person("Deborah", "Verfaillie", , "deborah.verfaillie@bsc.es", role = "ctb")) + person("Deborah", "Verfaillie", , "deborah.verfaillie@bsc.es", role = "ctb"), + person("Eva", "Rifà", , "eva.rifarovira@bsc.es", role = "ctb")) Description: The advanced version of package 's2dverification'. It is intended for 'seasonal to decadal' (s2d) climate forecast verification, but it can also be used in other kinds of forecasts or general climate analysis. @@ -19,17 +20,18 @@ Description: The advanced version of package 's2dverification'. It is from data retrieval, data post-processing, skill scores against observation, to visualization. Compared to 's2dverification', 's2dv' is more compatible with the package 'startR', able to use multiple cores for computation and - handle multi-dimensional arrays with a higher flexibility. + handle multi-dimensional arrays with a higher flexibility. The CDO version used + in development is 1.9.8. Depends: - maps, - methods, R (>= 3.6.0) Imports: abind, bigmemory, graphics, grDevices, + maps, mapproj, + methods, parallel, ClimProjDiags, stats, diff --git a/NAMESPACE b/NAMESPACE index 032ebf98b3d409665b45f43ceea18477573f25fd..d440ec097f07df8d3c0b7e37629587de38d0a9d9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,11 +2,15 @@ export(ACC) export(AMV) +export(AbsBiasSS) export(AnimateMap) export(Ano) export(Ano_CrossValid) +export(Bias) export(BrierScore) export(CDORemap) +export(CRPS) +export(CRPSS) export(Clim) export(Cluster) export(ColorBar) @@ -92,6 +96,7 @@ import(stats) importFrom(ClimProjDiags,CombineIndices) importFrom(ClimProjDiags,Subset) importFrom(ClimProjDiags,WeightedMean) +importFrom(SpecsVerification,enscrps_cpp) importFrom(abind,abind) importFrom(abind,adrop) importFrom(easyNCDF,ArrayToNc) diff --git a/NEWS.md b/NEWS.md index d65a8240a76842468a0a509707745d2587b0f28f..c7daf9370c409791fe9679082ba30ce06f8cf347 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,15 @@ +# s2dv 1.3.0 (Release date: 2022-10-17) +- New functions: Bias, AbsBiasSS, CRPS, CRPSS +- split RPSS parameter 'weights' into 'weights_exp' and 'weights_ref' +- The warning message format is consistent; use internal function .warning() for all the cases +- PlotEquiMap() bugfixes when lon vector is not continuous +- PlotEquiMap() parameter "dots", "varu", "varv", and "contours" array latitude and longitude dimension order is flexible +- PlotLayout(): Add parameter to change subplot title size +- PlotLayout works with CSTools::PlotMostLikelyQuantileMap() +- Parameter "dat_dim" can be NULL in all functions +- Add "dat_dim" in RPS and RPSS to allow multiple datasets to be calculated +- DiffCorr: Add two-sided significance test. New param "test.type" to specify the one- or two-sided significance test. + # s2dv 1.2.0 (Release date: 2022-06-22) - Cluster(): Fix a bug of calculating nclusters ("K"): the function didn't use the whole data to calculate "K" if parameter "nclusters" is NULL.; Add missing output dimension names - Clim(): Correct the output dimensions for some cases; allow dat_dim to be NULL; obs doesn't need to have dat_dim. @@ -8,7 +20,7 @@ - PlotEquiMap(): Add useRaster = TRUE in image() if possible (i.e., latitude and longitude are regularly spaced.) - PlotEquiMap(): New parameters xlonshft ylatshft xlabels ylabels for self-defined axis - PlotEquiMap(): Flexible map longitude range -- New function: WeightCells, DiffCorr, ResidualCorr, RPS, RPSS +- New function: DiffCorr, ResidualCorr, RPS, RPSS - Clim() and MeanDims() efficiency improvement - CDORemap(): Add arbitrary time metadata to avoid cdo warning like "Warning (find_time_vars): Time variable >time< not found!" - CDORemap(): Stop printing messages from cdo command. diff --git a/R/ACC.R b/R/ACC.R index 44c724c927675295ee54f26d7768380aaf96fc7a..64036f41e87eada3dcd6d4fba39614bdbcacde75 100644 --- a/R/ACC.R +++ b/R/ACC.R @@ -170,7 +170,7 @@ ACC <- function(exp, obs, dat_dim = 'dataset', lat_dim = 'lat', lon_dim = 'lon', } ## space_dim (deprecated) if (!missing("space_dim")) { - warning("Parameter 'space_dim' is deprecated. Use 'lat_dim' and 'lon_dim' instead.") + .warning("Parameter 'space_dim' is deprecated. Use 'lat_dim' and 'lon_dim' instead.") lat_dim <- space_dim[1] lon_dim <- space_dim[2] } @@ -276,7 +276,7 @@ ACC <- function(exp, obs, dat_dim = 'dataset', lat_dim = 'lat', lon_dim = 'lon', } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all the dimensions expect 'dat_dim' and 'memb_dim'.")) + "all the dimensions except 'dat_dim' and 'memb_dim'.")) } #----------------------------------------------------------------- diff --git a/R/AbsBiasSS.R b/R/AbsBiasSS.R new file mode 100644 index 0000000000000000000000000000000000000000..0ceb009c7b4dc33b6f9788dc6cb8459f0e25767b --- /dev/null +++ b/R/AbsBiasSS.R @@ -0,0 +1,281 @@ +#'Compute the Absolute Mean Bias Skill Score +#' +#'The Absolute Mean Bias Skill Score is based on the Absolute Mean Error (Wilks, +#' 2011) between the ensemble mean forecast and the observations. It measures +#'the accuracy of the forecast in comparison with a reference forecast to assess +#'whether the forecast presents an improvement or a worsening with respect to +#'that reference. The Mean Bias Skill Score ranges between minus infinite and 1. +#'Positive values indicate that the forecast has higher skill than the reference +#'forecast, while negative values indicate that it has a lower skill. Examples +#'of reference forecasts are the climatological forecast (average of the +#'observations), a previous model version, or another model. It is computed as +#'\code{AbsBiasSS = 1 - AbsBias_exp / AbsBias_ref}. The statistical significance +#'is obtained based on a Random Walk test at the 95% confidence level (DelSole +#'and Tippett, 2016). If there is more than one dataset, the result will be +#'computed for each pair of exp and obs data. +#' +#'@param exp A named numerical array of the forecast with at least time +#' dimension. +#'@param obs A named numerical array of the observation with at least time +#' dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +#' 'dat_dim'. +#'@param ref A named numerical array of the reference forecast data with at +#' least time dimension. The dimensions must be the same as 'exp' except +#' 'memb_dim' and 'dat_dim'. If there is only one reference dataset, it should +#' not have dataset dimension. If there is corresponding reference for each +#' experiement, the dataset dimension must have the same length as in 'exp'. If +#' 'ref' is NULL, the climatological forecast is used as reference forecast. +#' The default value is NULL. +#'@param time_dim A character string indicating the name of the time dimension. +#' The default value is 'sdate'. +#'@param memb_dim A character string indicating the name of the member dimension +#' to compute the ensemble mean; it should be set to NULL if the parameter 'exp' +#' and 'ref' are already the ensemble mean. The default value is NULL. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' The length of this dimension can be different between 'exp' and 'obs'. +#' The default value is NULL. +#'@param na.rm A logical value indicating if NAs should be removed (TRUE) or +#' kept (FALSE) for computation. The default value is FALSE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'\item{$biasSS}{ +#' A numerical array of BiasSS with dimensions nexp, nobs and the rest +#' dimensions of 'exp' except 'time_dim' and 'memb_dim'. +#'} +#'\item{$sign}{ +#' A logical array of the statistical significance of the BiasSS +#' with the same dimensions as $biasSS. nexp is the number of +#' experiment (i.e., 'dat_dim' in exp), and nobs is the number of observation +#' (i.e., 'dat_dim' in obs). If dat_dim is NULL, nexp and nobs are omitted. +#'} +#' +#'@references +#'Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +#'DelSole and Tippett, 2016; https://doi.org/10.1175/MWR-D-15-0218.1 +#' +#'@examples +#'exp <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, member = 10, sdate = 50)) +#'ref <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, member = 10, sdate = 50)) +#'obs <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, sdate = 50)) +#'biasSS1 <- AbsBiasSS(exp = exp, obs = obs, ref = ref, memb_dim = 'member') +#'biasSS2 <- AbsBiasSS(exp = exp, obs = obs, ref = NULL, memb_dim = 'member') +#' +#'@import multiApply +#'@export +AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, + dat_dim = NULL, na.rm = FALSE, ncores = NULL) { + + # Check inputs + ## exp, obs, and ref (1) + if (!is.array(exp) | !is.numeric(exp)) { + stop("Parameter 'exp' must be a numeric array.") + } + if (!is.array(obs) | !is.numeric(obs)) { + stop("Parameter 'obs' must be a numeric array.") + } + if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + if (!is.null(ref)) { + if (!is.array(ref) | !is.numeric(ref)) + stop("Parameter 'ref' must be a numeric array.") + if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + stop("Parameter 'ref' must have dimension names.") + } + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + if (!is.null(ref) & !time_dim %in% names(dim(ref))) { + stop("Parameter 'time_dim' is not found in 'ref' dimension.") + } + ## memb_dim + if (!is.null(memb_dim)) { + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp))) { + stop("Parameter 'memb_dim' is not found in 'exp' dimension.") + } + if (memb_dim %in% names(dim(obs))) { + if (identical(as.numeric(dim(obs)[memb_dim]), 1)) { + obs <- ClimProjDiags::Subset(x = obs, along = memb_dim, indices = 1, drop = 'selected') + } else { + stop("Not implemented for observations with members ('obs' can have 'memb_dim', ", + "but it should be of length = 1).") + } + } + } + ## dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + } + ## exp, obs, and ref (2) + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + if (!is.null(memb_dim)) { + name_exp <- name_exp[-which(name_exp == memb_dim)] + } + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } + if (!identical(length(name_exp), length(name_obs)) | + !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.")) + } + if (!is.null(ref)) { + name_ref <- sort(names(dim(ref))) + if (!is.null(memb_dim) && memb_dim %in% name_ref) { + name_ref <- name_ref[-which(name_ref == memb_dim)] + } + if (!is.null(dat_dim)) { + if (dat_dim %in% name_ref) { + if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { + stop(paste0("If parameter 'ref' has dataset dimension, it must be", + " equal to dataset dimension of 'exp'.")) + } + name_ref <- name_ref[-which(name_ref == dat_dim)] + } + } + if (!identical(length(name_exp), length(name_ref)) | + !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { + stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.")) + } + } + ## na.rm + if (!is.logical(na.rm) | length(na.rm) > 1) { + stop("Parameter 'na.rm' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be either NULL or a positive integer.") + } + } + + ############################ + + ## Ensemble mean + if (!is.null(memb_dim)) { + exp <- MeanDims(exp, memb_dim, na.rm = na.rm) + if (!is.null(ref) & memb_dim %in% names(dim(ref))) { + ref <- MeanDims(ref, memb_dim, na.rm = na.rm) + } + } + + ## Mean bias skill score + if (!is.null(ref)) { # use "ref" as reference forecast + if (!is.null(dat_dim) && dat_dim %in% names(dim(ref))) { + target_dims_ref <- c(time_dim, dat_dim) + } else { + target_dims_ref <- c(time_dim) + } + data <- list(exp = exp, obs = obs, ref = ref) + target_dims = list(exp = c(time_dim, dat_dim), + obs = c(time_dim, dat_dim), + ref = target_dims_ref) + } else { + data <- list(exp = exp, obs = obs) + target_dims = list(exp = c(time_dim, dat_dim), + obs = c(time_dim, dat_dim)) + } + + output <- Apply(data, + target_dims = target_dims, + fun = .AbsBiasSS, + dat_dim = dat_dim, + na.rm = na.rm, + ncores = ncores) + + return(output) +} + +.AbsBiasSS <- function(exp, obs, ref = NULL, dat_dim = NULL, na.rm = FALSE) { + # exp and obs: [sdate, (dat_dim)] + # ref: [sdate, (dat_dim)] or NULL + + # Adjust exp, obs, ref to have dat_dim temporarily + if (is.null(dat_dim)) { + nexp <- 1 + nobs <- 1 + exp <- InsertDim(exp, posdim = 2, lendim = 1, name = 'dataset') + obs <- InsertDim(obs, posdim = 2, lendim = 1, name = 'dataset') + if (!is.null(ref)) { + ref <- InsertDim(ref, posdim = 2, lendim = 1, name = 'dataset') + } + ref_dat_dim <- FALSE + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + if (length(dim(ref)) == 1) { # ref: [sdate] + ref_dat_dim <- FALSE + } else { + ref_dat_dim <- TRUE + } + } + + biasSS <- array(dim = c(nexp = nexp, nobs = nobs)) + sign <- array(dim = c(nexp = nexp, nobs = nobs)) + + for (i in 1:nexp) { + exp_data <- exp[, i] + if (isTRUE(ref_dat_dim)) { + ref_data <- ref[, i] + } else { + ref_data <- ref + } + for (j in 1:nobs) { + obs_data <- obs[, j] + + if (isTRUE(na.rm)) { + if (is.null(ref)) { + good_values <- !is.na(exp_data) & !is.na(obs_data) + exp_data <- exp_data[good_values] + obs_data <- obs_data[good_values] + } else { + good_values <- !is.na(exp_data) & !is.na(ref_data) & !is.na(obs_data) + exp_data <- exp_data[good_values] + ref_data <- ref_data[good_values] + obs_data <- obs_data[good_values] + } + } + + ## Bias of the exp + bias_exp <- .Bias(exp = exp_data, obs = obs_data, na.rm = na.rm, absolute = TRUE, time_mean = FALSE) + ## Bias of the ref + if (is.null(ref)) { ## Climatological forecast + ref_data <- rep(mean(obs_data, na.rm = na.rm), length(obs_data)) + } + bias_ref <- .Bias(exp = ref_data, obs = obs_data, na.rm = na.rm, absolute = TRUE, time_mean = FALSE) + ## Skill score and significance + biasSS[i, j] <- 1 - mean(bias_exp) / mean(bias_ref) + sign[i, j] <- .RandomWalkTest(skill_A = bias_exp, skill_B = bias_ref)$signif + } + } + + if (is.null(dat_dim)) { + dim(biasSS) <- NULL + dim(sign) <- NULL + } + + + return(list(biasSS = biasSS, sign = sign)) +} diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index 99205020b7412afdf90513ad18dedf0b9302320d..d1996b9cd84023e8dc37e11af20b32b6e1cedd0f 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -18,7 +18,8 @@ #'@param dat_dim A character vector indicating the name of the dataset and #' member dimensions. When calculating the climatology, if data at one #' startdate (i.e., 'time_dim') is not complete along 'dat_dim', this startdate -#' along 'dat_dim' will be discarded. The default value is +#' along 'dat_dim' will be discarded. If there is no dataset dimension, it can be NULL. +#' The default value is #' "c('dataset', 'member')". #'@param memb_dim A character string indicating the name of the member #' dimension. Only used when parameter 'memb' is FALSE. It must be one element @@ -83,11 +84,25 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") } ## dat_dim - if (!is.character(dat_dim)) { - stop("Parameter 'dat_dim' must be a character vector.") - } - if (!all(dat_dim %in% names(dim(exp))) | !all(dat_dim %in% names(dim(obs)))) { - stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + if (!is.null(dat_dim)) { + if (!is.character(dat_dim)) { + stop("Parameter 'dat_dim' must be a character vector.") + } + if (!all(dat_dim %in% names(dim(exp))) | !all(dat_dim %in% names(dim(obs)))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + # If dat_dim is not in obs, add it in + if (any(!dat_dim %in% names(dim(obs)))) { + reset_obs_dim <- TRUE + ori_obs_dim <- dim(obs) + dim(obs) <- c(dim(obs), rep(1, length(dat_dim[which(!dat_dim %in% names(dim(obs)))]))) + names(dim(obs)) <- c(names(ori_obs_dim), dat_dim[which(!dat_dim %in% names(dim(obs)))]) + } else { + reset_obs_dim <- FALSE + } + } else { + reset_obs_dim <- FALSE } ## memb if (!is.logical(memb) | length(memb) > 1) { @@ -115,9 +130,11 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) - for (i in 1:length(dat_dim)) { - name_exp <- name_exp[-which(name_exp == dat_dim[i])] - name_obs <- name_obs[-which(name_obs == dat_dim[i])] + if (!is.null(dat_dim)) { + for (i in 1:length(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim[i])] + name_obs <- name_obs[-which(name_obs == dat_dim[i])] + } } if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have the same length of ", @@ -135,36 +152,65 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', #----------------------------------- # Per-paired method: If any sdate along dat_dim is NA, turn all sdate points along dat_dim into NA. - pos <- rep(0, length(dat_dim)) # dat_dim: [dataset, member] - for (i in 1:length(dat_dim)) { - pos[i] <- which(names(dim(obs)) == dat_dim[i]) - } - outrows_exp <- MeanDims(exp, pos, na.rm = FALSE) + - MeanDims(obs, pos, na.rm = FALSE) - outrows_obs <- outrows_exp - - for (i in 1:length(pos)) { - outrows_exp <- InsertDim(outrows_exp, pos[i], dim(exp)[pos[i]]) - outrows_obs <- InsertDim(outrows_obs, pos[i], dim(obs)[pos[i]]) - } - exp_for_clim <- exp - obs_for_clim <- obs - exp_for_clim[which(is.na(outrows_exp))] <- NA - obs_for_clim[which(is.na(outrows_obs))] <- NA + if (!is.null(dat_dim)) { + pos <- rep(0, length(dat_dim)) # dat_dim: [dataset, member] + for (i in 1:length(dat_dim)) { + pos[i] <- which(names(dim(obs)) == dat_dim[i]) + } + outrows_exp <- MeanDims(exp, pos, na.rm = FALSE) + + MeanDims(obs, pos, na.rm = FALSE) + outrows_obs <- outrows_exp + + for (i in 1:length(pos)) { + outrows_exp <- InsertDim(outrows_exp, pos[i], dim(exp)[pos[i]]) + outrows_obs <- InsertDim(outrows_obs, pos[i], dim(obs)[pos[i]]) + } + exp_for_clim <- exp + obs_for_clim <- obs + exp_for_clim[which(is.na(outrows_exp))] <- NA + obs_for_clim[which(is.na(outrows_obs))] <- NA + } else { + exp_for_clim <- exp + obs_for_clim <- obs + } + #----------------------------------- + res <- Apply(list(exp, obs, exp_for_clim, obs_for_clim), + target_dims = c(time_dim, dat_dim), + fun = .Ano_CrossValid, dat_dim = dat_dim, + memb_dim = memb_dim, memb = memb, + ncores = ncores) - res <- Apply(list(exp, obs, exp_for_clim, obs_for_clim), - target_dims = c(time_dim, dat_dim), - fun = .Ano_CrossValid, - memb_dim = memb_dim, memb = memb, - ncores = ncores) + # Remove dat_dim in obs if obs doesn't have at first place + if (reset_obs_dim) { + res_obs_dim <- ori_obs_dim[-which(names(ori_obs_dim) == time_dim)] + if (!memb & memb_dim %in% names(res_obs_dim)) { + res_obs_dim <- res_obs_dim[-which(names(res_obs_dim) == memb_dim)] + } + if (is.integer(res_obs_dim) & length(res_obs_dim) == 0) { + res$obs <- as.vector(res$obs) + } else { + res$obs <- array(res$obs, dim = res_obs_dim) + } + } return(res) } -.Ano_CrossValid <- function(exp, obs, exp_for_clim, obs_for_clim, +.Ano_CrossValid <- function(exp, obs, exp_for_clim, obs_for_clim, dat_dim = c('dataset', 'member'), memb_dim = 'member', memb = TRUE, ncores = NULL) { + if (is.null(dat_dim)) { + ini_dims_exp <- dim(exp) + ini_dims_obs <- dim(obs) + ini_dims_exp_for_clim <- dim(exp) + ini_dims_obs_for_clim <- dim(exp) + exp <- InsertDim(exp, posdim = 2, lendim = 1, name = 'dataset') + exp_for_clim <- InsertDim(exp_for_clim, posdim = 2, lendim = 1, name = 'dataset') + obs <- InsertDim(obs, posdim = 2, lendim = 1, name = 'dataset') + obs_for_clim <- InsertDim(obs_for_clim, posdim = 2, lendim = 1, name = 'dataset') + } + # exp: [sdate, dat_dim, memb_dim] # obs: [sdate, dat_dim, memb_dim] ano_exp_list <- vector('list', length = dim(exp)[1]) #length: [sdate] @@ -222,5 +268,10 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', ano_obs <- array(unlist(ano_obs_list), dim = c(dim(obs)[-1], dim(obs)[1])) ano_obs <- Reorder(ano_obs, c(length(dim(obs)), 1:(length(dim(obs)) - 1))) + if (is.null(dat_dim)) { + ano_exp <- array(ano_exp, dim = ini_dims_exp) + ano_obs <- array(ano_obs, dim = ini_dims_obs) + } + return(list(exp = ano_exp, obs = ano_obs)) } diff --git a/R/Bias.R b/R/Bias.R new file mode 100644 index 0000000000000000000000000000000000000000..0319a0f08e23e388046ce895e7a06aa82a0d9a41 --- /dev/null +++ b/R/Bias.R @@ -0,0 +1,189 @@ +#'Compute the Mean Bias +#' +#'The Mean Bias or Mean Error (Wilks, 2011) is defined as the mean difference +#'between the ensemble mean forecast and the observations. It is a deterministic +#'metric. Positive values indicate that the forecasts are on average too high +#'and negative values indicate that the forecasts are on average too low. +#'It also allows to compute the Absolute Mean Bias or bias without temporal +#'mean. If there is more than one dataset, the result will be computed for each +#'pair of exp and obs data. +#' +#'@param exp A named numerical array of the forecast with at least time +#' dimension. +#'@param obs A named numerical array of the observation with at least time +#' dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +#' 'dat_dim'. +#'@param time_dim A character string indicating the name of the time dimension. +#' The default value is 'sdate'. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' The length of this dimension can be different between 'exp' and 'obs'. +#' The default value is NULL. +#'@param memb_dim A character string indicating the name of the member dimension +#' to compute the ensemble mean; it should be set to NULL if the parameter +#' 'exp' is already the ensemble mean. The default value is NULL. +#'@param na.rm A logical value indicating if NAs should be removed (TRUE) or +#' kept (FALSE) for computation. The default value is FALSE. +#'@param absolute A logical value indicating whether to compute the absolute +#' bias. The default value is FALSE. +#'@param time_mean A logical value indicating whether to compute the temporal +#' mean of the bias. The default value is TRUE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A numerical array of bias with dimensions c(nexp, nobs, the rest dimensions of +#''exp' except 'time_dim' (if time_mean = T) and 'memb_dim'). nexp is the number +#'of experiment (i.e., 'dat_dim' in exp), and nobs is the number of observation +#'(i.e., 'dat_dim' in obs). If dat_dim is NULL, nexp and nobs are omitted. +#' +#'@references +#'Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +#' +#'@examples +#'exp <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, member = 10, sdate = 50)) +#'obs <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, sdate = 50)) +#'bias <- Bias(exp = exp, obs = obs, memb_dim = 'member') +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +Bias <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, na.rm = FALSE, + absolute = FALSE, time_mean = TRUE, ncores = NULL) { + + # Check inputs + ## exp and obs (1) + if (!is.array(exp) | !is.numeric(exp)) + stop("Parameter 'exp' must be a numeric array.") + if (!is.array(obs) | !is.numeric(obs)) + stop("Parameter 'obs' must be a numeric array.") + if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) + stop("Parameter 'time_dim' must be a character string.") + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb_dim + if (!is.null(memb_dim)) { + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp))) { + stop("Parameter 'memb_dim' is not found in 'exp' dimension.") + } + if (memb_dim %in% names(dim(obs))) { + if (identical(as.numeric(dim(obs)[memb_dim]), 1)) { + obs <- ClimProjDiags::Subset(x = obs, along = memb_dim, indices = 1, drop = 'selected') + } else { + stop("Not implemented for observations with members ('obs' can have 'memb_dim', ", + "but it should be of length = 1).") + } + } + } + ## dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + } + ## exp and obs (2) + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + if (!is.null(memb_dim)) { + name_exp <- name_exp[-which(name_exp == memb_dim)] + } + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } + if (!identical(length(name_exp), length(name_obs)) | + !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.")) + } + ## na.rm + if (!is.logical(na.rm) | length(na.rm) > 1) { + stop("Parameter 'na.rm' must be one logical value.") + } + ## absolute + if (!is.logical(absolute) | length(absolute) > 1) { + stop("Parameter 'absolute' must be one logical value.") + } + ## time_mean + if (!is.logical(time_mean) | length(time_mean) > 1) { + stop("Parameter 'time_mean' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be either NULL or a positive integer.") + } + } + + ############################### + + ## Ensemble mean + if (!is.null(memb_dim)) { + exp <- MeanDims(exp, memb_dim, na.rm = na.rm) + } + + ## (Mean) Bias + bias <- Apply(data = list(exp, obs), + target_dims = c(time_dim, dat_dim), + fun = .Bias, + time_dim = time_dim, + dat_dim = dat_dim, + na.rm = na.rm, + absolute = absolute, + time_mean = time_mean, + ncores = ncores)$output1 + + return(bias) +} + + +.Bias <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, na.rm = FALSE, + absolute = FALSE, time_mean = TRUE) { + # exp and obs: [sdate, (dat)] + + if (is.null(dat_dim)) { + bias <- exp - obs + + if (isTRUE(absolute)) { + bias <- abs(bias) + } + + if (isTRUE(time_mean)) { + bias <- mean(bias, na.rm = na.rm) + } + + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + bias <- array(dim = c(dim(exp)[time_dim], nexp = nexp, nobs = nobs)) + + for (i in 1:nexp) { + for (j in 1:nobs) { + bias[, i, j] <- exp[, i] - obs[, j] + } + } + + if (isTRUE(absolute)) { + bias <- abs(bias) + } + + if (isTRUE(time_mean)) { + bias <- MeanDims(bias, time_dim, na.rm = na.rm) + } + } + + return(bias) +} diff --git a/R/BrierScore.R b/R/BrierScore.R index c3673ad4273089059f13debc91d244554c2f90cd..22f497d18553240f67693d3891c912cc43be059a 100644 --- a/R/BrierScore.R +++ b/R/BrierScore.R @@ -57,13 +57,13 @@ #''bs_check_gres', 'bss_gres', 'rel_bias_corrected', 'gres_bias_corrected', #''unc_bias_corrected', and 'bss_bias_corrected' are (a) a number (b) an array #'with dimensions c(nexp, nobs, all the rest dimensions in 'exp' and 'obs' -#'expect 'time_dim' and 'memb_dim') (c) an array with dimensions of +#'except 'time_dim' and 'memb_dim') (c) an array with dimensions of #''exp' and 'obs' except 'time_dim' and 'memb_dim'\cr #'Items 'nk', 'fkbar', and 'okbar' are (a) a vector of length of bin number #'determined by 'threshold' (b) an array with dimensions c(nexp, nobs, -#'no. of bins, all the rest dimensions in 'exp' and 'obs' expect 'time_dim' and +#'no. of bins, all the rest dimensions in 'exp' and 'obs' except 'time_dim' and #''memb_dim') (c) an array with dimensions c(no. of bin, all the rest dimensions -#'in 'exp' and 'obs' expect 'time_dim' and 'memb_dim') +#'in 'exp' and 'obs' except 'time_dim' and 'memb_dim') #' #'@references #'Wilks (2006) Statistical Methods in the Atmospheric Sciences.\cr @@ -176,11 +176,11 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd } if (any(!name_exp %in% name_obs) | any(!name_obs %in% name_exp)) { stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.")) + "of all the dimensions except 'dat_dim' and 'memb_dim'.")) } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.")) + "of all the dimensions except 'dat_dim' and 'memb_dim'.")) } ## ncores if (!is.null(ncores)) { diff --git a/R/CDORemap.R b/R/CDORemap.R index ce3ed353d894d5bdb836b8ff37c93187c093df55..f0044cba60d30889d2d1aa0a68f4057ad035357e 100644 --- a/R/CDORemap.R +++ b/R/CDORemap.R @@ -632,7 +632,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, cdo_version <- as.numeric_version( strsplit(suppressWarnings(system2("cdo", args = '-V', stderr = TRUE))[[1]], ' ')[[1]][5] ) - warning("CDORemap: Using CDO version ", cdo_version, ".") + .warning(paste0("CDORemap: Using CDO version ", cdo_version, ".")) if ((cdo_version >= as.numeric_version('1.7.0')) && (method == 'con')) { method <- 'ycon' } diff --git a/R/CRPS.R b/R/CRPS.R new file mode 100644 index 0000000000000000000000000000000000000000..7dedf4fcb90a833b1034e7a1eb038e2588fe15ca --- /dev/null +++ b/R/CRPS.R @@ -0,0 +1,171 @@ +#'Compute the Continuous Ranked Probability Score +#' +#'The Continuous Ranked Probability Score (CRPS; Wilks, 2011) is the continuous +#'version of the Ranked Probability Score (RPS; Wilks, 2011). It is a skill +#'metric to evaluate the full distribution of probabilistic forecasts. It has a +#'negative orientation (i.e., the higher-quality forecast the smaller CRPS) and +#'it rewards the forecast that has probability concentration around the observed +#'value. In case of a deterministic forecast, the CRPS is reduced to the mean +#'absolute error. It has the same units as the data. The function is based on +#'enscrps_cpp from SpecsVerification. If there is more than one dataset, CRPS +#'will be computed for each pair of exp and obs data. +#' +#'@param exp A named numerical array of the forecast with at least time +#' dimension. +#'@param obs A named numerical array of the observation with at least time +#' dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +#' 'dat_dim'. +#'@param time_dim A character string indicating the name of the time dimension. +#' The default value is 'sdate'. +#'@param memb_dim A character string indicating the name of the member dimension +#' to compute the probabilities of the forecast. The default value is 'member'. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' The length of this dimension can be different between 'exp' and 'obs'. The +#' default value is NULL. +#'@param Fair A logical indicating whether to compute the FairCRPS (the +#' potential CRPS that the forecast would have with an infinite ensemble size). +#' The default value is FALSE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A numerical array of CRPS with dimensions c(nexp, nobs, the rest dimensions of +#''exp' except 'time_dim' and 'memb_dim' dimensions). nexp is the number of +#'experiment (i.e., dat_dim in exp), and nobs is the number of observation +#'(i.e., dat_dim in obs). If dat_dim is NULL, nexp and nobs are omitted. +#' +#'@references +#'Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +#' +#'@examples +#'exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +#'obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) +#'res <- CRPS(exp = exp, obs = obs) +#' +#'@import multiApply +#'@importFrom SpecsVerification enscrps_cpp +#'@importFrom ClimProjDiags Subset +#'@export +CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, + Fair = FALSE, ncores = NULL) { + # Check inputs + ## exp and obs (1) + if (!is.array(exp) | !is.numeric(exp)) + stop("Parameter 'exp' must be a numeric array.") + if (!is.array(obs) | !is.numeric(obs)) + stop("Parameter 'obs' must be a numeric array.") + if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) + stop("Parameter 'time_dim' must be a character string.") + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp))) { + stop("Parameter 'memb_dim' is not found in 'exp' dimension.") + } + ## dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + } + ## exp and obs (2) + if (memb_dim %in% names(dim(obs))) { + if (identical(as.numeric(dim(obs)[memb_dim]), 1)) { + obs <- ClimProjDiags::Subset(x = obs, along = memb_dim, indices = 1, drop = 'selected') + } else { + stop("Not implemented for observations with members ('obs' can have 'memb_dim', but it should be of length = 1).") + } + } + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + name_exp <- name_exp[-which(name_exp == memb_dim)] + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } + if (!identical(length(name_exp), length(name_obs)) | + !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.")) + } + ## Fair + if (!is.logical(Fair) | length(Fair) > 1) { + stop("Parameter 'Fair' must be either TRUE or FALSE.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1) { + stop("Parameter 'ncores' must be either NULL or a positive integer.") + } + } + + ############################### + + # Compute CRPS + crps <- Apply(data = list(exp = exp, obs = obs), + target_dims = list(exp = c(time_dim, memb_dim, dat_dim), + obs = c(time_dim, dat_dim)), + fun = .CRPS, + time_dim = time_dim, memb_dim = memb_dim, dat_dim = dat_dim, + Fair = Fair, + ncores = ncores)$output1 + + # Return only the mean CRPS + crps <- MeanDims(crps, time_dim, na.rm = FALSE) + + return(crps) +} + +.CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, + Fair = FALSE) { + # exp: [sdate, memb, (dat_dim)] + # obs: [sdate, (dat_dim)] + + # Adjust dimensions if needed + if (is.null(dat_dim)) { + nexp <- 1 + nobs <- 1 + dim(exp) <- c(dim(exp), nexp = nexp) + dim(obs) <- c(dim(obs), nobs = nobs) + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + } + + # for FairCRPS + R_new <- ifelse(Fair, Inf, NA) + + CRPS <- array(dim = c(dim(exp)[time_dim], nexp = nexp, nobs = nobs)) + + for (i in 1:nexp) { + for (j in 1:nobs) { + exp_data <- exp[ , , i] + obs_data <- obs[ , j] + + if (is.null(dim(exp_data))) dim(exp_data) <- c(dim(exp)[1:2]) + if (is.null(dim(obs_data))) dim(obs_data) <- c(dim(obs)[1]) + + crps <- SpecsVerification::enscrps_cpp(ens = exp_data, obs = obs_data, R_new = R_new) + CRPS[ , i, j] <- crps + } + } + + if (is.null(dat_dim)) { + dim(CRPS) <- c(dim(CRPS)[time_dim]) + } + + return(CRPS) +} diff --git a/R/CRPSS.R b/R/CRPSS.R new file mode 100644 index 0000000000000000000000000000000000000000..a6b4a1405a80156149cf16cad5c955b9135428c2 --- /dev/null +++ b/R/CRPSS.R @@ -0,0 +1,298 @@ +#'Compute the Continuous Ranked Probability Skill Score +#' +#'The Continuous Ranked Probability Skill Score (CRPSS; Wilks, 2011) is the +#'skill score based on the Continuous Ranked Probability Score (CRPS; Wilks, +#'2011). It can be used to assess whether a forecast presents an improvement or +#'worsening with respect to a reference forecast. The CRPSS ranges between minus +#'infinite and 1. If the CRPSS is positive, it indicates that the forecast has +#'higher skill than the reference forecast, while a negative value means that it +#'has a lower skill. Examples of reference forecasts are the climatological +#'forecast (same probabilities for all categories for all time steps), +#'persistence, a previous model version, or another model. It is computed as +#'CRPSS = 1 - CRPS_exp / CRPS_ref. The statistical significance is obtained +#'based on a Random Walk test at the 95% confidence level (DelSole and Tippett, +#'2016). +#' +#'@param exp A named numerical array of the forecast with at least time +#' dimension. +#'@param obs A named numerical array of the observation with at least time +#' dimension. The dimensions must be the same as 'exp' except 'memb_dim' +#' and 'dat_dim'. +#'@param ref A named numerical array of the reference forecast data with at +#' least time and member dimension. The dimensions must be the same as 'exp' +#' except 'memb_dim' and 'dat_dim'. If there is only one reference dataset, +#' it should not have dataset dimension. If there is corresponding reference +#' for each experiement, the dataset dimension must have the same length as in +#' 'exp'. If 'ref' is NULL, the climatological forecast is used as reference +#' forecast. The default value is NULL. +#'@param time_dim A character string indicating the name of the time dimension. +#' The default value is 'sdate'. +#'@param memb_dim A character string indicating the name of the member dimension +#' to compute the probabilities of the forecast and the reference forecast. The +#' default value is 'member'. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' The length of this dimension can be different between 'exp' and 'obs'. +#' The default value is NULL. +#'@param Fair A logical indicating whether to compute the FairCRPSS (the +#' potential CRPSS that the forecast would have with an infinite ensemble +#' size). The default value is FALSE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'\item{$crpss}{ +#' A numerical array of the CRPSS with dimensions c(nexp, nobs, the rest +#' dimensions of 'exp' except 'time_dim' and 'memb_dim' dimensions). nexp is +#' the number of experiment (i.e., dat_dim in exp), and nobs is the number of +#' observation (i.e., dat_dim in obs). If 'dat_dim' is NULL, nexp and nobs are +#' omitted. +#'} +#'\item{$sign}{ +#' A logical array of the statistical significance of the CRPSS with the same +#' dimensions as $crpss. +#'} +#' +#'@references +#'Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +#'DelSole and Tippett, 2016; https://doi.org/10.1175/MWR-D-15-0218.1 +#' +#'@examples +#'exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +#'obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) +#'ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +#'res <- CRPSS(exp = exp, obs = obs) ## climatology as reference forecast +#'res <- CRPSS(exp = exp, obs = obs, ref = ref) ## ref as reference forecast +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, + Fair = FALSE, ncores = NULL) { + + # Check inputs + ## exp, obs, and ref (1) + if (!is.array(exp) | !is.numeric(exp)) { + stop("Parameter 'exp' must be a numeric array.") + } + if (!is.array(obs) | !is.numeric(obs)) { + stop("Parameter 'obs' must be a numeric array.") + } + if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + if (!is.null(ref)) { + if (!is.array(ref) | !is.numeric(ref)) + stop("Parameter 'ref' must be a numeric array.") + if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + stop("Parameter 'ref' must have dimension names.") + } + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + if (!is.null(ref) & !time_dim %in% names(dim(ref))) { + stop("Parameter 'time_dim' is not found in 'ref' dimension.") + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp))) { + stop("Parameter 'memb_dim' is not found in 'exp' dimension.") + } + if (!is.null(ref) & !memb_dim %in% names(dim(ref))) { + stop("Parameter 'memb_dim' is not found in 'ref' dimension.") + } + ## dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + } + ## exp, obs, and ref (2) + if (memb_dim %in% names(dim(obs))) { + if (identical(as.numeric(dim(obs)[memb_dim]), 1)) { + obs <- ClimProjDiags::Subset(x = obs, along = memb_dim, indices = 1, drop = 'selected') + } else { + stop("Not implemented for observations with members ('obs' can have ", + "'memb_dim', but it should be of length = 1).") + } + } + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + name_exp <- name_exp[-which(name_exp == memb_dim)] + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } + if (!identical(length(name_exp), length(name_obs)) | + !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of all dimensions", + " except 'memb_dim' and 'dat_dim'.")) + } + if (!is.null(ref)) { + name_ref <- sort(names(dim(ref))) + name_ref <- name_ref[-which(name_ref == memb_dim)] + if (!is.null(dat_dim)) { + if (dat_dim %in% name_ref) { + if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { + stop(paste0("If parameter 'ref' has dataset dimension it must be", + " equal to dataset dimension of 'exp'.")) + } + name_ref <- name_ref[-which(name_ref == dat_dim)] + } + } + if (!identical(length(name_exp), length(name_ref)) | + !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { + stop(paste0("Parameter 'exp' and 'ref' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.")) + } + } + ## Fair + if (!is.logical(Fair) | length(Fair) > 1) { + stop("Parameter 'Fair' must be either TRUE or FALSE.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1) { + stop("Parameter 'ncores' must be either NULL or a positive integer.") + } + } + + ############################### + + # Compute CRPSS + if (!is.null(ref)) { # use "ref" as reference forecast + if (!is.null(dat_dim) && (dat_dim %in% names(dim(ref)))) { + target_dims_ref <- c(time_dim, memb_dim, dat_dim) + } else { + target_dims_ref <- c(time_dim, memb_dim) + } + data <- list(exp = exp, obs = obs, ref = ref) + target_dims = list(exp = c(time_dim, memb_dim, dat_dim), + obs = c(time_dim, dat_dim), + ref = target_dims_ref) + } else { + data <- list(exp = exp, obs = obs) + target_dims = list(exp = c(time_dim, memb_dim, dat_dim), + obs = c(time_dim, dat_dim)) + } + output <- Apply(data, + target_dims = target_dims, + fun = .CRPSS, + time_dim = time_dim, memb_dim = memb_dim, + dat_dim = dat_dim, + Fair = Fair, + ncores = ncores) + + return(output) +} + +.CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, + Fair = FALSE) { + + # exp: [sdate, memb, (dat)] + # obs: [sdate, (dat)] + # ref: [sdate, memb, (dat)] or NULL + + if (is.null(dat_dim)) { + nexp <- 1 + nobs <- 1 + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + } + + #----- CRPS of the forecast + # [sdate, (nexp), (nobs)] + crps_exp <- .CRPS(exp = exp, obs = obs, time_dim = time_dim, memb_dim = memb_dim, + dat_dim = dat_dim, Fair = Fair) + + #----- CRPS of the reference forecast + if (is.null(ref)) { + ## using climatology as reference forecast + ## all the time steps are used as if they were members + ## then, ref dimensions are [sdate, memb], both with length(sdate) + + obs_time_len <- dim(obs)[time_dim] + if (is.null(dat_dim)) { + ref <- array(data = rep(obs, each = obs_time_len), dim = c(obs_time_len, obs_time_len)) + names(dim(ref)) <- c(time_dim, memb_dim) + # ref: [sdate, memb]; obs: [sdate] + crps_ref <- .CRPS(exp = ref, obs = obs, time_dim = time_dim, memb_dim = memb_dim, + dat_dim = dat_dim, Fair = Fair) + # crps_ref should be [sdate] + + } else { + crps_ref <- array(dim = c(obs_time_len, nobs)) + names(dim(crps_ref)) <- c(time_dim, 'nobs') + for (i_obs in 1:nobs) { + ref <- array(data = rep(obs[, i_obs], each = obs_time_len), dim = c(obs_time_len, obs_time_len)) + names(dim(ref)) <- c(time_dim, memb_dim) + crps_ref[, i_obs] <- .CRPS(exp = ref, obs = ClimProjDiags::Subset(obs, dat_dim, i_obs, drop = 'selected'), + time_dim = time_dim, memb_dim = memb_dim, dat_dim = NULL, Fair = Fair) + } + # crps_ref should be [sdate, nobs] + } + + } else { # ref is not NULL + if (!is.null(dat_dim) && (!dat_dim %in% names(dim(ref)))) { + remove_dat_dim <- TRUE + ref <- InsertDim(data = ref, posdim = length(dim(ref)) + 1 , lendim = 1, name = dat_dim) + } else { + remove_dat_dim <- FALSE + } + crps_ref <- .CRPS(exp = ref, obs = obs, time_dim = time_dim, memb_dim = memb_dim, + dat_dim = dat_dim, Fair = Fair) + # crps_ref should be [sdate, (nexp), (nobs)] + + if (!is.null(dat_dim)) { + if (isTRUE(remove_dat_dim)) { + dim(crps_ref) <- dim(crps_ref)[-2] + } + } + } + + #----- CRPSS + if (!is.null(dat_dim)) { + # If ref != NULL & ref has dat_dim, crps_ref = [sdate, nexp, nobs]; else, crps_ref = [sdate, nobs] + + crps_exp_mean <- MeanDims(crps_exp, time_dim, na.rm = FALSE) + crps_ref_mean <- MeanDims(crps_ref, time_dim, na.rm = FALSE) + crpss <- array(dim = c(nexp = nexp, nobs = nobs)) + sign <- array(dim = c(nexp = nexp, nobs = nobs)) + + if (length(dim(crps_ref_mean)) == 1) { + for (i in 1:nexp) { + for (j in 1:nobs) { + crpss[i, j] <- 1 - crps_exp_mean[i, j] / crps_ref_mean[j] + sign[i, j] <- .RandomWalkTest(skill_A = crps_exp_mean[i, j], skill_B = crps_ref_mean[j])$signif + } + } + } else { + for (i in 1:nexp) { + for (j in 1:nobs) { + crpss[i, j] <- 1 - crps_exp_mean[i, j] / crps_ref_mean[i, j] + sign[i, j] <- .RandomWalkTest(skill_A = crps_exp_mean[i, j], skill_B = crps_ref_mean[i, j])$signif + } + } + } + + } else { + crpss <- 1 - mean(crps_exp) / mean(crps_ref) + # Significance + sign <- .RandomWalkTest(skill_A = crps_exp, skill_B = crps_ref)$signif + } + + return(list(crpss = crpss, sign = sign)) +} diff --git a/R/Clim.R b/R/Clim.R index ce9ba2ed17b283d9a137df32e8b06275e7691f2e..c144025c1f8af795bb06afb31884949f868cb08f 100644 --- a/R/Clim.R +++ b/R/Clim.R @@ -173,7 +173,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), } if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have the same dimensions ", - "expect 'dat_dim'.")) + "except 'dat_dim'.")) } ############################### diff --git a/R/Composite.R b/R/Composite.R index be03ac9e71b37672a4eb2d84c061611d8921ed57..03f0d585a26e6d649a7145973828e3dff8d1a580 100644 --- a/R/Composite.R +++ b/R/Composite.R @@ -170,7 +170,7 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), count_k <- plyr::count(occ) if (any(count_k$freq == 1)) { tmp <- count_k$x[which(count_k$freq == 1)] - warning(paste0("Composite K = ", tmp, " has length 1. The p-value is NA.")) + .warning(paste0("Composite K = ", tmp, " has length 1. The p-value is NA.")) } output_dims <- list(composite = c(space_dim, 'K'), diff --git a/R/Consist_Trend.R b/R/Consist_Trend.R index b02aa5fe10cf64b6c574fb2314dd3ad91ab38029..ee956840bf613fc25b4d9ca65760a86e2f9bb4b3 100644 --- a/R/Consist_Trend.R +++ b/R/Consist_Trend.R @@ -124,7 +124,7 @@ Consist_Trend <- function(exp, obs, dat_dim = 'dataset', time_dim = 'sdate', int } if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension expect 'dat_dim'.")) + "all dimension except 'dat_dim'.")) } ## interval if (!is.numeric(interval) | interval <= 0 | length(interval) > 1) { diff --git a/R/Corr.R b/R/Corr.R index 0382a393266a7b021a7aab39e69f9e7382e1155c..67efb09c0a1119c0970682de43518a32368f48a1 100644 --- a/R/Corr.R +++ b/R/Corr.R @@ -2,28 +2,29 @@ #' #'Calculate the correlation coefficient (Pearson, Kendall or Spearman) for #'an array of forecast and an array of observation. The correlations are -#'computed along time_dim, the startdate dimension. If comp_dim is given, -#'the correlations are computed only if obs along the comp_dim dimension are -#'complete between limits[1] and limits[2], i.e., there is no NA between -#'limits[1] and limits[2]. This option can be activated if the user wants to -#'account only for the forecasts which the corresponding observations are -#'available at all leadtimes.\cr +#'computed along 'time_dim' that usually refers to the start date dimension. If +#''comp_dim' is given, the correlations are computed only if obs along comp_dim +#'dimension are complete between limits[1] and limits[2], i.e., there is no NA +#'between limits[1] and limits[2]. This option can be activated if the user +#'wants to account only for the forecasts which the corresponding observations +#'are available at all leadtimes.\cr #'The confidence interval is computed by the Fisher transformation and the #'significance level relies on an one-sided student-T distribution.\cr -#'If the dataset has more than one member, ensemble mean is necessary necessary -#'before using this function since it only allows one dimension 'dat_dim' to -#'have inconsistent length between 'exp' and 'obs'. If all the dimensions of -#''exp' and 'obs' are identical, you can simply use apply() and cor() to +#'The function can calculate ensemble mean before correlation by 'memb_dim' +#'specified and 'memb = F'. If ensemble mean is not calculated, correlation will +#'be calculated for each member. +#'If there is only one dataset for exp and obs, you can simply use cor() to #'compute the correlation. #' -#'@param exp A named numeric array of experimental data, with at least two -#' dimensions 'time_dim' and 'dat_dim'. +#'@param exp A named numeric array of experimental data, with at least dimension +#' 'time_dim'. #'@param obs A named numeric array of observational data, same dimensions as #' parameter 'exp' except along 'dat_dim' and 'memb_dim'. #'@param time_dim A character string indicating the name of dimension along #' which the correlations are computed. The default value is 'sdate'. #'@param dat_dim A character string indicating the name of dataset (nobs/nexp) -#' dimension. The default value is 'dataset'. +#' dimension. The default value is 'dataset'. If there is no dataset +#' dimension, set NULL. #'@param comp_dim A character string indicating the name of dimension along which #' obs is taken into account only if it is complete. The default value #' is NULL. @@ -51,9 +52,10 @@ #' c(nexp, nobs, exp_memb, obs_memb, all other dimensions of exp except #' time_dim and memb_dim).\cr #'nexp is the number of experiment (i.e., 'dat_dim' in exp), and nobs is the -#'number of observation (i.e., 'dat_dim' in obs). exp_memb is the number of -#'member in experiment (i.e., 'memb_dim' in exp) and obs_memb is the number of -#'member in observation (i.e., 'memb_dim' in obs).\cr\cr +#'number of observation (i.e., 'dat_dim' in obs). If dat_dim is NULL, nexp and +#'nobs are omitted. exp_memb is the number of member in experiment (i.e., +#''memb_dim' in exp) and obs_memb is the number of member in observation (i.e., +#''memb_dim' in obs). If memb = F, exp_memb and obs_memb are omitted.\cr\cr #'\item{$corr}{ #' The correlation coefficient. #'} @@ -129,11 +131,14 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") } ## dat_dim - if (!is.character(dat_dim) | length(dat_dim) > 1) { - stop("Parameter 'dat_dim' must be a character string.") - } - if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { - stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string or NULL.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } } ## comp_dim if (!is.null(comp_dim)) { @@ -194,15 +199,17 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) - name_exp <- name_exp[-which(name_exp == dat_dim)] - name_obs <- name_obs[-which(name_obs == dat_dim)] + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } if (!is.null(memb_dim)) { name_exp <- name_exp[-which(name_exp == memb_dim)] name_obs <- name_obs[-which(name_obs == memb_dim)] } if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension expect 'dat_dim' and 'memb_dim'.")) + "all dimension except 'dat_dim' and 'memb_dim'.")) } if (dim(exp)[time_dim] < 3) { stop("The length of time_dim must be at least 3 to compute correlation.") @@ -234,152 +241,121 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', rm(obs_sub, outrows) } - if (is.null(memb_dim)) { - # Define output_dims - if (conf & pval) { - output_dims <- list(corr = c('nexp', 'nobs'), - p.val = c('nexp', 'nobs'), - conf.lower = c('nexp', 'nobs'), - conf.upper = c('nexp', 'nobs')) - } else if (conf & !pval) { - output_dims <- list(corr = c('nexp', 'nobs'), - conf.lower = c('nexp', 'nobs'), - conf.upper = c('nexp', 'nobs')) - } else if (!conf & pval) { - output_dims <- list(corr = c('nexp', 'nobs'), - p.val = c('nexp', 'nobs')) - } else { - output_dims <- list(corr = c('nexp', 'nobs')) - } - - res <- Apply(list(exp, obs), - target_dims = list(c(time_dim, dat_dim), - c(time_dim, dat_dim)), - output_dims = output_dims, - fun = .Corr, - time_dim = time_dim, method = method, - pval = pval, conf = conf, conf.lev = conf.lev, - ncores = ncores) - - } else { + if (!is.null(memb_dim)) { if (!memb) { #ensemble mean - name_exp <- names(dim(exp)) - margin_dims_ind <- c(1:length(name_exp))[-which(name_exp == memb_dim)] - exp <- apply(exp, margin_dims_ind, mean, na.rm = TRUE) #NOTE: remove NAs here - obs <- apply(obs, margin_dims_ind, mean, na.rm = TRUE) - - # Define output_dims - if (conf & pval) { - output_dims <- list(corr = c('nexp', 'nobs'), - p.val = c('nexp', 'nobs'), - conf.lower = c('nexp', 'nobs'), - conf.upper = c('nexp', 'nobs')) - } else if (conf & !pval) { - output_dims <- list(corr = c('nexp', 'nobs'), - conf.lower = c('nexp', 'nobs'), - conf.upper = c('nexp', 'nobs')) - } else if (!conf & pval) { - output_dims <- list(corr = c('nexp', 'nobs'), - p.val = c('nexp', 'nobs')) - } else { - output_dims <- list(corr = c('nexp', 'nobs')) - } - - res <- Apply(list(exp, obs), - target_dims = list(c(time_dim, dat_dim), - c(time_dim, dat_dim)), - output_dims = output_dims, - fun = .Corr, - time_dim = time_dim, method = method, - pval = pval, conf = conf, conf.lev = conf.lev, ncores_input = ncores, - ncores = ncores) - - } else { # correlation for each member - - # Define output_dims - if (conf & pval) { - output_dims <- list(corr = c('nexp', 'nobs', 'exp_memb', 'obs_memb'), - p.val = c('nexp', 'nobs', 'exp_memb', 'obs_memb'), - conf.lower = c('nexp', 'nobs', 'exp_memb', 'obs_memb'), - conf.upper = c('nexp', 'nobs', 'exp_memb', 'obs_memb')) - } else if (conf & !pval) { - output_dims <- list(corr = c('nexp', 'nobs', 'exp_memb', 'obs_memb'), - conf.lower = c('nexp', 'nobs', 'exp_memb', 'obs_memb'), - conf.upper = c('nexp', 'nobs', 'exp_memb', 'obs_memb')) - } else if (!conf & pval) { - output_dims <- list(corr = c('nexp', 'nobs', 'exp_memb', 'obs_memb'), - p.val = c('nexp', 'nobs', 'exp_memb', 'obs_memb')) - } else { - output_dims <- list(corr = c('nexp', 'nobs', 'exp_memb', 'obs_memb')) - } + exp <- MeanDims(exp, memb_dim, na.rm = TRUE) + obs <- MeanDims(obs, memb_dim, na.rm = TRUE) +# name_exp <- names(dim(exp)) +# margin_dims_ind <- c(1:length(name_exp))[-which(name_exp == memb_dim)] +# exp <- apply(exp, margin_dims_ind, mean, na.rm = TRUE) #NOTE: remove NAs here +# obs <- apply(obs, margin_dims_ind, mean, na.rm = TRUE) + memb_dim <- NULL + } + } - res <- Apply(list(exp, obs), + res <- Apply(list(exp, obs), target_dims = list(c(time_dim, dat_dim, memb_dim), c(time_dim, dat_dim, memb_dim)), - output_dims = output_dims, fun = .Corr, + dat_dim = dat_dim, memb_dim = memb_dim, time_dim = time_dim, method = method, pval = pval, conf = conf, conf.lev = conf.lev, ncores_input = ncores, - ncores = ncores) - } - } + ncores = ncores) return(res) } -.Corr <- function(exp, obs, time_dim = 'sdate', method = 'pearson', +.Corr <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', time_dim = 'sdate', method = 'pearson', conf = TRUE, pval = TRUE, conf.lev = 0.95, ncores_input = NULL) { - - if (length(dim(exp)) == 2) { - # exp: [sdate, dat_exp] - # obs: [sdate, dat_obs] - nexp <- as.numeric(dim(exp)[2]) - nobs <- as.numeric(dim(obs)[2]) - -# NOTE: Use sapply to replace the for loop - CORR <- sapply(1:nobs, function(i) { - sapply(1:nexp, function (x) { - if (any(!is.na(exp[, x])) && sum(!is.na(obs[, i])) > 2) { #NOTE: Is this necessary? - cor(exp[, x], obs[, i], - use = "pairwise.complete.obs", - method = method) - } else { - NA #CORR[, i] <- NA + if (is.null(memb_dim)) { + if (is.null(dat_dim)) { + # exp: [sdate] + # obs: [sdate] + nexp <- 1 + nobs <- 1 + CORR <- array(dim = c(nexp = nexp, nobs = nobs)) + if (any(!is.na(exp)) && sum(!is.na(obs)) > 2) { + CORR <- cor(exp, obs, use = "pairwise.complete.obs", method = method) } - }) - }) - if (is.null(dim(CORR))) { - CORR <- array(CORR, dim = c(1, 1)) - } - - } else { # member - - # exp: [sdate, dat_exp, memb_exp] - # obs: [sdate, dat_obs, memb_obs] - nexp <- as.numeric(dim(exp)[2]) - nobs <- as.numeric(dim(obs)[2]) - exp_memb <- as.numeric(dim(exp)[3]) - obs_memb <- as.numeric(dim(obs)[3]) + } else { + # exp: [sdate, dat_exp] + # obs: [sdate, dat_obs] + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + CORR <- array(dim = c(nexp = nexp, nobs = nobs)) + for (j in 1:nobs) { + for (y in 1:nexp) { + if (any(!is.na(exp[, y])) && sum(!is.na(obs[, j])) > 2) { + CORR[y, j] <- cor(exp[, y], obs[, j], + use = "pairwise.complete.obs", + method = method) + } + } + } +#---------------------------------------- +# Same as above calculation. +#TODO: Compare which is faster. +# CORR <- sapply(1:nobs, function(i) { +# sapply(1:nexp, function (x) { +# if (any(!is.na(exp[, x])) && sum(!is.na(obs[, i])) > 2) { +# cor(exp[, x], obs[, i], +# use = "pairwise.complete.obs", +# method = method) +# } else { +# NA +# } +# }) +# }) +#----------------------------------------- + } - CORR <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) + } else { # memb_dim != NULL + exp_memb <- as.numeric(dim(exp)[memb_dim]) # memb_dim + obs_memb <- as.numeric(dim(obs)[memb_dim]) + + if (is.null(dat_dim)) { + # exp: [sdate, memb_exp] + # obs: [sdate, memb_obs] + nexp <- 1 + nobs <- 1 + CORR <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) + + for (j in 1:obs_memb) { + for (y in 1:exp_memb) { + + if (any(!is.na(exp[,y])) && sum(!is.na(obs[, j])) > 2) { + CORR[, , y, j] <- cor(exp[, y], obs[, j], + use = "pairwise.complete.obs", + method = method) + } - for (j in 1:obs_memb) { - for (y in 1:exp_memb) { - CORR[, , y, j] <- sapply(1:nobs, function(i) { - sapply(1:nexp, function (x) { - if (any(!is.na(exp[, x, y])) && sum(!is.na(obs[, i, j])) > 2) { - cor(exp[, x, y], obs[, i, j], - use = "pairwise.complete.obs", - method = method) - } else { - NA #CORR[, i] <- NA } - }) - }) + } + } else { + # exp: [sdate, dat_exp, memb_exp] + # obs: [sdate, dat_obs, memb_obs] + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + + CORR <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) + + for (j in 1:obs_memb) { + for (y in 1:exp_memb) { + CORR[, , y, j] <- sapply(1:nobs, function(i) { + sapply(1:nexp, function (x) { + if (any(!is.na(exp[, x, y])) && sum(!is.na(obs[, i, j])) > 2) { + cor(exp[, x, y], obs[, i, j], + use = "pairwise.complete.obs", + method = method) + } else { + NA + } + }) + }) + } + } } - } - } @@ -398,14 +374,21 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', if (pval | conf) { if (method == "kendall" | method == "spearman") { - tmp <- apply(obs, c(1:length(dim(obs)))[-1], rank) # for memb_dim = NULL, 2; for memb_dim, c(2, 3) - names(dim(tmp))[1] <- time_dim - eno <- Eno(tmp, time_dim, ncores = ncores_input) + if (!is.null(dat_dim) | !is.null(memb_dim)) { + tmp <- apply(obs, c(1:length(dim(obs)))[-1], rank) # for memb_dim = NULL, 2; for memb_dim, c(2, 3) + names(dim(tmp))[1] <- time_dim + eno <- Eno(tmp, time_dim, ncores = ncores_input) + } else { + tmp <- rank(obs) + tmp <- array(tmp) + names(dim(tmp)) <- time_dim + eno <- Eno(tmp, time_dim, ncores = ncores_input) + } } else if (method == "pearson") { eno <- Eno(obs, time_dim, ncores = ncores_input) } - if (length(dim(exp)) == 2) { + if (is.null(memb_dim)) { eno_expand <- array(dim = c(nexp = nexp, nobs = nobs)) for (i in 1:nexp) { eno_expand[i, ] <- eno @@ -435,6 +418,21 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', confhigh <- tanh(atanh(CORR) + qnorm(conf.upper) / sqrt(eno_expand - 3)) } +################################### + # Remove nexp and nobs if dat_dim = NULL + if (is.null(dat_dim) & !is.null(memb_dim)) { + dim(CORR) <- dim(CORR)[3:length(dim(CORR))] + if (pval) { + dim(p.val) <- dim(p.val)[3:length(dim(p.val))] + } + if (conf) { + dim(conflow) <- dim(conflow)[3:length(dim(conflow))] + dim(confhigh) <- dim(confhigh)[3:length(dim(confhigh))] + } + } + +################################### + if (pval & conf) { res <- list(corr = CORR, p.val = p.val, conf.lower = conflow, conf.upper = confhigh) @@ -447,6 +445,6 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', res <- list(corr = CORR) } - return(res) + return(res) } diff --git a/R/DiffCorr.R b/R/DiffCorr.R index c250814ce859739f4ad5a9e79e92aa14d8cd1fb4..1e07458989db3f40db83aa954abfc8b2b8929738 100644 --- a/R/DiffCorr.R +++ b/R/DiffCorr.R @@ -4,10 +4,10 @@ #'Positive values of the correlation difference indicate that the forecast is #'more skillful than the reference forecast, while negative values mean that #'the reference forecast is more skillful. The statistical significance of the -#'correlation differences is computed with a one-sided test for equality of -#'dependent correlation coefficients (Steiger, 1980; Siegert et al., 2017) using -#'effective degrees of freedom to account for the autocorrelation of the time -#'series (von Storch and Zwiers, 1999). +#'correlation differences is computed with a one-sided or two-sided test for +#'equality of dependent correlation coefficients (Steiger, 1980; Siegert et al., +#'2017) using effective degrees of freedom to account for the autocorrelation of +#'the time series (Zwiers and von Storch, 1995). #' #'@param exp A named numerical array of the forecast data with at least time #' dimension. @@ -38,6 +38,11 @@ #' steps with no missing values in all "exp", "ref", and "obs" will be used. If #' "na.fail", an error will arise if any of "exp", "ref", or "obs" contains any #' NA. The default value is "return.na". +#'@param test.type A character string indicating the type of significance test. +#' It can be "two-sided" (to assess whether the skill of "exp" and "ref" are +#' significantly different) or "one-sided" (to assess whether the skill of +#' "exp" is significantly higher than that of "ref") following Steiger (1980). +#' The default value is "two-sided". #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' @@ -60,19 +65,22 @@ #'@references #'Steiger, 1980; https://content.apa.org/doi/10.1037/0033-2909.87.2.245 #'Siegert et al., 2017; https://doi.org/10.1175/MWR-D-16-0037.1 -#'von Storch and Zwiers, 1999; https://doi.org/10.1017/CBO9780511612336 +#'Zwiers and von Storch, 1995; https://doi.org/10.1175/1520-0442(1995)008<0336:TSCIAI>2.0.CO;2 #' #'@examples #' exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) #' obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) #' ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) -#' res <- DiffCorr(exp, obs, ref, memb_dim = 'member') +#' res_two.sided_sign <- DiffCorr(exp, obs, ref, memb_dim = 'member', +#' test.type = 'two-sided', alpha = 0.05) +#' res_one.sided_pval <- DiffCorr(exp, obs, ref, memb_dim = 'member', +#' test.type = 'one-sided', alpha = NULL) #' #'@import multiApply #'@export DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', memb_dim = NULL, method = 'pearson', alpha = NULL, - handle.na = 'return.na', ncores = NULL) { + handle.na = 'return.na', test.type = "two-sided", ncores = NULL) { # Check inputs ## exp, ref, and obs (1) @@ -128,9 +136,9 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', stop('Parameter "method" must be "pearson" or "spearman".') } if (method == "spearman") { - warning(paste0("The test used in this function is built on Pearson method. ", - "To verify if Spearman method is reliable, you can run the ", - "Monte-Carlo simulations that are done in Siegert et al., 2017")) + .warning(paste0("The test used in this function is built on Pearson method. ", + "To verify if Spearman method is reliable, you can run the ", + "Monte-Carlo simulations that are done in Siegert et al., 2017")) } ## alpha if (!is.null(alpha)) { @@ -143,6 +151,14 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', if (!handle.na %in% c('return.na', 'only.complete.triplets', 'na.fail')) { stop('Parameter "handle.na" must be "return.na", "only.complete.triplets" or "na.fail".') } + ## test.type + if (!test.type %in% c('two-sided', 'one-sided')) { + stop("Parameter 'test.type' must be 'two-sided' or 'one-sided'.") + } + #NOTE: warning can be removed in the next release + .warning("The default significance test has changed after s2dv_1.2.0. The default method is 'two-sided'.") + + ## ncores if (!is.null(ncores)) { if (any(!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1)) { @@ -184,47 +200,74 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', ref = time_dim, N.eff = NULL), output_dims = output_dims, fun = .DiffCorr, method = method, - alpha = alpha, handle.na = handle.na, ncores = ncores) + alpha = alpha, handle.na = handle.na, + test.type = test.type, ncores = ncores) } else { output <- Apply(data = list(exp = exp, obs = obs, ref = ref), target_dims = list(exp = time_dim, obs = time_dim, ref = time_dim), output_dims = output_dims, N.eff = N.eff, fun = .DiffCorr, method = method, - alpha = alpha, handle.na = handle.na, ncores = ncores) + alpha = alpha, handle.na = handle.na, + test.type = test.type, ncores = ncores) } return(output) } -.DiffCorr <- function(exp, obs, ref, N.eff = NA, method = 'pearson', alpha = NULL, handle.na = 'return.na') { - - .diff.corr <- function(exp, obs, ref, method = 'pearson', N.eff = NA, alpha = NULL) { +.DiffCorr <- function(exp, obs, ref, N.eff = NA, method = 'pearson', alpha = NULL, + handle.na = 'return.na', test.type = 'two.sided') { + .diff.corr <- function(exp, obs, ref, method = 'pearson', N.eff = NA, alpha = NULL, test.type = 'two.sided') { # Correlation difference cor.exp <- cor(x = exp, y = obs, method = method) cor.ref <- cor(x = ref, y = obs, method = method) output <- NULL output$diff.corr <- cor.exp - cor.ref + if (is.na(N.eff)) { + N.eff <- .Eno(x = obs, na.action = na.pass) ## effective degrees of freedom + } - # Significance with one-sided test for equality of dependent correlation coefficients (Steiger, 1980) + # Significance with one-sided or two-sided test for equality of dependent correlation coefficients (Steiger, 1980) r12 <- cor.exp r13 <- cor.ref r23 <- cor(exp, ref) - if (is.na(N.eff)) { - N.eff <- .Eno(x = obs, na.action = na.pass) ## effective degrees of freedom - } R <- (1 - r12 * r12 - r13 * r13 - r23 * r23) + 2 * r12 * r13 * r23 t <- (r12 - r13) * sqrt((N.eff - 1) * (1 + r23) / (2 * ((N.eff - 1) / (N.eff - 3)) * R + 0.25 * (r12 + r13)^2 * (1 - r23)^3)) - p.value <- 1 - pt(t, df = N.eff - 3) - if (is.null(alpha)) { - output$p.val <- p.value + + if (test.type == 'one-sided') { + + ## H0: the skill of exp is not higher than that of ref + ## H1: the skill of exp is higher than that of ref + + p.value <- pt(t, df = N.eff - 3, lower.tail = FALSE) + + if (is.null(alpha)) { + output$p.val <- p.value + } else { + output$sign <- ifelse(!is.na(p.value) & p.value <= alpha & output$diff.corr > 0, TRUE, FALSE) + } + + } else if (test.type == 'two-sided') { + + ## H0: the skill difference of exp and ref is zero + ## H1: the skill difference of exp and ref is different from zero + + p.value <- pt(abs(t), df = N.eff - 3, lower.tail = FALSE) + + if (is.null(alpha)) { + output$p.val <- p.value + } else { + output$sign <- ifelse(!is.na(p.value) & p.value <= alpha / 2, TRUE, FALSE) + } + } else { - output$sign <- ifelse(!is.na(p.value) & p.value <= alpha, TRUE, FALSE) + stop("Parameter 'test.type' is not supported.") } + return(output) } - + #================================================== if (anyNA(exp) | anyNA(obs) | anyNA(ref)) { ## There are NAs @@ -237,7 +280,7 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', ref <- ref[!nna] output <- .diff.corr(exp = exp, obs = obs, ref = ref, method = method, - N.eff = N.eff, alpha = alpha) + N.eff = N.eff, alpha = alpha, test.type = test.type) } else if (handle.na == 'return.na') { # Data contain NA, return NAs directly without passing to .diff.corr @@ -250,7 +293,8 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', } else { ## There is no NA output <- .diff.corr(exp = exp, obs = obs, ref = ref, method = method, - N.eff = N.eff, alpha = alpha) + N.eff = N.eff, alpha = alpha, test.type = test.type) } + return(output) } diff --git a/R/EOF.R b/R/EOF.R index d5c79a630f776f46eee54e932aa78a912a0118fc..66e69da59e93cae4384aab2289d6ef3dba248988 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -131,7 +131,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), "length as the longitude dimension of 'ano'.")) } if (any(lon > 360 | lon < -360)) { - warning("Some 'lon' is out of the range [-360, 360].") + .warning("Some 'lon' is out of the range [-360, 360].") } ## neofs if (!is.numeric(neofs) | neofs %% 1 != 0 | neofs <= 0 | length(neofs) > 1) { diff --git a/R/InsertDim.R b/R/InsertDim.R index 36ce2f87e4512e99577dd92aadfdef1a1fb97b60..533683d78f5c36863ed65d78e67983e8b8b1a0f2 100644 --- a/R/InsertDim.R +++ b/R/InsertDim.R @@ -52,7 +52,7 @@ InsertDim <- function(data, posdim, lendim, name = NULL, ncores = NULL) { if (is.null(name)) { if (is.null(names(lendim))) { name <- 'new' - warning("The name of new dimension is not given. Set the name as 'new'.") + .warning("The name of new dimension is not given. Set the name as 'new'.") } else { name <- names(lendim) } @@ -63,7 +63,7 @@ InsertDim <- function(data, posdim, lendim, name = NULL, ncores = NULL) { } ## ncores if (!missing("ncores")) - warning("Argument 'ncores' is deprecated.") + .warning("Argument 'ncores' is deprecated.", tag = '! Deprecation: ') ############################### # Calculate InsertDim diff --git a/R/Load.R b/R/Load.R index e188299aa3cbacc9ae8a4da0f19c6fa19ab29917..cca99bf3612242029f43ebeb9f54bf3bed45db58 100644 --- a/R/Load.R +++ b/R/Load.R @@ -1545,7 +1545,7 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, # If there are no experiments to load we need to choose a number of time steps # to load from observational datasets. We load from the first start date to # the current date. - if (is.null(exp) || dims == 0) { + if (is.null(exp) || identical(dims, 0)) { if (is.null(leadtimemax)) { diff <- Sys.time() - as.POSIXct(sdates[1], format = '%Y%m%d', tz = "UTC") if (diff > 0) { @@ -1866,12 +1866,12 @@ Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, if (!is.null(dim_exp) && (length(unlist(dim_exp)) == length(dim_exp)) && !anyNA(unlist(dim_exp)) && !any(unlist(dim_exp) == 0)) { var_exp <- big.matrix(nrow = prod(unlist(dim_exp)), ncol = 1) - pointer_var_exp <- describe(var_exp) + pointer_var_exp <- bigmemory::describe(var_exp) } if (!is.null(dim_obs) && (length(unlist(dim_obs)) == length(dim_obs)) && !anyNA(unlist(dim_obs)) && !any(unlist(dim_obs) == 0)) { var_obs <- big.matrix(nrow = prod(unlist(dim_obs)), ncol = 1) - pointer_var_obs <- describe(var_obs) + pointer_var_obs <- bigmemory::describe(var_obs) } if (is.null(nprocs)) { nprocs <- detectCores() diff --git a/R/NAO.R b/R/NAO.R index af4893ad0c5b904d0f62893f986282b4883d401d..6d48dba6aaec6eb8fc41dba2462c097e514ccc3f 100644 --- a/R/NAO.R +++ b/R/NAO.R @@ -194,7 +194,7 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', } if (throw_error) { stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'memb_dim'.")) + "of all the dimensions except 'memb_dim'.")) } } ## ftime_avg diff --git a/R/PlotEquiMap.R b/R/PlotEquiMap.R index ee10ec3aa4f2c42947f1b286b03a4f1e4d683bbf..2c98430d27e6418021ea52af30344b4b43bfbe8a 100644 --- a/R/PlotEquiMap.R +++ b/R/PlotEquiMap.R @@ -16,7 +16,9 @@ #' descending order and latitudes in any order. It can contain NA values #' (coloured with 'colNA'). Arrays with dimensions c(longitude, latitude) #' will also be accepted but 'lon' and 'lat' will be used to disambiguate so -#' this alternative is not appropriate for square arrays. +#' this alternative is not appropriate for square arrays. It is allowed that +#' the positions of the longitudinal and latitudinal coordinate dimensions +#' are interchanged. #'@param lon Numeric vector of longitude locations of the cell centers of the #' grid of 'var', in ascending or descending order (same as 'var'). Expected #' to be regularly spaced, within either of the ranges [-180, 180] or @@ -27,9 +29,11 @@ #' grid of 'var', in any order (same as 'var'). Expected to be from a regular #' rectangular or gaussian grid, within the range [-90, 90]. #'@param varu Array of the zonal component of wind/current/other field with -#' the same dimensions as 'var'. +#' the same dimensions as 'var'. It is allowed that the positions of the +#' longitudinal and latitudinal coordinate dimensions are interchanged. #'@param varv Array of the meridional component of wind/current/other field -#' with the same dimensions as 'var'. +#' with the same dimensions as 'var'. It is allowed that the positions of the +#' longitudinal and latitudinal coordinate dimensions are interchanged. #'@param toptitle Top title of the figure, scalable with parameter #' 'title_scale'. #'@param sizetit Scale factor for the figure top title provided in parameter @@ -52,8 +56,15 @@ #' colors returned by 'color_fun'. If not available, it takes 'pink' by #' default. 'col_inf' and 'col_sup' will take the value of 'colNA' if not #' specified. See ?ColorBar for a full explanation on 'col_inf' and 'col_sup'. -#'@param color_fun,subsampleg,bar_extra_labels,draw_bar_ticks,draw_separators,triangle_ends_scale,bar_label_digits,bar_label_scale,units_scale,bar_tick_scale,bar_extra_margin Set of parameters to control the visual -#' aspect of the drawn colour bar. See ?ColorBar for a full explanation. +#'@param color_fun,subsampleg,bar_extra_labels,draw_bar_ticks Set of +#' parameters to control the visual aspect of the drawn colour bar +#' (1/3). See ?ColorBar for a full explanation. +#'@param draw_separators,triangle_ends_scale,bar_label_digits Set of +#' parameters to control the visual aspect of the drawn colour bar +#' (2/3). See ?ColorBar for a full explanation. +#'@param bar_label_scale,units_scale,bar_tick_scale,bar_extra_margin Set of +#' parameters to control the visual aspect of the drawn colour bar (3/3). +#' See ?ColorBar for a full explanation. #'@param square Logical value to choose either to draw a coloured square for #' each grid cell in 'var' (TRUE; default) or to draw contour lines and fill #' the spaces in between with colours (FALSE). In the latter case, @@ -82,6 +93,8 @@ #'@param contours Array of same dimensions as 'var' to be added to the plot #' and displayed with contours. Parameter 'brks2' is required to define the #' magnitude breaks for each contour curve. Disregarded if 'square = FALSE'. +#' It is allowed that the positions of the longitudinal and latitudinal +#' coordinate dimensions are interchanged. #'@param brks2 Vector of magnitude breaks where to draw contour curves for the #' array provided in 'contours' or if 'square = FALSE'. #'@param contour_lwd Line width of the contour curves provided via 'contours' @@ -99,7 +112,8 @@ #' plot. A value of TRUE at a grid cell will draw a dot/symbol on the #' corresponding square of the plot. By default all layers provided in 'dots' #' are plotted with dots, but a symbol can be specified for each of the -#' layers via the parameter 'dot_symbol'. +#' layers via the parameter 'dot_symbol'. It is allowed that the positions of +#' the longitudinal and latitudinal coordinate dimensions are interchanged. #'@param dot_symbol Single character/number or vector of characters/numbers #' that correspond to each of the symbol layers specified in parameter 'dots'. #' If a single value is specified, it will be applied to all the layers in @@ -134,8 +148,8 @@ #'@param lab_dist_y A numeric of the distance of the latitude labels to the #' box borders. The default value is NULL and is automatically adjusted by #' the function. -#'@param degree_sym A logical indicating whether to include degree symbol (30° N) -#' or not (30N; default). +#'@param degree_sym A logical indicating whether to include degree symbol +#' (30° N) or not (30N; default). #'@param intylat Interval between latitude ticks on y-axis, in degrees. #' Defaults to 20. #'@param intxlon Interval between latitude ticks on x-axis, in degrees. @@ -289,91 +303,214 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, fileout <- deviceInfo$files } - # Preliminar check of dots, contours, varu, varv, lon, lat - if (!is.null(dots)) { - if (!is.array(dots) || !(length(dim(dots)) %in% c(2, 3))) { - stop("Parameter 'dots' must be a logical array with two or three dimensions.") - } - if (length(dim(dots)) == 2) { - dim(dots) <- c(1, dim(dots)) - } - } - if (!is.null(contours)) { - if (!is.array(contours) || !(length(dim(contours)) == 2)) { - stop("Parameter 'contours' must be a numerical array with two dimensions.") - } - } - if (!is.null(varu) && !is.null(varv)) { - if (!is.array(varu) || !(length(dim(varu)) == 2)) { - stop("Parameter 'varu' must be a numerical array with two dimensions.") - } - if (!is.array(varv) || !(length(dim(varv)) == 2)) { - stop("Parameter 'varv' must be a numerical array with two dimensions.") - } - } else if (!is.null(varu) || !is.null(varv)) { - stop("Only one of the components 'varu' or 'varv' has been provided. Both must be provided.") - } + # Check lon, lat if (!is.numeric(lon) || !is.numeric(lat)) { stop("Parameters 'lon' and 'lat' must be numeric vectors.") } # Check var + if (is.null(var)) { + stop("Parameter 'var' cannot be NULL.") + } if (!is.array(var)) { stop("Parameter 'var' must be a numeric array.") } - if (length(dim(var)) > 2) { - var <- drop(var) - dim(var) <- head(c(dim(var), 1, 1), 2) + + transpose <- FALSE + if (!is.null(names(dim(var)))) { + if (any(names(dim(var)) %in% .KnownLonNames()) && + any(names(dim(var)) %in% .KnownLatNames())) { + lon_dim <- names(dim(var))[names(dim(var)) %in% .KnownLonNames()] + lat_dim <- names(dim(var))[names(dim(var)) %in% .KnownLatNames()] + } else { + names(dim(var)) <- NULL + lat_dim <- NULL + lon_dim <- NULL + .warning("Dimension names of 'var' doesn't correspond to any coordinates names supported by s2dv package.") + } + } else { + lon_dim <- NULL + lat_dim <- NULL + .warning("Parameter 'var' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") } + if (length(dim(var)) > 2) { - stop("Parameter 'var' must be a numeric array with two dimensions. See PlotMultiMap() for multi-pannel maps or AnimateMap() for animated maps.") - } else if (length(dim(var)) < 2) { + if (!is.null(lon_dim) & !is.null(lat_dim)) { + dimnames <- names(dim(var)) + dim(var) <- dim(var)[which((dimnames == lon_dim | dimnames == lat_dim | dim(var) != 1))] + } else { + if (all(dim(var) == 1)) { + dim(var) <- c(1, 1) + } else if (length(dim(var)[which(dim(var) > 1)]) == 2) { + var <- drop(var) + } else if (length(dim(var)[which(dim(var) > 1)]) == 1) { + dim(var) <- c(dim(var)[which(dim(var) > 1)], 1) + } + } + } + + if (length(dim(var)) != 2) { stop("Parameter 'var' must be a numeric array with two dimensions.") } - dims <- dim(var) - # Transpose the input matrices because the base plot functions work directly - # with dimensions c(lon, lat). - transpose <- FALSE - if (!is.null(names(dims))) { - if (any(names(dims) %in% .KnownLonNames()) && - any(names(dims) %in% .KnownLatNames())) { - if (which(names(dims) %in% .KnownLonNames()) != 1) { + + if ((dim(var)[1] == length(lon) && dim(var)[2] == length(lat)) || + (dim(var)[2] == length(lon) && dim(var)[1] == length(lat))) { + if (dim(var)[2] == length(lon) && dim(var)[1] == length(lat)) { + if (length(lon) == length(lat)) { + if (is.null(names(dim(var)))) { + .warning("Parameter 'var' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the first and second dimensions.") + } else { + if (names(dim(var)[1]) == lat_dim) { + transpose <- TRUE + } + } + } else { transpose <- TRUE - } + } } + } else { + stop("Parameters 'lon' and 'lat' must have as many elements as the number of cells along longitudes and latitudes in the input array 'var'.") } - if (dims[1] != length(lon) || dims[2] != length(lat)) { - if (dims[1] == length(lat) && dims[2] == length(lon)) { - transpose <- TRUE + + if (!is.null(names(dim(var)))) { + if (names(dim(var)[1]) == lon_dim) { + if (transpose) { + stop("Coordinates dimensions of 'var' doesn't correspond to lat or lon.") + } + } else if (names(dim(var)[2]) == lon_dim) { + if (!transpose) { + stop("Coordinates dimensions of 'var' doesn't correspond to lat or lon.") + } } } + + # Transpose the input matrices because the base plot functions work directly + # with dimensions c(lon, lat). + if (transpose) { var <- t(var) - if (!is.null(varu)) varu <- t(varu) - if (!is.null(varv)) varv <- t(varv) - if (!is.null(contours)) contours <- t(contours) - if (!is.null(dots)) dots <- aperm(dots, c(1, 3, 2)) - dims <- dim(var) } - # Check lon - if (length(lon) != dims[1]) { - stop("Parameter 'lon' must have as many elements as the number of cells along longitudes in the input array 'var'.") - } + transpose <- FALSE - # Check lat - if (length(lat) != dims[2]) { - stop("Parameter 'lat' must have as many elements as the number of cells along longitudes in the input array 'var'.") - } + names(dim(var)) <- c(lon_dim, lat_dim) + dims <- dim(var) # Check varu and varv if (!is.null(varu) && !is.null(varv)) { - if (dim(varu)[1] != dims[1] || dim(varu)[2] != dims[2]) { - stop("Parameter 'varu' must have same number of longitudes and latitudes as 'var'.") + if (!is.array(varu) || !(length(dim(varu)) == 2)) { + stop("Parameter 'varu' must be a numerical array with two dimensions.") } - if (dim(varv)[1] != dims[1] || dim(varv)[2] != dims[2]) { - stop("Parameter 'varv' must have same number of longitudes and latitudes as 'var'.") + if (!is.array(varv) || !(length(dim(varv)) == 2)) { + stop("Parameter 'varv' must be a numerical array with two dimensions.") } + } else if (!is.null(varu) || !is.null(varv)) { + stop("Only one of the components 'varu' or 'varv' has been provided. Both must be provided.") + } + + if (!is.null(varu) && !is.null(varv)) { + if (!all(dim(varu) %in% dim(varv)) || !all(names(dim(varv)) %in% names(dim(varu)))) { + stop("Parameter 'varu' and 'varv' must have equal dimensions and dimension names.") + } else if (any(dim(varu) != dim(varv)) || any(names(dim(varv)) != names(dim(varu)))) { + varv <- t(varv) + names(dim(varv)) <- names(dim(varu)) + } + + if (is.null(lon_dim)) { + names(dim(varu)) <- NULL + names(dim(varv)) <- NULL + } else { + if (!is.null(names(dim(varu)))) { + if (!(lon_dim %in% names(dim(varu)) && lat_dim %in% names(dim(varu)))) { + stop("Parameters 'varu' and 'varv' must have same dimension names as 'var'.") + } else if (dim(varu)[lon_dim] != dim(var)[lon_dim] || dim(varu)[lat_dim] != dim(var)[lat_dim]) { + stop("Parameters 'varu' and 'varv' must have same dimensions as 'var'.") + } + } else { + .warning("Parameters 'varu' and 'varv' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") + } + } + + + if ((dim(varu)[1] == dims[1] && dim(varu)[2] == dims[2]) || + (dim(varu)[2] == dims[1] && dim(varu)[1] == dims[2])) { + if (dim(varu)[2] == dims[1] && dim(varu)[1] == dims[2]) { + if (length(lon) == length(lat)) { + if (is.null(names(dim(varu)))) { + .warning("Parameters 'varu' and 'varv' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the first and second dimensions.") + } else { + if (names(dim(varu)[1]) == lat_dim) { + transpose <- TRUE + } + } + } else { + transpose <- TRUE + } + } + } else { + stop("Parameters 'lon' and 'lat' must have as many elements as the number of cells along longitudes and latitudes in the input array 'varu' and 'varv'.") + } + + if (transpose) { + varu <- t(varu) + varv <- t(varv) + } + + transpose <- FALSE + + } + + # Check contours + if (!is.null(contours)) { + if (!is.array(contours) || !(length(dim(contours)) == 2)) { + stop("Parameter 'contours' must be a numerical array with two dimensions.") + } + } + + + if (!is.null(contours)) { + + if (is.null(lon_dim)) { + names(dim(contours)) <- NULL + } else { + if (!is.null(names(dim(contours)))) { + if (!(lon_dim %in% names(dim(contours)) && lat_dim %in% names(dim(contours)))) { + stop("Parameters 'contours' must have same dimension names as 'var'.") + } else if (dim(contours)[lon_dim] != dim(var)[lon_dim] || dim(contours)[lat_dim] != dim(var)[lat_dim]) { + stop("Parameters 'contours' must have same dimensions as 'var'.") + } + } else { + .warning("Parameters 'contours' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") + } + } + + + transpose <- FALSE + if ((dim(contours)[1] == dims[1] && dim(contours)[2] == dims[2]) || + (dim(contours)[2] == dims[1] && dim(contours)[1] == dims[2])) { + if (dim(contours)[2] == dims[1] && dim(contours)[1] == dims[2]) { + if (length(lon) == length(lat)) { + if (is.null(names(dim(contours)))) { + .warning("Parameter 'contours' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the first and second dimensions.") + } else { + if (names(dim(contours)[1]) == lat_dim) { + transpose <- TRUE + } + } + } else { + transpose <- TRUE + } + } + } else { + stop("Parameters 'lon' and 'lat' must have as many elements as the number of cells along longitudes and latitudes in the input array 'contours'.") + } + + if (transpose) { + contours <- t(contours) + } + + transpose <- FALSE + } # Check toptitle @@ -533,13 +670,6 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, stop("Parameter 'shapefile_color' must be a valid colour identifier.") } - # Check contours - if (!is.null(contours)) { - if (dim(contours)[1] != dims[1] || dim(contours)[2] != dims[2]) { - stop("Parameter 'contours' must have the same number of longitudes and latitudes as 'var'.") - } - } - # Check brks2 if (is.null(brks2)) { if (is.null(contours)) { @@ -579,11 +709,59 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, stop("Parameter 'contour_label_scale' must be numeric.") } - # Check dots, dot_symbol and dot_size + # Check dots if (!is.null(dots)) { - if (dim(dots)[2] != dims[1] || dim(dots)[3] != dims[2]) { - stop("Parameter 'dots' must have the same number of longitudes and latitudes as 'var'.") + if (!is.array(dots) || !(length(dim(dots)) %in% c(2, 3))) { + stop("Parameter 'dots' must be a logical array with two or three dimensions.") + } + if (length(dim(dots)) == 2) { + dim(dots) <- c(1, dim(dots)) + } + + if (is.null(lon_dim)) { + names(dim(dots)) <- NULL + } else { + if (!is.null(names(dim(dots)))) { + if (!(lon_dim %in% names(dim(dots)) && lat_dim %in% names(dim(dots)))) { + stop("Parameters 'dots' must have same dimension names as 'var'.") + } else if (dim(dots)[lon_dim] != dim(var)[lon_dim] || dim(dots)[lat_dim] != dim(var)[lat_dim]) { + stop("Parameters 'dots' must have same dimensions as 'var'.") + } + } else { + .warning("Parameters 'dots' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the corresponding coordinates dimensions.") + } } + + transpose <- FALSE + if ((dim(dots)[2] == dims[1] && dim(dots)[3] == dims[2]) || + (dim(dots)[3] == dims[1] && dim(dots)[2] == dims[2])) { + if (dim(dots)[3] == dims[1] && dim(dots)[2] == dims[2]) { + if (length(lon) == length(lat)) { + if (is.null(names(dim(dots)))) { + .warning("Parameter 'dots' should have dimension names. Coordinates 'lon' and 'lat' have been assigned into the first and second dimensions.") + } else { + if (names(dim(dots)[2]) == lat_dim) { + transpose <- TRUE + } + } + } else { + transpose <- TRUE + } + } + } else { + stop("Parameter 'dots' must have same number of longitudes and latitudes as 'var'.") + } + + if (transpose) { + dots <- aperm(dots, c(1, 3, 2)) + } + + transpose <- FALSE + + } + + # Check dot_symbol and dot_size + if (!is.null(dots)) { if (!is.numeric(dot_symbol) && !is.character(dot_symbol)) { stop("Parameter 'dot_symbol' must be a numeric or character string vector.") } @@ -748,9 +926,10 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # ~~~~~~~~~~~~~~~~~ # latb <- sort(lat, index.return = TRUE) - dlon <- lon[2:dims[1]] - lon[1:(dims[1] - 1)] + dlon <- diff(lon) wher <- which(dlon > (mean(dlon) + 1)) if (length(wher) > 0) { + .warning("Detect gap in 'lon' vector, which is considered as crossing the border.") lon[(wher + 1):dims[1]] <- lon[(wher + 1):dims[1]] - 360 } lonb <- sort(lon, index.return = TRUE) @@ -790,7 +969,7 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, ypos <- seq(latmin, latmax, intylat) + ylatshft if (length(ypos) != length(ylabels)) { stop(paste0("Parameter 'ylabels' must have the same length as the latitude ", - "vector spaced by 'intylat' (length = ", length(ypos), ").")) + "vector spaced by 'intylat' (length = ", length(ypos), ").")) } ylabs <- ylabels } else { @@ -811,7 +990,7 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, xpos <- seq(lonmin, lonmax, intxlon) + xlonshft if (length(xpos) != length(xlabels)) { stop(paste0("Parameter 'xlabels' must have the same length as the longitude ", - "vector spaced by 'intxlon' (length = ", length(xpos), ").")) + "vector spaced by 'intxlon' (length = ", length(xpos), ").")) } xlabs <- xlabels } else { @@ -942,7 +1121,7 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, # Plotting continents # ~~~~~~~~~~~~~~~~~~~~~ # - wrap_vec <- c(lon[1], lon[1] + 360) + wrap_vec <- c(lonb$x[1], lonb$x[1] + 360) old_lwd <- par('lwd') par(lwd = coast_width) # If [0, 360], use GEOmap; if [-180, 180], use maps::map diff --git a/R/PlotLayout.R b/R/PlotLayout.R index 742478e08db3ad08563ae00b6619379b9448bb9b..c442bf77311df2a1f6b5aa5149b2ffbb3f66ca25 100644 --- a/R/PlotLayout.R +++ b/R/PlotLayout.R @@ -101,6 +101,8 @@ #' (specified in 'row_titles' and 'col_titles'). Takes 1 by default. #'@param subtitle_margin_scale Scale factor for the margins surrounding the #' subtitles. Takes 1 by default. +#'@param subplot_titles_scale Scale factor for the subplots top titles. Takes +#' 1 by default. #'@param units Title at the top of the colour bar, most commonly the units of #' the variable provided in parameter 'var'. #'@param brks,cols,bar_limits,triangle_ends Usually only providing 'brks' is @@ -216,6 +218,7 @@ PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, title_scale = 1, title_margin_scale = 1, title_left_shift_scale = 1, subtitle_scale = 1, subtitle_margin_scale = 1, + subplot_titles_scale = 1, brks = NULL, cols = NULL, drawleg = 'S', titles = NULL, subsampleg = NULL, bar_limits = NULL, triangle_ends = NULL, col_inf = NULL, col_sup = NULL, @@ -392,6 +395,11 @@ PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, stop("Parameter 'subtite_margin_scale' must be numeric.") } + # Check subplot_titles_scale + if (!is.numeric(subplot_titles_scale)) { + stop("Parameter 'subplot_titles_scale' must be numeric.") + } + # Check titles if (!all(sapply(titles, is.character))) { stop("Parameter 'titles' must be a vector of character strings.") @@ -540,26 +548,45 @@ PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, title_margin <- 0.5 * title_cex * title_margin_scale subtitle_cex <- 1.5 * subtitle_scale subtitle_margin <- 0.5 * sqrt(nrow * ncol) * subtitle_cex * subtitle_margin_scale - mat_layout <- 1:(nrow * ncol) + ifelse(drawleg != FALSE, 1, 0) + mat_layout <- 1:(nrow * ncol) + if (drawleg != FALSE) { + if (all(fun %in% 'PlotMostLikelyQuantileMap')) { #multi_colorbar + multi_colorbar <- TRUE + cat_dim <- list(...)$cat_dim + if (is.null(cat_dim)) cat_dim <- 'bin' # default + nmap <- as.numeric(dim(var[[1]])[cat_dim]) + minimum_value <- ceiling(1 / nmap * 10 * 1.1) * 10 + display_range = c(minimum_value, 100) + mat_layout <- mat_layout + nmap + } else { + multi_colorbar <- FALSE + mat_layout <- mat_layout + 1 + } + } mat_layout <- matrix(mat_layout, nrow, ncol, byrow = layout_by_rows) fsu <- figure_size_units <- 10 # unitless widths <- rep(fsu, ncol) heights <- rep(fsu, nrow) - n_figures <- nrow * ncol - if (length(row_titles) > 0) { - mat_layout <- cbind(rep(0, dim(mat_layout)[1]), mat_layout) - widths <- c(((subtitle_cex + subtitle_margin / 2) * cs / device_size[1]) * ncol * fsu, widths) - } - if (length(col_titles) > 0) { - mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout) - heights <- c(((subtitle_cex + subtitle_margin) * cs / device_size[2]) * nrow * fsu, heights) - } + # Useless +# n_figures <- nrow * ncol + if (drawleg != FALSE) { if (drawleg == 'N') { mat_layout <- rbind(rep(1, dim(mat_layout)[2]), mat_layout) heights <- c(round(bar_scale * 2 * nrow), heights) } else if (drawleg == 'S') { - mat_layout <- rbind(mat_layout, rep(1, dim(mat_layout)[2])) + if (multi_colorbar) { + new_mat_layout <- c() + for (i_col in 1:ncol) { + new_mat_layout <- c(new_mat_layout, rep(mat_layout[, i_col], nmap)) + } + new_mat_layout <- matrix(new_mat_layout, nrow, nmap * ncol) + colorbar_row <- rep(1:nmap, each = ncol) + mat_layout <- rbind(new_mat_layout, as.numeric(colorbar_row)) + widths <- rep(widths, nmap) + } else { + mat_layout <- rbind(mat_layout, rep(1, dim(mat_layout)[2])) + } heights <- c(heights, round(bar_scale * 2 * nrow)) } else if (drawleg == 'W') { mat_layout <- cbind(rep(1, dim(mat_layout)[1]), mat_layout) @@ -568,8 +595,20 @@ PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, mat_layout <- cbind(mat_layout, rep(1, dim(mat_layout)[1])) widths <- c(widths, round(bar_scale * 3 * ncol)) } - n_figures <- n_figures + 1 + # Useless +# n_figures <- n_figures + 1 } + + # row and col titles + if (length(row_titles) > 0) { + mat_layout <- cbind(rep(0, dim(mat_layout)[1]), mat_layout) + widths <- c(((subtitle_cex + subtitle_margin / 2) * cs / device_size[1]) * ncol * fsu, widths) + } + if (length(col_titles) > 0) { + mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout) + heights <- c(((subtitle_cex + subtitle_margin) * cs / device_size[2]) * nrow * fsu, heights) + } + # toptitle if (toptitle != '') { mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout) heights <- c(((title_cex + title_margin) * cs / device_size[2]) * nrow * fsu, heights) @@ -582,13 +621,32 @@ PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, bar_extra_margin[2] <- bar_extra_margin[2] + (subtitle_cex + subtitle_margin / 2) * bar_left_shift_scale } - ColorBar(colorbar$brks, colorbar$cols, vertical, subsampleg, - bar_limits, var_limits, - triangle_ends = triangle_ends, col_inf = colorbar$col_inf, - col_sup = colorbar$col_sup, color_fun, plot = TRUE, draw_bar_ticks, - draw_separators, triangle_ends_scale, bar_extra_labels, - units, units_scale, bar_label_scale, bar_tick_scale, - bar_extra_margin, bar_label_digits) + + if (multi_colorbar) { # multiple colorbar + if (!is.null(list(...)$bar_titles)) { + bar_titles <- list(...)$bar_titles + } else { + bar_titles <- NULL + } + GradientCatsColorBar(nmap = nmap, + brks = brks, cols = cols, vertical = vertical, subsampleg = subsampleg, + bar_limits = display_range, var_limits = var_limits, + triangle_ends = triangle_ends, plot = TRUE, + draw_separators = draw_separators, + bar_titles = bar_titles, title_scale = units_scale, + label_scale = bar_label_scale, extra_margin = bar_extra_margin) + + } else { # one colorbar + ColorBar(brks = colorbar$brks, cols = colorbar$cols, vertical = vertical, subsampleg = subsampleg, + bar_limits = bar_limits, var_limits = var_limits, + triangle_ends = triangle_ends, col_inf = colorbar$col_inf, + col_sup = colorbar$col_sup, color_fun = color_fun, plot = TRUE, draw_ticks = draw_bar_ticks, + draw_separators = draw_separators, triangle_ends_scale = triangle_ends_scale, + extra_labels = bar_extra_labels, + title = units, title_scale = units_scale, label_scale = bar_label_scale, tick_scale = bar_tick_scale, + extra_margin = bar_extra_margin, label_digits = bar_label_digits) + + } } # Draw titles @@ -657,19 +715,26 @@ PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, # For each of the arrays provided in that array apply(x, (1:length(dim(x)))[-plot_dim_indices], function(y) { - # Do the plot - fun_args <- c(list(y, toptitle = titles[plot_number]), list(...), + # Do the plot. colorbar is not drew. + fun_args <- c(list(y, toptitle = titles[plot_number], drawleg = FALSE), list(...), special_args[[array_number]]) - funct <- fun[[array_number]] - if (fun[[array_number]] %in% c('PlotEquiMap', 'PlotStereoMap', 'PlotSection')) { +# funct <- fun[[array_number]] + if (fun[[array_number]] %in% c('PlotEquiMap', 'PlotStereoMap')) { fun_args <- c(fun_args, list(brks = colorbar$brks, cols = colorbar$cols, col_inf = colorbar$col_inf, col_sup = colorbar$col_sup, - drawleg = FALSE)) + title_scale = subplot_titles_scale # when all the functions have this argument, put it above in fun_args + )) + } else if (fun[[array_number]] == c('PlotSection')) { + fun_args <- c(fun_args, list(brks = colorbar$brks, cols = colorbar$cols)) + + } else if (fun[[array_number]] %in% 'PlotMostLikelyQuantileMap') { + #TODO: pre-generate colorbar params? like above + fun_args <- c(fun_args, list(brks = brks, cols = cols)) } do.call(fun[[array_number]], fun_args) plot_number <<- plot_number + 1 - }) + }) } array_number <<- array_number + 1 }) diff --git a/R/REOF.R b/R/REOF.R index 2def222614b84ff7f15a772eb5092ff22691b6ce..c9c82cf94e1091f88ea7a8c71dd2957e5079de80 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -146,9 +146,9 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', # ntrunc is bounded if (ntrunc != min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), ntrunc)) { ntrunc <- min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), ntrunc) - warning(paste0("Parameter 'ntrunc' is changed to ", ntrunc, ", the minimum among ", - "the length of time_dim, the production of the length of space_dim, ", - "and ntrunc.")) + .warning(paste0("Parameter 'ntrunc' is changed to ", ntrunc, ", the minimum among ", + "the length of time_dim, the production of the length of space_dim, ", + "and ntrunc.")) } # Area weighting is needed to compute the fraction of variance explained by diff --git a/R/RMS.R b/R/RMS.R index b3c8ad4b016d18cc9f3dfd79ddaeb3bb38ba15b0..b3188fcd045518458cec57415c4bcd7da3b5621a 100644 --- a/R/RMS.R +++ b/R/RMS.R @@ -107,11 +107,14 @@ RMS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") } ## dat_dim - if (!is.character(dat_dim) | length(dat_dim) > 1) { - stop("Parameter 'dat_dim' must be a character string.") - } - if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { - stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string or NULL.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + "Set it as NULL if there is no dataset dimension.") + } } ## comp_dim if (!is.null(comp_dim)) { @@ -151,11 +154,13 @@ RMS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) - name_exp <- name_exp[-which(name_exp == dat_dim)] - name_obs <- name_obs[-which(name_obs == dat_dim)] + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension expect 'dat_dim'.")) + "all dimension except 'dat_dim'.")) } if (dim(exp)[time_dim] < 2) { stop("The length of time_dim must be at least 2 to compute RMS.") @@ -196,12 +201,22 @@ RMS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', } .RMS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', - conf = TRUE, conf.lev = 0.95, ncores_input = NULL) { - - # exp: [sdate, dat_exp] - # obs: [sdate, dat_obs] - nexp <- as.numeric(dim(exp)[2]) - nobs <- as.numeric(dim(obs)[2]) + conf = TRUE, conf.lev = 0.95, ncores_input = NULL) { + if (is.null(dat_dim)) { + # exp: [sdate] + # obs: [sdate] + nexp <- 1 + nobs <- 1 + ini_dims <- dim(exp) + dim(exp) <- c(ini_dims, dat_dim = 1) + dim(obs) <- c(ini_dims, dat_dim = 1) + } else { + # exp: [sdate, dat_exp] + # obs: [sdate, dat_obs] + nexp <- as.numeric(dim(exp)[2]) + nobs <- as.numeric(dim(obs)[2]) + } + nsdate <- as.numeric(dim(exp)[1]) dif <- array(dim = c(sdate = nsdate, nexp = nexp, nobs = nobs)) @@ -236,6 +251,16 @@ RMS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', conf.upper <- (eno * rms ** 2 / chi) ** 0.5 } + ################################### + # Remove nexp and nobs if dat_dim = NULL + if (is.null(dat_dim)) { + dim(rms) <- NULL + dim(conf.lower) <- NULL + dim(conf.upper) <- NULL + } + + ################################### + if (conf) { res <- list(rms = rms, conf.lower = conf.lower, conf.upper = conf.upper) } else { diff --git a/R/RMSSS.R b/R/RMSSS.R index 5fa96596ebacc4a2d46ed4f9e511adf504eb3e04..e44105cea96ba9f14c2e96f8488f4cc986c9826d 100644 --- a/R/RMSSS.R +++ b/R/RMSSS.R @@ -96,11 +96,14 @@ RMSSS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") } ## dat_dim - if (!is.character(dat_dim) | length(dat_dim) > 1) { - stop("Parameter 'dat_dim' must be a character string.") - } - if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { - stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string or NULL.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } } ## pval if (!is.logical(pval) | length(pval) > 1) { @@ -116,11 +119,13 @@ RMSSS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) + if (!is.null(dat_dim)) { name_exp <- name_exp[-which(name_exp == dat_dim)] name_obs <- name_obs[-which(name_obs == dat_dim)] + } if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension expect 'dat_dim'.")) + "all dimension except 'dat_dim'.")) } if (dim(exp)[time_dim] <= 2) { stop("The length of time_dim must be more than 2 to compute RMSSS.") @@ -151,10 +156,20 @@ RMSSS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', .RMSSS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', pval = TRUE, ncores_input = NULL) { + if (is.null(dat_dim)) { + # exp: [sdate] + # obs: [sdate] + nexp <- 1 + nobs <- 1 + dim(exp) <- c(dim(exp), nexp = nexp) + dim(obs) <- c(dim(obs), nobs = nobs) + } else { # exp: [sdate, dat_exp] # obs: [sdate, dat_obs] - nexp <- as.numeric(dim(exp)[2]) - nobs <- as.numeric(dim(obs)[2]) + nexp <- as.numeric(dim(exp)[2]) + nobs <- as.numeric(dim(obs)[2]) + } + nsdate <- as.numeric(dim(exp)[1]) p_val <- array(dim = c(nexp = nexp, nobs = nobs)) @@ -208,6 +223,14 @@ RMSSS <- function(exp, obs, time_dim = 'sdate', dat_dim = 'dataset', rmsss[which(!tmp)] <- NA } + ################################### + # Remove extra dimensions if dat_dim = NULL + if (is.null(dat_dim)) { + dim(rmsss) <- NULL + dim(p_val) <- NULL + } + ################################### + # output if (pval) { res <- list(rmsss = rmsss, p.val = p_val) diff --git a/R/RPS.R b/R/RPS.R index 8ded53e6d1546373f065bca04f07d12bebfbc73a..76c81d254bf8758327290ba8946f7dfc9e7aad77 100644 --- a/R/RPS.R +++ b/R/RPS.R @@ -9,14 +9,19 @@ #'categories. In the case of a forecast divided into two categories (the lowest #'number of categories that a probabilistic forecast can have), the RPS #'corresponds to the Brier Score (BS; Wilks, 2011), therefore, ranges between 0 -#'and 1. +#'and 1. If there is more than one dataset, RPS will be computed for each pair +#'of exp and obs data. #' -#'@param exp A named numerical array of the forecast with at least time -#' dimension. +#'@param exp A named numerical array of the forecast with at least time and +#' member dimension. #'@param obs A named numerical array of the observation with at least time -#' dimension. The dimensions must be the same as 'exp' except 'memb_dim'. +#' dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +#' 'dat_dim'. #'@param time_dim A character string indicating the name of the time dimension. #' The default value is 'sdate'. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' The length of this dimension can be different between 'exp' and 'obs'. +#' The default value is NULL. #'@param memb_dim A character string indicating the name of the member dimension #' to compute the probabilities of the forecast. The default value is 'member'. #'@param prob_thresholds A numeric vector of the relative thresholds (from 0 to @@ -25,20 +30,23 @@ #'@param indices_for_clim A vector of the indices to be taken along 'time_dim' #' for computing the thresholds between the probabilistic categories. If NULL, #' the whole period is used. The default value is NULL. -#'@param Fair A logical indicating whether to compute the FairRPSS (the -#' potential RPSS that the forecast would have with an infinite ensemble size). +#'@param Fair A logical indicating whether to compute the FairRPS (the +#' potential RPS that the forecast would have with an infinite ensemble size). #' The default value is FALSE. -#'@param weights A named two-dimensional numerical array of the weights for each -#' member and time. The dimension names should include 'memb_dim' and -#' 'time_dim'. The default value is NULL. The ensemble should have at least 70 -#' members or span at least 10 time steps and have more than 45 members if -#' consistency between the weighted and unweighted methodologies is desired. +#'@param weights A named numerical array of the weights for 'exp'. If 'dat_dim' +#' is NULL, the dimension should include 'memb_dim' and 'time_dim'. Else, the +#' dimension should also include 'dat_dim'. The default value is NULL. The +#' ensemble should have at least 70 members or span at least 10 time steps and +#' have more than 45 members if consistency between the weighted and unweighted +#' methodologies is desired. #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' #'@return -#'A numerical array of RPS with the same dimensions as "exp" except the -#''time_dim' and 'memb_dim' dimensions. +#'A numerical array of RPS with dimensions c(nexp, nobs, the rest dimensions of +#''exp' except 'time_dim' and 'memb_dim' dimensions). nexp is the number of +#'experiment (i.e., dat_dim in exp), and nobs is the number of observation +#'(i.e., dat_dim in obs). If dat_dim is NULL, nexp and nobs are omitted. #' #'@references #'Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 @@ -51,7 +59,7 @@ #'@import multiApply #'@importFrom easyVerification convert2prob #'@export -RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', +RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, weights = NULL, ncores = NULL) { @@ -78,6 +86,16 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', if (!memb_dim %in% names(dim(exp))) { stop("Parameter 'memb_dim' is not found in 'exp' dimension.") } + ## dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + } ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) @@ -85,10 +103,14 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', if (memb_dim %in% name_obs) { name_obs <- name_obs[-which(name_obs == memb_dim)] } + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions expect 'memb_dim'.")) + "all dimensions except 'memb_dim' and 'dat_dim'.")) } ## prob_thresholds if (!is.numeric(prob_thresholds) | !is.vector(prob_thresholds) | @@ -114,14 +136,29 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', ## weights if (!is.null(weights)) { if (!is.array(weights) | !is.numeric(weights)) - stop('Parameter "weights" must be a two-dimensional numeric array.') - if (length(dim(weights)) != 2 | any(!names(dim(weights)) %in% c(memb_dim, time_dim))) - stop("Parameter 'weights' must have two dimensions with the names of memb_dim and time_dim.") - if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | - dim(weights)[time_dim] != dim(exp)[time_dim]) { - stop("Parameter 'weights' must have the same dimension lengths as memb_dim and time_dim in 'exp'.") + stop("Parameter 'weights' must be a named numeric array.") + if (is.null(dat_dim)) { + if (length(dim(weights)) != 2 | any(!names(dim(weights)) %in% c(memb_dim, time_dim))) + stop("Parameter 'weights' must have two dimensions with the names of 'memb_dim' and 'time_dim'.") + if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | + dim(weights)[time_dim] != dim(exp)[time_dim]) { + stop(paste0("Parameter 'weights' must have the same dimension lengths ", + "as 'memb_dim' and 'time_dim' in 'exp'.")) + } + weights <- Reorder(weights, c(time_dim, memb_dim)) + + } else { + if (length(dim(weights)) != 3 | any(!names(dim(weights)) %in% c(memb_dim, time_dim, dat_dim))) + stop("Parameter 'weights' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") + if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | + dim(weights)[time_dim] != dim(exp)[time_dim] | + dim(weights)[dat_dim] != dim(exp)[dat_dim]) { + stop(paste0("Parameter 'weights' must have the same dimension lengths ", + "as 'memb_dim', 'time_dim' and 'dat_dim' in 'exp'.")) + } + weights <- Reorder(weights, c(time_dim, memb_dim, dat_dim)) + } - weights <- Reorder(weights, c(time_dim, memb_dim)) } ## ncores if (!is.null(ncores)) { @@ -135,19 +172,20 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', # Compute RPS if (!memb_dim %in% names(dim(obs))) { - target_dims_obs <- time_dim + target_dims_obs <- c(time_dim, dat_dim) } else { - target_dims_obs <- c(time_dim, memb_dim) + target_dims_obs <- c(time_dim, memb_dim, dat_dim) } rps <- Apply(data = list(exp = exp, obs = obs), - target_dims = list(exp = c(time_dim, memb_dim), + target_dims = list(exp = c(time_dim, memb_dim, dat_dim), obs = target_dims_obs), - output_dims = time_dim, fun = .RPS, + dat_dim = dat_dim, time_dim = time_dim, + memb_dim = memb_dim, prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim, Fair = Fair, weights = weights, ncores = ncores)$output1 - # browser() + # Return only the mean RPS rps <- MeanDims(rps, time_dim, na.rm = FALSE) @@ -155,28 +193,69 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', } -.RPS <- function(exp, obs, prob_thresholds = c(1/3, 2/3), - indices_for_clim = NULL, Fair = FALSE, weights = NULL) { - # exp: [sdate, memb] - # obs: [sdate, (memb)] - exp_probs <- .get_probs(data = exp, indices_for_quantiles = indices_for_clim, prob_thresholds = prob_thresholds, weights = weights) - # exp_probs: [bin, sdate] - obs_probs <- .get_probs(data = obs, indices_for_quantiles = indices_for_clim, - prob_thresholds = prob_thresholds, weights = NULL) - # obs_probs: [bin, sdate] - - probs_exp_cumsum <- apply(exp_probs, 2, cumsum) - probs_obs_cumsum <- apply(obs_probs, 2, cumsum) - rps <- apply((probs_exp_cumsum - probs_obs_cumsum)^2, 2, sum) - # rps: [sdate] - - if (Fair) { # FairRPS - ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps] - R <- dim(exp)[2] #memb - R_new <- Inf - adjustment <- (-1) / (R - 1) * probs_exp_cumsum * (1 - probs_exp_cumsum) - adjustment <- apply(adjustment, 2, sum) - rps <- rps + adjustment +.RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, + prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, weights = NULL) { + + # exp: [sdate, memb, (dat)] + # obs: [sdate, (memb), (dat)] + # weights: NULL or same as exp + + # Adjust dimensions to be [sdate, memb, dat] for both exp and obs + if (!memb_dim %in% names(dim(obs))) obs <- InsertDim(obs, posdim = 2, lendim = 1, name = memb_dim) + + if (is.null(dat_dim)) { + nexp <- 1 + nobs <- 1 + dim(exp) <- c(dim(exp), nexp = nexp) + dim(obs) <- c(dim(obs), nobs = nobs) + if (!is.null(weights)) dim(weights) <- c(dim(weights), nexp = nexp) + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + } + + rps <- array(dim = c(dim(exp)[time_dim], nexp = nexp, nobs = nobs)) + + for (i in 1:nexp) { + for (j in 1:nobs) { + exp_data <- exp[ , , i] + obs_data <- obs[ , , j] + + if (is.null(dim(exp_data))) dim(exp_data) <- c(dim(exp)[1:2]) + if (is.null(dim(obs_data))) dim(obs_data) <- c(dim(obs)[1:2]) + + if (!is.null(weights)) { + weights_data <- weights[ , , i] + if (is.null(dim(weights_data))) dim(weights_data) <- c(dim(weights)[1:2]) + } else { + weights_data <- weights + } + + exp_probs <- .get_probs(data = exp_data, indices_for_quantiles = indices_for_clim, + prob_thresholds = prob_thresholds, weights = weights_data) + # exp_probs: [bin, sdate] + obs_probs <- .get_probs(data = obs_data, indices_for_quantiles = indices_for_clim, + prob_thresholds = prob_thresholds, weights = NULL) + # obs_probs: [bin, sdate] + probs_exp_cumsum <- apply(exp_probs, 2, cumsum) + probs_obs_cumsum <- apply(obs_probs, 2, cumsum) + + # rps: [sdate, nexp, nobs] + rps[ , i, j] <- apply((probs_exp_cumsum - probs_obs_cumsum)^2, 2, sum) + + if (Fair) { # FairRPS + ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps] + R <- dim(exp)[2] #memb + R_new <- Inf + adjustment <- (-1) / (R - 1) * probs_exp_cumsum * (1 - probs_exp_cumsum) + adjustment <- apply(adjustment, 2, sum) + rps[ , i, j] <- rps[ , i, j] + adjustment + } + } + } + + if (is.null(dat_dim)) { + dim(rps) <- dim(exp)[time_dim] } return(rps) diff --git a/R/RPSS.R b/R/RPSS.R index 3b24777ddde51eaab88286ca6479a07724e7eeb3..3d50d2bc554317949a4f2bba8c25d928502eddef 100644 --- a/R/RPSS.R +++ b/R/RPSS.R @@ -8,23 +8,32 @@ #'reference forecast, while a negative value means that it has a lower skill. #'Examples of reference forecasts are the climatological forecast (same #'probabilities for all categories for all time steps), persistence, a previous -#'model version, and another model. It is computed as RPSS = 1 - RPS_exp / RPS_ref. -#'The statistical significance is obtained based on a Random Walk test at the -#'95% confidence level (DelSole and Tippett, 2016). +#'model version, and another model. It is computed as +#'\code{RPSS = 1 - RPS_exp / RPS_ref}. The statistical significance is obtained +#'based on a Random Walk test at the 95% confidence level (DelSole and Tippett, +#'2016). If there is more than one dataset, RPS will be computed for each pair +#'of exp and obs data. #' -#'@param exp A named numerical array of the forecast with at least time -#' dimension. +#'@param exp A named numerical array of the forecast with at least time and +#' member dimension. #'@param obs A named numerical array of the observation with at least time -#' dimension. The dimensions must be the same as 'exp' except 'memb_dim'. +#' dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +#' 'dat_dim'. #'@param ref A named numerical array of the reference forecast data with at -#' least time dimension. The dimensions must be the same as 'exp' except -#' 'memb_dim'. If it is NULL, the climatological forecast is used as reference +#' least time and member dimension. The dimensions must be the same as 'exp' +#' except 'memb_dim' and 'dat_dim'. If there is only one reference dataset, +#' it should not have dataset dimension. If there is corresponding reference +#' for each experiement, the dataset dimension must have the same length as in +#' 'exp'. If 'ref' is NULL, the climatological forecast is used as reference #' forecast. The default value is NULL. #'@param time_dim A character string indicating the name of the time dimension. #' The default value is 'sdate'. #'@param memb_dim A character string indicating the name of the member dimension #' to compute the probabilities of the forecast and the reference forecast. The #' default value is 'member'. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' The length of this dimension can be different between 'exp' and 'obs'. +#' The default value is NULL. #'@param prob_thresholds A numeric vector of the relative thresholds (from 0 to #' 1) between the categories. The default value is c(1/3, 2/3), which #' corresponds to tercile equiprobable categories. @@ -34,22 +43,29 @@ #'@param Fair A logical indicating whether to compute the FairRPSS (the #' potential RPSS that the forecast would have with an infinite ensemble size). #' The default value is FALSE. -#'@param weights A named two-dimensional numerical array of the weights for each -#' member and time. The dimension names should include 'memb_dim' and -#' 'time_dim'. The default value is NULL. The ensemble should have at least 70 -#' members or span at least 10 time steps and have more than 45 members if -#' consistency between the weighted and unweighted methodologies is desired. +#'@param weights Deprecated and will be removed in the next release. Please use +#' 'weights_exp' and 'weights_ref' instead. +#'@param weights_exp A named numerical array of the forecast ensemble weights. +#' The dimension should include 'memb_dim', 'time_dim' and 'dat_dim' if there +#' are multiple datasets. All dimension lengths must be equal to 'exp' +#' dimension lengths. The default value is NULL, which means no weighting is +#' applied. The ensemble should have at least 70 members or span at least 10 +#' time steps and have more than 45 members if consistency between the weighted +#' and unweighted methodologies is desired. +#'@param weights_ref Same as 'weights_exp' but for the reference forecast. #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' #'@return #'\item{$rpss}{ -#' A numerical array of the RPSS with the same dimensions as "exp" except the -#' 'time_dim' and 'memb_dim' dimensions. +#' A numerical array of RPSS with dimensions c(nexp, nobs, the rest dimensions +#' of 'exp' except 'time_dim' and 'memb_dim' dimensions). nexp is the number of +#' experiment (i.e., dat_dim in exp), and nobs is the number of observation +#' i.e., dat_dim in obs). If dat_dim is NULL, nexp and nobs are omitted. #'} #'\item{$sign}{ -#' A logical array of the statistical significance of the RPSS with the same -#' dimensions as 'exp' except the 'time_dim' and 'memb_dim' dimensions. +#' A logical array of the statistical significance of the RPSS with the same +#' dimensions as $rpss. #'} #' #'@references @@ -57,31 +73,49 @@ #'DelSole and Tippett, 2016; https://doi.org/10.1175/MWR-D-15-0218.1 #' #'@examples -#'exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) -#'obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) -#'ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +#'set.seed(1) +#'exp <- array(rnorm(3000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +#'set.seed(2) +#'obs <- array(rnorm(300), dim = c(lat = 3, lon = 2, sdate = 50)) +#'set.seed(3) +#'ref <- array(rnorm(3000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +#'weights <- sapply(1:dim(exp)['sdate'], function(i) { +#' n <- abs(rnorm(10)) +#' n/sum(n) +#' }) +#'dim(weights) <- c(member = 10, sdate = 50) #'res <- RPSS(exp = exp, obs = obs) ## climatology as reference forecast #'res <- RPSS(exp = exp, obs = obs, ref = ref) ## ref as reference forecast -#' +#'res <- RPSS(exp = exp, obs = obs, ref = ref, weights_exp = weights, weights_ref = weights) #'@import multiApply #'@export RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', - prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, - weights = NULL, ncores = NULL) { + dat_dim = NULL, prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, + Fair = FALSE, weights = NULL, weights_exp = NULL, weights_ref = NULL, ncores = NULL) { # Check inputs ## exp, obs, and ref (1) - if (!is.array(exp) | !is.numeric(exp)) - stop('Parameter "exp" must be a numeric array.') - if (!is.array(obs) | !is.numeric(obs)) - stop('Parameter "obs" must be a numeric array.') + if (!is.array(exp) | !is.numeric(exp)) { + stop("Parameter 'exp' must be a numeric array.") + } + if (!is.array(obs) | !is.numeric(obs)) { + stop("Parameter 'obs' must be a numeric array.") + } + if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } if (!is.null(ref)) { if (!is.array(ref) | !is.numeric(ref)) - stop('Parameter "ref" must be a numeric array.') + stop("Parameter 'ref' must be a numeric array.") + if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + stop("Parameter 'ref' must have dimension names.") + } } ## time_dim - if (!is.character(time_dim) | length(time_dim) != 1) - stop('Parameter "time_dim" must be a character string.') + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") } @@ -98,25 +132,49 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.null(ref) & !memb_dim %in% names(dim(ref))) { stop("Parameter 'memb_dim' is not found in 'ref' dimension.") } - ## exp and obs (2) + ## dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") + } + } + ## exp, obs, and ref (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) name_exp <- name_exp[-which(name_exp == memb_dim)] if (memb_dim %in% name_obs) { name_obs <- name_obs[-which(name_obs == memb_dim)] } + if (!is.null(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim)] + name_obs <- name_obs[-which(name_obs == dat_dim)] + } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions expect 'memb_dim'.")) + "all dimensions except 'memb_dim' and 'dat_dim'.")) } if (!is.null(ref)) { name_ref <- sort(names(dim(ref))) name_ref <- name_ref[-which(name_ref == memb_dim)] + if (!is.null(dat_dim)) { + if (dat_dim %in% name_ref) { + if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { + stop(paste0("If parameter 'ref' has dataset dimension, it must be", + " equal to dataset dimension of 'exp'.")) + } + name_ref <- name_ref[-which(name_ref == dat_dim)] + } + } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions expect 'memb_dim'.")) + stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.")) } } ## prob_thresholds @@ -137,20 +195,70 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } } ## Fair - if (!is.logical(Fair) | length(Fair) > 1) { + if (!is.logical(Fair) | length(Fair) > 1) { stop("Parameter 'Fair' must be either TRUE or FALSE.") } ## weights if (!is.null(weights)) { - if (!is.array(weights) | !is.numeric(weights)) - stop('Parameter "weights" must be a two-dimensional numeric array.') - if (length(dim(weights)) != 2 | any(!names(dim(weights)) %in% c(memb_dim, time_dim))) - stop("Parameter 'weights' must have two dimensions with the names of memb_dim and time_dim.") - if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | - dim(weights)[time_dim] != dim(exp)[time_dim]) { - stop("Parameter 'weights' must have the same dimension lengths as memb_dim and time_dim in 'exp'.") + .warning(paste0("Parameter 'weights' is deprecated and will be removed in the next release. ", + "Use 'weights_exp' and 'weights_ref' instead. The value will be assigned ", + "to these two parameters now if they are NULL."), tag = '! Deprecation: ') + if (is.null(weights_exp)) weights_exp <- weights + if (is.null(weights_ref)) weights_ref <- weights + } + ## weights_exp + if (!is.null(weights_exp)) { + if (!is.array(weights_exp) | !is.numeric(weights_exp)) + stop("Parameter 'weights_exp' must be a named numeric array.") + + if (is.null(dat_dim)) { + if (length(dim(weights_exp)) != 2 | any(!names(dim(weights_exp)) %in% c(memb_dim, time_dim))) + stop("Parameter 'weights_exp' must have two dimensions with the names of 'memb_dim' and 'time_dim'.") + if (dim(weights_exp)[memb_dim] != dim(exp)[memb_dim] | + dim(weights_exp)[time_dim] != dim(exp)[time_dim]) { + stop("Parameter 'weights_exp' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'exp'.") + } + weights_exp <- Reorder(weights_exp, c(time_dim, memb_dim)) + + } else { + if (length(dim(weights_exp)) != 3 | any(!names(dim(weights_exp)) %in% c(memb_dim, time_dim, dat_dim))) + stop("Parameter 'weights_exp' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") + if (dim(weights_exp)[memb_dim] != dim(exp)[memb_dim] | + dim(weights_exp)[time_dim] != dim(exp)[time_dim] | + dim(weights_exp)[dat_dim] != dim(exp)[dat_dim]) { + stop(paste0("Parameter 'weights_exp' must have the same dimension lengths ", + "as 'memb_dim', 'time_dim' and 'dat_dim' in 'exp'.")) + } + weights_exp <- Reorder(weights_exp, c(time_dim, memb_dim, dat_dim)) } - weights <- Reorder(weights, c(time_dim, memb_dim)) + + } + ## weights_ref + if (!is.null(weights_ref)) { + if (!is.array(weights_ref) | !is.numeric(weights_ref)) + stop('Parameter "weights_ref" must be a named numeric array.') + + if (is.null(dat_dim) | ((!is.null(dat_dim)) && (!dat_dim %in% names(dim(ref))))) { + if (length(dim(weights_ref)) != 2 | any(!names(dim(weights_ref)) %in% c(memb_dim, time_dim))) + stop("Parameter 'weights_ref' must have two dimensions with the names of 'memb_dim' and 'time_dim'.") + if (dim(weights_ref)[memb_dim] != dim(exp)[memb_dim] | + dim(weights_ref)[time_dim] != dim(exp)[time_dim]) { + stop("Parameter 'weights_ref' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'ref'.") + } + weights_ref <- Reorder(weights_ref, c(time_dim, memb_dim)) + + } else { + if (length(dim(weights_ref)) != 3 | any(!names(dim(weights_ref)) %in% c(memb_dim, time_dim, dat_dim))) + stop("Parameter 'weights_ref' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") + if (dim(weights_ref)[memb_dim] != dim(ref)[memb_dim] | + dim(weights_ref)[time_dim] != dim(ref)[time_dim] | + dim(weights_ref)[dat_dim] != dim(ref)[dat_dim]) { + stop(paste0("Parameter 'weights_ref' must have the same dimension lengths ", + "as 'memb_dim', 'time_dim' and 'dat_dim' in 'ref'.")) + } + weights_ref <- Reorder(weights_ref, c(time_dim, memb_dim, dat_dim)) + } + } ## ncores if (!is.null(ncores)) { @@ -164,78 +272,149 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', # Compute RPSS if (!memb_dim %in% names(dim(obs))) { - target_dims_obs <- time_dim + target_dims_obs <- c(time_dim, dat_dim) } else { - target_dims_obs <- c(time_dim, memb_dim) + target_dims_obs <- c(time_dim, memb_dim, dat_dim) } if (!is.null(ref)) { # use "ref" as reference forecast + if (!is.null(dat_dim) && (dat_dim %in% names(dim(ref)))) { + target_dims_ref <- c(time_dim, memb_dim, dat_dim) + } else { + target_dims_ref <- c(time_dim, memb_dim) + } data <- list(exp = exp, obs = obs, ref = ref) - target_dims = list(exp = c(time_dim, memb_dim), + target_dims = list(exp = c(time_dim, memb_dim, dat_dim), obs = target_dims_obs, - ref = c(time_dim, memb_dim)) + ref = target_dims_ref) } else { data <- list(exp = exp, obs = obs) - target_dims = list(exp = c(time_dim, memb_dim), + target_dims = list(exp = c(time_dim, memb_dim, dat_dim), obs = target_dims_obs) } output <- Apply(data, target_dims = target_dims, fun = .RPSS, + time_dim = time_dim, memb_dim = memb_dim, + dat_dim = dat_dim, prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim, Fair = Fair, - weights = weights, + weights_exp = weights_exp, + weights_ref = weights_ref, ncores = ncores) return(output) + } -.RPSS <- function(exp, obs, ref = NULL, prob_thresholds = c(1/3, 2/3), - indices_for_clim = NULL, Fair = FALSE, weights = NULL) { - # exp: [sdate, memb] - # obs: [sdate, (memb)] - # ref: [sdate, memb] or NULL +.RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', dat_dim = NULL, + prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, + weights_exp = NULL, weights_ref = NULL) { + + # exp: [sdate, memb, (dat)] + # obs: [sdate, (memb), (dat)] + # ref: [sdate, memb, (dat)] or NULL + + if (is.null(dat_dim)) { + nexp <- 1 + nobs <- 1 + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + } # RPS of the forecast - rps_exp <- .RPS(exp = exp, obs = obs, prob_thresholds = prob_thresholds, - indices_for_clim = indices_for_clim, Fair = Fair, weights = weights) + rps_exp <- .RPS(exp = exp, obs = obs, time_dim = time_dim, memb_dim = memb_dim, dat_dim = dat_dim, + prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim, + Fair = Fair, weights = weights_exp) # RPS of the reference forecast if (is.null(ref)) { ## using climatology as reference forecast - obs_probs <- .get_probs(data = obs, indices_for_quantiles = indices_for_clim, - prob_thresholds = prob_thresholds, weights = NULL) - # obs_probs: [bin, sdate] - - clim_probs <- c(prob_thresholds[1], diff(prob_thresholds), 1 - prob_thresholds[length(prob_thresholds)]) - clim_probs <- array(clim_probs, dim = dim(obs_probs)) - # clim_probs: [bin, sdate] - - # Calculate RPS for each time step - probs_clim_cumsum <- apply(clim_probs, 2, cumsum) - probs_obs_cumsum <- apply(obs_probs, 2, cumsum) - rps_ref <- apply((probs_clim_cumsum - probs_obs_cumsum)^2, 2, sum) - # rps_ref: [sdate] - -# if (Fair) { # FairRPS -# ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps] -# R <- dim(exp)[2] #memb -# R_new <- Inf -# adjustment <- (-1) / (R - 1) * probs_clim_cumsum * (1 - probs_clim_cumsum) -# adjustment <- apply(adjustment, 2, sum) -# rps_ref <- rps_ref + adjustment -# } + if (!memb_dim %in% names(dim(obs))) { + obs <- InsertDim(obs, posdim = 2, lendim = 1, name = memb_dim) + } + if (is.null(dat_dim)) { + dim(obs) <- c(dim(obs), nobs = nobs) + } + rps_ref <- array(dim = c(dim(obs)[time_dim], nobs = nobs)) + + for (j in 1:nobs) { + obs_data <- obs[ , , j] + if (is.null(dim(obs_data))) dim(obs_data) <- c(dim(obs)[1:2]) + # obs_probs: [bin, sdate] + obs_probs <- .get_probs(data = obs_data, indices_for_quantiles = indices_for_clim, + prob_thresholds = prob_thresholds, weights = NULL) + # clim_probs: [bin, sdate] + clim_probs <- c(prob_thresholds[1], diff(prob_thresholds), 1 - prob_thresholds[length(prob_thresholds)]) + clim_probs <- array(clim_probs, dim = dim(obs_probs)) + + # Calculate RPS for each time step + probs_clim_cumsum <- apply(clim_probs, 2, cumsum) + probs_obs_cumsum <- apply(obs_probs, 2, cumsum) + rps_ref[ , j] <- apply((probs_clim_cumsum - probs_obs_cumsum)^2, 2, sum) + + # if (Fair) { # FairRPS + # ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps] + # R <- dim(exp)[2] #memb + # R_new <- Inf + # adjustment <- (-1) / (R - 1) * probs_clim_cumsum * (1 - probs_clim_cumsum) + # adjustment <- apply(adjustment, 2, sum) + # rps_ref <- rps_ref + adjustment + # } + + } + if (is.null(dat_dim)) { + dim(rps_ref) <- dim(exp)[time_dim] + } } else { # use "ref" as reference forecast - rps_ref <- .RPS(exp = ref, obs = obs, prob_thresholds = prob_thresholds, - indices_for_clim = indices_for_clim, Fair = Fair, weights = weights) + if (!is.null(dat_dim) && (!dat_dim %in% names(dim(ref)))) { + remove_dat_dim <- TRUE + ref <- InsertDim(ref, posdim = 3, lendim = 1, name = dat_dim) + if (!is.null(weights_ref)) { + weights_ref <- InsertDim(weights_ref, posdim = 3, lendim = 1, name = dat_dim) + } + } else { + remove_dat_dim <- FALSE + } + + rps_ref <- .RPS(exp = ref, obs = obs, time_dim = time_dim, memb_dim = memb_dim, dat_dim = dat_dim, + prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim, + Fair = Fair, weights = weights_ref) + if (!is.null(dat_dim)) { + if (isTRUE(remove_dat_dim)) { + dim(rps_ref) <- dim(rps_ref)[-2] + } + } } - # RPSS - rpss <- 1 - mean(rps_exp) / mean(rps_ref) - - # Significance - sign <- .RandomWalkTest(skill_A = rps_exp, skill_B = rps_ref)$signif + if (!is.null(dat_dim)) { + + rps_exp_mean <- MeanDims(rps_exp, time_dim, na.rm = FALSE) + rps_ref_mean <- MeanDims(rps_ref, time_dim, na.rm = FALSE) + rpss <- array(dim = c(nexp = nexp, nobs = nobs)) + sign <- array(dim = c(nexp = nexp, nobs = nobs)) + + if (length(dim(rps_ref_mean)) == 1) { + for (i in 1:nexp) { + for (j in 1:nobs) { + rpss[i, j] <- 1 - rps_exp_mean[i, j] / rps_ref_mean[j] + sign[i, j] <- .RandomWalkTest(skill_A = rps_exp_mean[i, j], skill_B = rps_ref_mean[j])$signif + } + } + } else { + for (i in 1:nexp) { + for (j in 1:nobs) { + rpss[i, j] <- 1 - rps_exp_mean[i, j] / rps_ref_mean[i, j] + sign[i, j] <- .RandomWalkTest(skill_A = rps_exp_mean[i, j], skill_B = rps_ref_mean[i, j])$signif + } + } + } + } else { + rpss <- 1 - mean(rps_exp) / mean(rps_ref) + # Significance + sign <- .RandomWalkTest(skill_A = rps_exp, skill_B = rps_ref)$signif + } return(list(rpss = rpss, sign = sign)) } - diff --git a/R/RatioRMS.R b/R/RatioRMS.R index f7e34b42f01fb2893a3d38112b49b69ce7c6d3b1..51f39846e1eb9c8e5a1616627de6c69ae848f8e6 100644 --- a/R/RatioRMS.R +++ b/R/RatioRMS.R @@ -21,7 +21,7 @@ #' computation. The default value is NULL. #' #'@return A list containing the numeric arrays with dimensions identical with -#' 'exp1', 'exp2', and 'obs', expect 'time_dim': +#' 'exp1', 'exp2', and 'obs', except 'time_dim': #'\item{$ratiorms}{ #' The ratio between the RMSE (i.e., RMSE1/RMSE2). #'} diff --git a/R/RatioSDRMS.R b/R/RatioSDRMS.R index 544ca6f8db3b6f85c73788fdecd5caa9c8557586..d527625c2daabfc5fc0fa2366ebec4a5292a46df 100644 --- a/R/RatioSDRMS.R +++ b/R/RatioSDRMS.R @@ -109,7 +109,7 @@ RatioSDRMS <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', name_obs <- name_obs[-which(name_obs == memb_dim)] if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all the dimensions expect 'dat_dim' and 'memb_dim'.")) + "all the dimensions except 'dat_dim' and 'memb_dim'.")) } ## pval if (!is.logical(pval) | length(pval) > 1) { diff --git a/R/ResidualCorr.R b/R/ResidualCorr.R index 7428d1b08be1ab462cbd37750e82835a2c91f797..8d9f0404fbfd1bd50d307da6950e7da4664859c1 100644 --- a/R/ResidualCorr.R +++ b/R/ResidualCorr.R @@ -125,7 +125,7 @@ ResidualCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', if (length(name_exp) != length(name_obs) | length(name_exp) != length(name_ref) | any(dim(exp)[name_exp] != dim(obs)[name_obs]) | any(dim(exp)[name_exp] != dim(ref)[name_ref])) { stop(paste0("Parameter 'exp', 'obs', and 'ref' must have same length of ", - "all dimensions expect 'memb_dim'.")) + "all dimensions except 'memb_dim'.")) } ## method if (!method %in% c("pearson", "kendall", "spearman")) { diff --git a/R/UltimateBrier.R b/R/UltimateBrier.R index aeaddcdcadcdd9d25e3a283d1ec8d24534f969d0..d2c4ac936016ef4f663f6005877b6a3220a06e88 100644 --- a/R/UltimateBrier.R +++ b/R/UltimateBrier.R @@ -5,14 +5,15 @@ #'to choose. #' #'@param exp A numeric array of forecast anomalies with named dimensions that -#' at least include 'dat_dim', 'memb_dim', and 'time_dim'. It can be provided +#' at least include 'memb_dim', and 'time_dim'. It can be provided #' by \code{Ano()}. #'@param obs A numeric array of observational reference anomalies with named -#' dimensions that at least include 'dat_dim' and 'time_dim'. If it has +#' dimensions that at least include 'time_dim'. If it has #' 'memb_dim', the length must be 1. The dimensions should be consistent with #' 'exp' except 'dat_dim' and 'memb_dim'. It can be provided by \code{Ano()}. #'@param dat_dim A character string indicating the name of the dataset -#' dimension in 'exp' and 'obs'. The default value is 'dataset'. +#' dimension in 'exp' and 'obs'. The default value is 'dataset'. If there is no dataset +#' dimension, set NULL. #'@param memb_dim A character string indicating the name of the member #' dimension in 'exp' (and 'obs') for ensemble mean calculation. The default #' value is 'member'. @@ -55,7 +56,7 @@ #'same dimensions: #'c(nexp, nobs, no. of bins, the rest dimensions of 'exp' except 'time_dim' and #''memb_dim'). 'nexp' and 'nobs' is the length of dataset dimension in 'exp' -#'and 'obs' respectively.\cr +#'and 'obs' respectively. If dat_dim is NULL, nexp and nobs are omitted.\cr #'The list of 4 includes: #' \itemize{ #' \item{$bs: Brier Score} @@ -102,12 +103,15 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti stop("Parameter 'exp' and 'obs' must have dimension names.") } ## dat_dim - if (!is.character(dat_dim) | length(dat_dim) > 1) { - stop("Parameter 'dat_dim' must be a character string.") - } - if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { - stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + if (!is.null(dat_dim)) { + if (!is.character(dat_dim) | length(dat_dim) > 1) { + stop("Parameter 'dat_dim' must be a character string or NULL.") + } + if (!dat_dim %in% names(dim(exp)) | !dat_dim %in% names(dim(obs))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + } } + ## memb_dim if (!is.character(memb_dim) | length(memb_dim) > 1) { stop("Parameter 'memb_dim' must be a character string.") @@ -137,11 +141,11 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti name_obs <- name_obs[-which(name_obs == dat_dim)] if (any(name_exp != name_obs)) { stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.")) + "of all the dimensions except 'dat_dim' and 'memb_dim'.")) } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.")) + "of all the dimensions except 'dat_dim' and 'memb_dim'.")) } ## quantile if (!is.logical(quantile) | length(quantile) > 1) { @@ -183,6 +187,7 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti target_dims = list(c(time_dim, dat_dim, memb_dim), c(time_dim, dat_dim, memb_dim)), fun = .UltimateBrier, + dat_dim = dat_dim, memb_dim = memb_dim, thr = thr, type = type, decomposition = decomposition, ncores = ncores)$output1 @@ -203,6 +208,7 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti target_dims = list(c(time_dim, dat_dim), c(time_dim, dat_dim)), fun = .UltimateBrier, + dat_dim = dat_dim, memb_dim = memb_dim, thr = thr, type = type, decomposition = decomposition, ncores = ncores) @@ -217,8 +223,8 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti return(res) } -.UltimateBrier <- function(exp, obs, thr = c(5/100, 95/100), type = 'BS', - decomposition = TRUE) { +.UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', thr = c(5/100, 95/100), + type = 'BS', decomposition = TRUE) { # If exp and obs are probablistics # exp: [sdate, nexp] # obs: [sdate, nobs] @@ -229,6 +235,10 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti #NOTE: 'thr' is used in 'FairEnsembleBSS' and 'FairEnsembleBS'. But if quantile = F and # thr is real value, does it work? if (type == 'FairEnsembleBSS') { + if (is.null(dat_dim)) { + obs <- InsertDim(obs, posdim = 2, lendim = 1, name = 'dataset') + exp <- InsertDim(exp, posdim = 2, lendim = 1, name = 'dataset') + } size_ens_ref <- prod(dim(obs)[c(1, 3)]) res <- array(dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]), @@ -245,6 +255,9 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti } } } + if (is.null(dat_dim)) { + dim(res) <- dim(res)[3:length(dim(res))] + } } else if (type == 'FairEnsembleBS') { #NOTE: The calculation in s2dverification::UltimateBrier is wrong. In the final stage, @@ -252,6 +265,10 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti # but the 3rd dim of result is 'bins' instead of decomposition. 'FairEnsembleBS' does # not have decomposition. # The calculation is fixed here. + if (is.null(dat_dim)) { + obs <- InsertDim(obs, posdim = 2, lendim = 1, name = 'dataset') + exp <- InsertDim(exp, posdim = 2, lendim = 1, name = 'dataset') + } res <- array(dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]), bin = length(thr) + 1)) @@ -264,10 +281,17 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti } } } + if (is.null(dat_dim)) { + dim(res) <- dim(res)[3:length(dim(res))] + } # tmp <- res[, , 1] - res[, , 2] + res[, , 3] # res <- array(tmp, dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]))) } else if (type == 'BS') { + if (is.null(dat_dim)) { + obs <- InsertDim(obs, posdim = 2, lendim = 1, name = 'dataset') + exp <- InsertDim(exp, posdim = 2, lendim = 1, name = 'dataset') + } comp <- array(dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]), comp = 3)) @@ -280,17 +304,28 @@ UltimateBrier <- function(exp, obs, dat_dim = 'dataset', memb_dim = 'member', ti } if (decomposition) { rel <- comp[, , 1] - dim(rel) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) res <- comp[, , 2] - dim(res) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) unc <- comp[, , 3] - dim(unc) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) bs <- rel - res + unc - dim(bs) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + if (is.null(dat_dim)) { + dim(rel) <- NULL + dim(res) <- NULL + dim(unc) <- NULL + dim(bs) <- NULL + } else { + dim(rel) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + dim(res) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + dim(unc) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + dim(bs) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + } res <- list(bs = bs, rel = rel, res = res, unc = unc) } else { bs <- comp[, , 1] - comp[, , 2] + comp[, , 3] - dim(bs) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + if (is.null(dat_dim)) { + dim(bs) <- NULL + } else { + dim(bs) <- c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2])) + } res <- list(bs = bs) } diff --git a/R/Utils.R b/R/Utils.R index c13691499e7db59f4247411b0ad79498f9c0a65b..c2c17eb2698c1378b7a4c2147c1002da9b3f9f3a 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -1720,3 +1720,92 @@ return(anom) } + +#TODO: Remove from s2dv when PlotLayout can get colorbar info from plotting function directly. +# The function is temporarily here because PlotLayout() needs to draw the colorbars of +# PlotMostLikelyQuantileMap(). +#Draws Color Bars for Categories +#A wrapper of s2dv::ColorBar to generate multiple color bars for different +#categories, and each category has different color set. +GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits, var_limits = NULL, + triangle_ends = NULL, plot = TRUE, + draw_separators = FALSE, + bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + ...) { + # bar_limits + if (!is.numeric(bar_limits) || length(bar_limits) != 2) { + stop("Parameter 'bar_limits' must be a numeric vector of length 2.") + } + + # Check brks + if (is.null(brks) || (is.numeric(brks) && length(brks) == 1)) { + num_brks <- 5 + if (is.numeric(brks)) { + num_brks <- brks + } + brks <- seq(from = bar_limits[1], to = bar_limits[2], length.out = num_brks) + } + if (!is.numeric(brks)) { + stop("Parameter 'brks' must be a numeric vector.") + } + # Check cols + col_sets <- list(c("#A1D99B", "#74C476", "#41AB5D", "#238B45"), + c("#6BAED6FF", "#4292C6FF", "#2171B5FF", "#08519CFF"), + c("#FFEDA0FF", "#FED976FF", "#FEB24CFF", "#FD8D3CFF"), + c("#FC4E2AFF", "#E31A1CFF", "#BD0026FF", "#800026FF"), + c("#FCC5C0", "#FA9FB5", "#F768A1", "#DD3497")) + if (is.null(cols)) { + if (length(col_sets) >= nmap) { + chosen_sets <- 1:nmap + chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) + } else { + chosen_sets <- array(1:length(col_sets), nmap) + } + cols <- col_sets[chosen_sets] + } else { + if (!is.list(cols)) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (!all(sapply(cols, is.character))) { + stop("Parameter 'cols' must be a list of character vectors.") + } + if (length(cols) != nmap) { + stop("Parameter 'cols' must be a list of the same length as the number of ", + "maps in 'maps'.") + } + } + for (i in 1:length(cols)) { + if (length(cols[[i]]) != (length(brks) - 1)) { + cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) + } + } + + # Check bar_titles + if (is.null(bar_titles)) { + if (nmap == 3) { + bar_titles <- c("Below normal (%)", "Normal (%)", "Above normal (%)") + } else if (nmap == 5) { + bar_titles <- c("Low (%)", "Below normal (%)", + "Normal (%)", "Above normal (%)", "High (%)") + } else { + bar_titles <- paste0("Cat. ", 1:nmap, " (%)") + } + } + + if (plot) { + for (k in 1:nmap) { + s2dv::ColorBar(brks = brks, cols = cols[[k]], vertical = FALSE, subsampleg = subsampleg, +# bar_limits = bar_limits, var_limits = var_limits, + triangle_ends = triangle_ends, plot = TRUE, + draw_separators = draw_separators, + title = bar_titles[[k]], title_scale = title_scale, + label_scale = label_scale, extra_margin = extra_margin) + } + } else { + #TODO: col_inf and col_sup + return(list(brks = brks, cols = cols)) + } + +} + diff --git a/man/AbsBiasSS.Rd b/man/AbsBiasSS.Rd new file mode 100644 index 0000000000000000000000000000000000000000..029101d06d6c3f31b69d8936ef3852b2702e2c8c --- /dev/null +++ b/man/AbsBiasSS.Rd @@ -0,0 +1,89 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AbsBiasSS.R +\name{AbsBiasSS} +\alias{AbsBiasSS} +\title{Compute the Absolute Mean Bias Skill Score} +\usage{ +AbsBiasSS( + exp, + obs, + ref = NULL, + time_dim = "sdate", + memb_dim = NULL, + dat_dim = NULL, + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named numerical array of the forecast with at least time +dimension.} + +\item{obs}{A named numerical array of the observation with at least time +dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +'dat_dim'.} + +\item{ref}{A named numerical array of the reference forecast data with at +least time dimension. The dimensions must be the same as 'exp' except +'memb_dim' and 'dat_dim'. If there is only one reference dataset, it should +not have dataset dimension. If there is corresponding reference for each +experiement, the dataset dimension must have the same length as in 'exp'. If +'ref' is NULL, the climatological forecast is used as reference forecast. +The default value is NULL.} + +\item{time_dim}{A character string indicating the name of the time dimension. +The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of the member dimension +to compute the ensemble mean; it should be set to NULL if the parameter 'exp' +and 'ref' are already the ensemble mean. The default value is NULL.} + +\item{dat_dim}{A character string indicating the name of dataset dimension. +The length of this dimension can be different between 'exp' and 'obs'. +The default value is NULL.} + +\item{na.rm}{A logical value indicating if NAs should be removed (TRUE) or +kept (FALSE) for computation. The default value is FALSE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +\item{$biasSS}{ + A numerical array of BiasSS with dimensions nexp, nobs and the rest + dimensions of 'exp' except 'time_dim' and 'memb_dim'. +} +\item{$sign}{ + A logical array of the statistical significance of the BiasSS + with the same dimensions as $biasSS. nexp is the number of + experiment (i.e., 'dat_dim' in exp), and nobs is the number of observation + (i.e., 'dat_dim' in obs). If dat_dim is NULL, nexp and nobs are omitted. +} +} +\description{ +The Absolute Mean Bias Skill Score is based on the Absolute Mean Error (Wilks, +2011) between the ensemble mean forecast and the observations. It measures +the accuracy of the forecast in comparison with a reference forecast to assess +whether the forecast presents an improvement or a worsening with respect to +that reference. The Mean Bias Skill Score ranges between minus infinite and 1. +Positive values indicate that the forecast has higher skill than the reference +forecast, while negative values indicate that it has a lower skill. Examples +of reference forecasts are the climatological forecast (average of the +observations), a previous model version, or another model. It is computed as +\code{AbsBiasSS = 1 - AbsBias_exp / AbsBias_ref}. The statistical significance +is obtained based on a Random Walk test at the 95% confidence level (DelSole +and Tippett, 2016). If there is more than one dataset, the result will be +computed for each pair of exp and obs data. +} +\examples{ +exp <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, member = 10, sdate = 50)) +ref <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, member = 10, sdate = 50)) +obs <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, sdate = 50)) +biasSS1 <- AbsBiasSS(exp = exp, obs = obs, ref = ref, memb_dim = 'member') +biasSS2 <- AbsBiasSS(exp = exp, obs = obs, ref = NULL, memb_dim = 'member') + +} +\references{ +Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +DelSole and Tippett, 2016; https://doi.org/10.1175/MWR-D-15-0218.1 +} diff --git a/man/Ano_CrossValid.Rd b/man/Ano_CrossValid.Rd index d2234a1623901efa767aba83bbd4c5eb532940a7..2a82713159b5d3357904e190a88486aadea52d1b 100644 --- a/man/Ano_CrossValid.Rd +++ b/man/Ano_CrossValid.Rd @@ -25,10 +25,11 @@ parameter 'exp' except along 'dat_dim'.} The default value is 'sdate'.} \item{dat_dim}{A character vector indicating the name of the dataset and -member dimensions. When calculating the climatology, if data at one -startdate (i.e., 'time_dim') is not complete along 'dat_dim', this startdate -along 'dat_dim' will be discarded. The default value is -"c('dataset', 'member')".} + member dimensions. When calculating the climatology, if data at one + startdate (i.e., 'time_dim') is not complete along 'dat_dim', this startdate + along 'dat_dim' will be discarded. If there is no dataset dimension, it can be NULL. +The default value is + "c('dataset', 'member')".} \item{memb_dim}{A character string indicating the name of the member dimension. Only used when parameter 'memb' is FALSE. It must be one element diff --git a/man/Bias.Rd b/man/Bias.Rd new file mode 100644 index 0000000000000000000000000000000000000000..2a02f2d52b9d39b8df0c7b8fa06ef02d702b1b11 --- /dev/null +++ b/man/Bias.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Bias.R +\name{Bias} +\alias{Bias} +\title{Compute the Mean Bias} +\usage{ +Bias( + exp, + obs, + time_dim = "sdate", + memb_dim = NULL, + dat_dim = NULL, + na.rm = FALSE, + absolute = FALSE, + time_mean = TRUE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named numerical array of the forecast with at least time +dimension.} + +\item{obs}{A named numerical array of the observation with at least time +dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +'dat_dim'.} + +\item{time_dim}{A character string indicating the name of the time dimension. +The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of the member dimension +to compute the ensemble mean; it should be set to NULL if the parameter +'exp' is already the ensemble mean. The default value is NULL.} + +\item{dat_dim}{A character string indicating the name of dataset dimension. +The length of this dimension can be different between 'exp' and 'obs'. +The default value is NULL.} + +\item{na.rm}{A logical value indicating if NAs should be removed (TRUE) or +kept (FALSE) for computation. The default value is FALSE.} + +\item{absolute}{A logical value indicating whether to compute the absolute +bias. The default value is FALSE.} + +\item{time_mean}{A logical value indicating whether to compute the temporal +mean of the bias. The default value is TRUE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A numerical array of bias with dimensions c(nexp, nobs, the rest dimensions of +'exp' except 'time_dim' (if time_mean = T) and 'memb_dim'). nexp is the number +of experiment (i.e., 'dat_dim' in exp), and nobs is the number of observation +(i.e., 'dat_dim' in obs). If dat_dim is NULL, nexp and nobs are omitted. +} +\description{ +The Mean Bias or Mean Error (Wilks, 2011) is defined as the mean difference +between the ensemble mean forecast and the observations. It is a deterministic +metric. Positive values indicate that the forecasts are on average too high +and negative values indicate that the forecasts are on average too low. +It also allows to compute the Absolute Mean Bias or bias without temporal +mean. If there is more than one dataset, the result will be computed for each +pair of exp and obs data. +} +\examples{ +exp <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, member = 10, sdate = 50)) +obs <- array(rnorm(1000), dim = c(dat = 1, lat = 3, lon = 5, sdate = 50)) +bias <- Bias(exp = exp, obs = obs, memb_dim = 'member') + +} +\references{ +Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +} diff --git a/man/BrierScore.Rd b/man/BrierScore.Rd index 9271a2adb8fca99ed95483a36b46545e219cd47c..76fb27eb0106b2a38a4222af784b268abcaa45a2 100644 --- a/man/BrierScore.Rd +++ b/man/BrierScore.Rd @@ -73,13 +73,13 @@ Items 'rel', 'res', 'unc', 'bs', 'bs_check_res', 'bss_res', 'gres', 'bs_check_gres', 'bss_gres', 'rel_bias_corrected', 'gres_bias_corrected', 'unc_bias_corrected', and 'bss_bias_corrected' are (a) a number (b) an array with dimensions c(nexp, nobs, all the rest dimensions in 'exp' and 'obs' -expect 'time_dim' and 'memb_dim') (c) an array with dimensions of +except 'time_dim' and 'memb_dim') (c) an array with dimensions of 'exp' and 'obs' except 'time_dim' and 'memb_dim'\cr Items 'nk', 'fkbar', and 'okbar' are (a) a vector of length of bin number determined by 'threshold' (b) an array with dimensions c(nexp, nobs, -no. of bins, all the rest dimensions in 'exp' and 'obs' expect 'time_dim' and +no. of bins, all the rest dimensions in 'exp' and 'obs' except 'time_dim' and 'memb_dim') (c) an array with dimensions c(no. of bin, all the rest dimensions -in 'exp' and 'obs' expect 'time_dim' and 'memb_dim') +in 'exp' and 'obs' except 'time_dim' and 'memb_dim') } \description{ Compute the Brier score (BS) and the components of its standard decompostion diff --git a/man/CRPS.Rd b/man/CRPS.Rd new file mode 100644 index 0000000000000000000000000000000000000000..453c1994608459bdb95eeb36149915b69599f19d --- /dev/null +++ b/man/CRPS.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CRPS.R +\name{CRPS} +\alias{CRPS} +\title{Compute the Continuous Ranked Probability Score} +\usage{ +CRPS( + exp, + obs, + time_dim = "sdate", + memb_dim = "member", + dat_dim = NULL, + Fair = FALSE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named numerical array of the forecast with at least time +dimension.} + +\item{obs}{A named numerical array of the observation with at least time +dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +'dat_dim'.} + +\item{time_dim}{A character string indicating the name of the time dimension. +The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of the member dimension +to compute the probabilities of the forecast. The default value is 'member'.} + +\item{dat_dim}{A character string indicating the name of dataset dimension. +The length of this dimension can be different between 'exp' and 'obs'. The +default value is NULL.} + +\item{Fair}{A logical indicating whether to compute the FairCRPS (the +potential CRPS that the forecast would have with an infinite ensemble size). +The default value is FALSE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A numerical array of CRPS with dimensions c(nexp, nobs, the rest dimensions of +'exp' except 'time_dim' and 'memb_dim' dimensions). nexp is the number of +experiment (i.e., dat_dim in exp), and nobs is the number of observation +(i.e., dat_dim in obs). If dat_dim is NULL, nexp and nobs are omitted. +} +\description{ +The Continuous Ranked Probability Score (CRPS; Wilks, 2011) is the continuous +version of the Ranked Probability Score (RPS; Wilks, 2011). It is a skill +metric to evaluate the full distribution of probabilistic forecasts. It has a +negative orientation (i.e., the higher-quality forecast the smaller CRPS) and +it rewards the forecast that has probability concentration around the observed +value. In case of a deterministic forecast, the CRPS is reduced to the mean +absolute error. It has the same units as the data. The function is based on +enscrps_cpp from SpecsVerification. If there is more than one dataset, CRPS +will be computed for each pair of exp and obs data. +} +\examples{ +exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) +res <- CRPS(exp = exp, obs = obs) + +} +\references{ +Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +} diff --git a/man/CRPSS.Rd b/man/CRPSS.Rd new file mode 100644 index 0000000000000000000000000000000000000000..31bf501ec19771f8a86703bfa83fc567daaf4b0f --- /dev/null +++ b/man/CRPSS.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CRPSS.R +\name{CRPSS} +\alias{CRPSS} +\title{Compute the Continuous Ranked Probability Skill Score} +\usage{ +CRPSS( + exp, + obs, + ref = NULL, + time_dim = "sdate", + memb_dim = "member", + dat_dim = NULL, + Fair = FALSE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named numerical array of the forecast with at least time +dimension.} + +\item{obs}{A named numerical array of the observation with at least time +dimension. The dimensions must be the same as 'exp' except 'memb_dim' +and 'dat_dim'.} + +\item{ref}{A named numerical array of the reference forecast data with at +least time and member dimension. The dimensions must be the same as 'exp' +except 'memb_dim' and 'dat_dim'. If there is only one reference dataset, +it should not have dataset dimension. If there is corresponding reference +for each experiement, the dataset dimension must have the same length as in +'exp'. If 'ref' is NULL, the climatological forecast is used as reference +forecast. The default value is NULL.} + +\item{time_dim}{A character string indicating the name of the time dimension. +The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of the member dimension +to compute the probabilities of the forecast and the reference forecast. The +default value is 'member'.} + +\item{dat_dim}{A character string indicating the name of dataset dimension. +The length of this dimension can be different between 'exp' and 'obs'. +The default value is NULL.} + +\item{Fair}{A logical indicating whether to compute the FairCRPSS (the +potential CRPSS that the forecast would have with an infinite ensemble +size). The default value is FALSE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +\item{$crpss}{ + A numerical array of the CRPSS with dimensions c(nexp, nobs, the rest + dimensions of 'exp' except 'time_dim' and 'memb_dim' dimensions). nexp is + the number of experiment (i.e., dat_dim in exp), and nobs is the number of + observation (i.e., dat_dim in obs). If 'dat_dim' is NULL, nexp and nobs are + omitted. +} +\item{$sign}{ + A logical array of the statistical significance of the CRPSS with the same + dimensions as $crpss. +} +} +\description{ +The Continuous Ranked Probability Skill Score (CRPSS; Wilks, 2011) is the +skill score based on the Continuous Ranked Probability Score (CRPS; Wilks, +2011). It can be used to assess whether a forecast presents an improvement or +worsening with respect to a reference forecast. The CRPSS ranges between minus +infinite and 1. If the CRPSS is positive, it indicates that the forecast has +higher skill than the reference forecast, while a negative value means that it +has a lower skill. Examples of reference forecasts are the climatological +forecast (same probabilities for all categories for all time steps), +persistence, a previous model version, or another model. It is computed as +CRPSS = 1 - CRPS_exp / CRPS_ref. The statistical significance is obtained +based on a Random Walk test at the 95% confidence level (DelSole and Tippett, +2016). +} +\examples{ +exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) +ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +res <- CRPSS(exp = exp, obs = obs) ## climatology as reference forecast +res <- CRPSS(exp = exp, obs = obs, ref = ref) ## ref as reference forecast + +} +\references{ +Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 +DelSole and Tippett, 2016; https://doi.org/10.1175/MWR-D-15-0218.1 +} diff --git a/man/Corr.Rd b/man/Corr.Rd index 077791fbeeb5e100a18e5b44c26a0b4753772d39..4cbd0986bf3b6dbbca2fc67715ac2f56c18c96a9 100644 --- a/man/Corr.Rd +++ b/man/Corr.Rd @@ -21,8 +21,8 @@ Corr( ) } \arguments{ -\item{exp}{A named numeric array of experimental data, with at least two -dimensions 'time_dim' and 'dat_dim'.} +\item{exp}{A named numeric array of experimental data, with at least dimension +'time_dim'.} \item{obs}{A named numeric array of observational data, same dimensions as parameter 'exp' except along 'dat_dim' and 'memb_dim'.} @@ -31,7 +31,8 @@ parameter 'exp' except along 'dat_dim' and 'memb_dim'.} which the correlations are computed. The default value is 'sdate'.} \item{dat_dim}{A character string indicating the name of dataset (nobs/nexp) -dimension. The default value is 'dataset'.} +dimension. The default value is 'dataset'. If there is no dataset +dimension, set NULL.} \item{comp_dim}{A character string indicating the name of dimension along which obs is taken into account only if it is complete. The default value @@ -68,9 +69,10 @@ A list containing the numeric arrays with dimension:\cr c(nexp, nobs, exp_memb, obs_memb, all other dimensions of exp except time_dim and memb_dim).\cr nexp is the number of experiment (i.e., 'dat_dim' in exp), and nobs is the -number of observation (i.e., 'dat_dim' in obs). exp_memb is the number of -member in experiment (i.e., 'memb_dim' in exp) and obs_memb is the number of -member in observation (i.e., 'memb_dim' in obs).\cr\cr +number of observation (i.e., 'dat_dim' in obs). If dat_dim is NULL, nexp and +nobs are omitted. exp_memb is the number of member in experiment (i.e., +'memb_dim' in exp) and obs_memb is the number of member in observation (i.e., +'memb_dim' in obs). If memb = F, exp_memb and obs_memb are omitted.\cr\cr \item{$corr}{ The correlation coefficient. } @@ -87,18 +89,18 @@ member in observation (i.e., 'memb_dim' in obs).\cr\cr \description{ Calculate the correlation coefficient (Pearson, Kendall or Spearman) for an array of forecast and an array of observation. The correlations are -computed along time_dim, the startdate dimension. If comp_dim is given, -the correlations are computed only if obs along the comp_dim dimension are -complete between limits[1] and limits[2], i.e., there is no NA between -limits[1] and limits[2]. This option can be activated if the user wants to -account only for the forecasts which the corresponding observations are -available at all leadtimes.\cr +computed along 'time_dim' that usually refers to the start date dimension. If +'comp_dim' is given, the correlations are computed only if obs along comp_dim +dimension are complete between limits[1] and limits[2], i.e., there is no NA +between limits[1] and limits[2]. This option can be activated if the user +wants to account only for the forecasts which the corresponding observations +are available at all leadtimes.\cr The confidence interval is computed by the Fisher transformation and the significance level relies on an one-sided student-T distribution.\cr -If the dataset has more than one member, ensemble mean is necessary necessary -before using this function since it only allows one dimension 'dat_dim' to -have inconsistent length between 'exp' and 'obs'. If all the dimensions of -'exp' and 'obs' are identical, you can simply use apply() and cor() to +The function can calculate ensemble mean before correlation by 'memb_dim' +specified and 'memb = F'. If ensemble mean is not calculated, correlation will +be calculated for each member. +If there is only one dataset for exp and obs, you can simply use cor() to compute the correlation. } \examples{ diff --git a/man/DiffCorr.Rd b/man/DiffCorr.Rd index d8ff65cbeda9efc4a6a345610971527774851ad0..d127af817a8543ad478fad4114df93fa95ca046b 100644 --- a/man/DiffCorr.Rd +++ b/man/DiffCorr.Rd @@ -14,6 +14,7 @@ DiffCorr( method = "pearson", alpha = NULL, handle.na = "return.na", + test.type = "two-sided", ncores = NULL ) } @@ -56,6 +57,12 @@ steps with no missing values in all "exp", "ref", and "obs" will be used. If "na.fail", an error will arise if any of "exp", "ref", or "obs" contains any NA. The default value is "return.na".} +\item{test.type}{A character string indicating the type of significance test. +It can be "two-sided" (to assess whether the skill of "exp" and "ref" are +significantly different) or "one-sided" (to assess whether the skill of +"exp" is significantly higher than that of "ref") following Steiger (1980). +The default value is "two-sided".} + \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} } @@ -81,20 +88,23 @@ Compute the correlation difference between two deterministic forecasts. Positive values of the correlation difference indicate that the forecast is more skillful than the reference forecast, while negative values mean that the reference forecast is more skillful. The statistical significance of the -correlation differences is computed with a one-sided test for equality of -dependent correlation coefficients (Steiger, 1980; Siegert et al., 2017) using -effective degrees of freedom to account for the autocorrelation of the time -series (von Storch and Zwiers, 1999). +correlation differences is computed with a one-sided or two-sided test for +equality of dependent correlation coefficients (Steiger, 1980; Siegert et al., +2017) using effective degrees of freedom to account for the autocorrelation of +the time series (Zwiers and von Storch, 1995). } \examples{ exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) -res <- DiffCorr(exp, obs, ref, memb_dim = 'member') +res_two.sided_sign <- DiffCorr(exp, obs, ref, memb_dim = 'member', + test.type = 'two-sided', alpha = 0.05) +res_one.sided_pval <- DiffCorr(exp, obs, ref, memb_dim = 'member', + test.type = 'one-sided', alpha = NULL) } \references{ Steiger, 1980; https://content.apa.org/doi/10.1037/0033-2909.87.2.245 Siegert et al., 2017; https://doi.org/10.1175/MWR-D-16-0037.1 -von Storch and Zwiers, 1999; https://doi.org/10.1017/CBO9780511612336 +Zwiers and von Storch, 1995; https://doi.org/10.1175/1520-0442(1995)008<0336:TSCIAI>2.0.CO;2 } diff --git a/man/PlotEquiMap.Rd b/man/PlotEquiMap.Rd index 47a0d981a3ae6d5dd022b2b59585dcd834271fd5..19ff838922f4926f1fc093ed9c5a40b2185d2c26 100644 --- a/man/PlotEquiMap.Rd +++ b/man/PlotEquiMap.Rd @@ -92,7 +92,9 @@ dimensions: c(latitude, longitude). Longitudes can be in ascending or descending order and latitudes in any order. It can contain NA values (coloured with 'colNA'). Arrays with dimensions c(longitude, latitude) will also be accepted but 'lon' and 'lat' will be used to disambiguate so -this alternative is not appropriate for square arrays.} +this alternative is not appropriate for square arrays. It is allowed that +the positions of the longitudinal and latitudinal coordinate dimensions +are interchanged.} \item{lon}{Numeric vector of longitude locations of the cell centers of the grid of 'var', in ascending or descending order (same as 'var'). Expected @@ -106,10 +108,12 @@ grid of 'var', in any order (same as 'var'). Expected to be from a regular rectangular or gaussian grid, within the range [-90, 90].} \item{varu}{Array of the zonal component of wind/current/other field with -the same dimensions as 'var'.} +the same dimensions as 'var'. It is allowed that the positions of the +longitudinal and latitudinal coordinate dimensions are interchanged.} \item{varv}{Array of the meridional component of wind/current/other field -with the same dimensions as 'var'.} +with the same dimensions as 'var'. It is allowed that the positions of the +longitudinal and latitudinal coordinate dimensions are interchanged.} \item{toptitle}{Top title of the figure, scalable with parameter 'title_scale'.} @@ -138,8 +142,9 @@ colors returned by 'color_fun'. If not available, it takes 'pink' by default. 'col_inf' and 'col_sup' will take the value of 'colNA' if not specified. See ?ColorBar for a full explanation on 'col_inf' and 'col_sup'.} -\item{color_fun, subsampleg, bar_extra_labels, draw_bar_ticks, draw_separators, triangle_ends_scale, bar_label_digits, bar_label_scale, units_scale, bar_tick_scale, bar_extra_margin}{Set of parameters to control the visual -aspect of the drawn colour bar. See ?ColorBar for a full explanation.} +\item{color_fun, subsampleg, bar_extra_labels, draw_bar_ticks}{Set of +parameters to control the visual aspect of the drawn colour bar +(1/3). See ?ColorBar for a full explanation.} \item{square}{Logical value to choose either to draw a coloured square for each grid cell in 'var' (TRUE; default) or to draw contour lines and fill @@ -178,7 +183,9 @@ location of the shape. The default value is NULL.} \item{contours}{Array of same dimensions as 'var' to be added to the plot and displayed with contours. Parameter 'brks2' is required to define the -magnitude breaks for each contour curve. Disregarded if 'square = FALSE'.} +magnitude breaks for each contour curve. Disregarded if 'square = FALSE'. +It is allowed that the positions of the longitudinal and latitudinal +coordinate dimensions are interchanged.} \item{brks2}{Vector of magnitude breaks where to draw contour curves for the array provided in 'contours' or if 'square = FALSE'.} @@ -203,7 +210,8 @@ c(n, dim(var)), where n is the number of dot/symbol layers to add to the plot. A value of TRUE at a grid cell will draw a dot/symbol on the corresponding square of the plot. By default all layers provided in 'dots' are plotted with dots, but a symbol can be specified for each of the -layers via the parameter 'dot_symbol'.} +layers via the parameter 'dot_symbol'. It is allowed that the positions of +the longitudinal and latitudinal coordinate dimensions are interchanged.} \item{dot_symbol}{Single character/number or vector of characters/numbers that correspond to each of the symbol layers specified in parameter 'dots'. @@ -251,8 +259,8 @@ the function.} box borders. The default value is NULL and is automatically adjusted by the function.} -\item{degree_sym}{A logical indicating whether to include degree symbol (30° N) -or not (30N; default).} +\item{degree_sym}{A logical indicating whether to include degree symbol +(30° N) or not (30N; default).} \item{intylat}{Interval between latitude ticks on y-axis, in degrees. Defaults to 20.} @@ -286,6 +294,14 @@ and latitude axes.} TRUE. It is not possible to plot the colour bar if 'add = TRUE'. Use ColorBar() and the return values of PlotEquiMap() instead.} +\item{draw_separators, triangle_ends_scale, bar_label_digits}{Set of +parameters to control the visual aspect of the drawn colour bar +(2/3). See ?ColorBar for a full explanation.} + +\item{bar_label_scale, units_scale, bar_tick_scale, bar_extra_margin}{Set of +parameters to control the visual aspect of the drawn colour bar (3/3). +See ?ColorBar for a full explanation.} + \item{boxlim}{Limits of a box to be added to the plot, in degrees: c(x1, y1, x2, y2). A list with multiple box specifications can also be provided.} diff --git a/man/PlotLayout.Rd b/man/PlotLayout.Rd index f8e7bae376763de767cd967a4f3baee1d608ceef..2a053ad04b0291f71dcf5bee4e946ceb7a6d2034 100644 --- a/man/PlotLayout.Rd +++ b/man/PlotLayout.Rd @@ -21,6 +21,7 @@ PlotLayout( title_left_shift_scale = 1, subtitle_scale = 1, subtitle_margin_scale = 1, + subplot_titles_scale = 1, brks = NULL, cols = NULL, drawleg = "S", @@ -152,6 +153,9 @@ be disregarded if no 'row_titles' are provided.} \item{subtitle_margin_scale}{Scale factor for the margins surrounding the subtitles. Takes 1 by default.} +\item{subplot_titles_scale}{Scale factor for the subplots top titles. Takes +1 by default.} + \item{brks, cols, bar_limits, triangle_ends}{Usually only providing 'brks' is enough to generate the desired colour bar. These parameters allow to define n breaks that define n - 1 intervals to classify each of the values diff --git a/man/RPS.Rd b/man/RPS.Rd index ee5c24142cd840615cd2759ae0180b805028d773..4d8236bba260d14f016ebb82304c536d545d01dd 100644 --- a/man/RPS.Rd +++ b/man/RPS.Rd @@ -9,6 +9,7 @@ RPS( obs, time_dim = "sdate", memb_dim = "member", + dat_dim = NULL, prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, @@ -17,11 +18,12 @@ RPS( ) } \arguments{ -\item{exp}{A named numerical array of the forecast with at least time -dimension.} +\item{exp}{A named numerical array of the forecast with at least time and +member dimension.} \item{obs}{A named numerical array of the observation with at least time -dimension. The dimensions must be the same as 'exp' except 'memb_dim'.} +dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +'dat_dim'.} \item{time_dim}{A character string indicating the name of the time dimension. The default value is 'sdate'.} @@ -29,6 +31,10 @@ The default value is 'sdate'.} \item{memb_dim}{A character string indicating the name of the member dimension to compute the probabilities of the forecast. The default value is 'member'.} +\item{dat_dim}{A character string indicating the name of dataset dimension. +The length of this dimension can be different between 'exp' and 'obs'. +The default value is NULL.} + \item{prob_thresholds}{A numeric vector of the relative thresholds (from 0 to 1) between the categories. The default value is c(1/3, 2/3), which corresponds to tercile equiprobable categories.} @@ -37,22 +43,25 @@ corresponds to tercile equiprobable categories.} for computing the thresholds between the probabilistic categories. If NULL, the whole period is used. The default value is NULL.} -\item{Fair}{A logical indicating whether to compute the FairRPSS (the -potential RPSS that the forecast would have with an infinite ensemble size). +\item{Fair}{A logical indicating whether to compute the FairRPS (the +potential RPS that the forecast would have with an infinite ensemble size). The default value is FALSE.} -\item{weights}{A named two-dimensional numerical array of the weights for each -member and time. The dimension names should include 'memb_dim' and -'time_dim'. The default value is NULL. The ensemble should have at least 70 -members or span at least 10 time steps and have more than 45 members if -consistency between the weighted and unweighted methodologies is desired.} +\item{weights}{A named numerical array of the weights for 'exp'. If 'dat_dim' +is NULL, the dimension should include 'memb_dim' and 'time_dim'. Else, the +dimension should also include 'dat_dim'. The default value is NULL. The +ensemble should have at least 70 members or span at least 10 time steps and +have more than 45 members if consistency between the weighted and unweighted +methodologies is desired.} \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} } \value{ -A numerical array of RPS with the same dimensions as "exp" except the -'time_dim' and 'memb_dim' dimensions. +A numerical array of RPS with dimensions c(nexp, nobs, the rest dimensions of +'exp' except 'time_dim' and 'memb_dim' dimensions). nexp is the number of +experiment (i.e., dat_dim in exp), and nobs is the number of observation +(i.e., dat_dim in obs). If dat_dim is NULL, nexp and nobs are omitted. } \description{ The Ranked Probability Score (RPS; Wilks, 2011) is defined as the sum of the @@ -64,7 +73,8 @@ of multi-categorical probabilistic forecasts. The RPS ranges between 0 categories. In the case of a forecast divided into two categories (the lowest number of categories that a probabilistic forecast can have), the RPS corresponds to the Brier Score (BS; Wilks, 2011), therefore, ranges between 0 -and 1. +and 1. If there is more than one dataset, RPS will be computed for each pair +of exp and obs data. } \examples{ exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) diff --git a/man/RPSS.Rd b/man/RPSS.Rd index 5b8bd7ec07dfc58f5a588fd2113009b441eb1445..a68f21ca4b864411bc19f6a71aa612c910493d66 100644 --- a/man/RPSS.Rd +++ b/man/RPSS.Rd @@ -10,23 +10,30 @@ RPSS( ref = NULL, time_dim = "sdate", memb_dim = "member", + dat_dim = NULL, prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, weights = NULL, + weights_exp = NULL, + weights_ref = NULL, ncores = NULL ) } \arguments{ -\item{exp}{A named numerical array of the forecast with at least time -dimension.} +\item{exp}{A named numerical array of the forecast with at least time and +member dimension.} \item{obs}{A named numerical array of the observation with at least time -dimension. The dimensions must be the same as 'exp' except 'memb_dim'.} +dimension. The dimensions must be the same as 'exp' except 'memb_dim' and +'dat_dim'.} \item{ref}{A named numerical array of the reference forecast data with at -least time dimension. The dimensions must be the same as 'exp' except -'memb_dim'. If it is NULL, the climatological forecast is used as reference +least time and member dimension. The dimensions must be the same as 'exp' +except 'memb_dim' and 'dat_dim'. If there is only one reference dataset, +it should not have dataset dimension. If there is corresponding reference +for each experiement, the dataset dimension must have the same length as in +'exp'. If 'ref' is NULL, the climatological forecast is used as reference forecast. The default value is NULL.} \item{time_dim}{A character string indicating the name of the time dimension. @@ -36,6 +43,10 @@ The default value is 'sdate'.} to compute the probabilities of the forecast and the reference forecast. The default value is 'member'.} +\item{dat_dim}{A character string indicating the name of dataset dimension. +The length of this dimension can be different between 'exp' and 'obs'. +The default value is NULL.} + \item{prob_thresholds}{A numeric vector of the relative thresholds (from 0 to 1) between the categories. The default value is c(1/3, 2/3), which corresponds to tercile equiprobable categories.} @@ -48,23 +59,32 @@ the whole period is used. The default value is NULL.} potential RPSS that the forecast would have with an infinite ensemble size). The default value is FALSE.} -\item{weights}{A named two-dimensional numerical array of the weights for each -member and time. The dimension names should include 'memb_dim' and -'time_dim'. The default value is NULL. The ensemble should have at least 70 -members or span at least 10 time steps and have more than 45 members if -consistency between the weighted and unweighted methodologies is desired.} +\item{weights}{Deprecated and will be removed in the next release. Please use +'weights_exp' and 'weights_ref' instead.} + +\item{weights_exp}{A named numerical array of the forecast ensemble weights. +The dimension should include 'memb_dim', 'time_dim' and 'dat_dim' if there +are multiple datasets. All dimension lengths must be equal to 'exp' +dimension lengths. The default value is NULL, which means no weighting is +applied. The ensemble should have at least 70 members or span at least 10 +time steps and have more than 45 members if consistency between the weighted + and unweighted methodologies is desired.} + +\item{weights_ref}{Same as 'weights_exp' but for the reference forecast.} \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} } \value{ \item{$rpss}{ - A numerical array of the RPSS with the same dimensions as "exp" except the - 'time_dim' and 'memb_dim' dimensions. + A numerical array of RPSS with dimensions c(nexp, nobs, the rest dimensions + of 'exp' except 'time_dim' and 'memb_dim' dimensions). nexp is the number of + experiment (i.e., dat_dim in exp), and nobs is the number of observation + i.e., dat_dim in obs). If dat_dim is NULL, nexp and nobs are omitted. } \item{$sign}{ - A logical array of the statistical significance of the RPSS with the same - dimensions as 'exp' except the 'time_dim' and 'memb_dim' dimensions. + A logical array of the statistical significance of the RPSS with the same + dimensions as $rpss. } } \description{ @@ -76,17 +96,27 @@ RPSS is positive, it indicates that the forecast has higher skill than the reference forecast, while a negative value means that it has a lower skill. Examples of reference forecasts are the climatological forecast (same probabilities for all categories for all time steps), persistence, a previous -model version, and another model. It is computed as RPSS = 1 - RPS_exp / RPS_ref. -The statistical significance is obtained based on a Random Walk test at the -95% confidence level (DelSole and Tippett, 2016). +model version, and another model. It is computed as +\code{RPSS = 1 - RPS_exp / RPS_ref}. The statistical significance is obtained +based on a Random Walk test at the 95% confidence level (DelSole and Tippett, +2016). If there is more than one dataset, RPS will be computed for each pair +of exp and obs data. } \examples{ -exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) -obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50)) -ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +set.seed(1) +exp <- array(rnorm(3000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +set.seed(2) +obs <- array(rnorm(300), dim = c(lat = 3, lon = 2, sdate = 50)) +set.seed(3) +ref <- array(rnorm(3000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50)) +weights <- sapply(1:dim(exp)['sdate'], function(i) { + n <- abs(rnorm(10)) + n/sum(n) + }) +dim(weights) <- c(member = 10, sdate = 50) res <- RPSS(exp = exp, obs = obs) ## climatology as reference forecast res <- RPSS(exp = exp, obs = obs, ref = ref) ## ref as reference forecast - +res <- RPSS(exp = exp, obs = obs, ref = ref, weights_exp = weights, weights_ref = weights) } \references{ Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7 diff --git a/man/RatioRMS.Rd b/man/RatioRMS.Rd index 194c6b9899e84dfd1772117cc9eade22d2e1e7b7..3330eb5a31aec9507a6836451f38ef829fcc108d 100644 --- a/man/RatioRMS.Rd +++ b/man/RatioRMS.Rd @@ -30,7 +30,7 @@ computation. The default value is NULL.} } \value{ A list containing the numeric arrays with dimensions identical with - 'exp1', 'exp2', and 'obs', expect 'time_dim': + 'exp1', 'exp2', and 'obs', except 'time_dim': \item{$ratiorms}{ The ratio between the RMSE (i.e., RMSE1/RMSE2). } diff --git a/man/UltimateBrier.Rd b/man/UltimateBrier.Rd index 2cad133c23d620eeee9e0a57d7466550da9478cf..0dfa772e00dd9d9efa0679b781fee56a76ae855f 100644 --- a/man/UltimateBrier.Rd +++ b/man/UltimateBrier.Rd @@ -19,16 +19,17 @@ UltimateBrier( } \arguments{ \item{exp}{A numeric array of forecast anomalies with named dimensions that -at least include 'dat_dim', 'memb_dim', and 'time_dim'. It can be provided +at least include 'memb_dim', and 'time_dim'. It can be provided by \code{Ano()}.} \item{obs}{A numeric array of observational reference anomalies with named -dimensions that at least include 'dat_dim' and 'time_dim'. If it has +dimensions that at least include 'time_dim'. If it has 'memb_dim', the length must be 1. The dimensions should be consistent with 'exp' except 'dat_dim' and 'memb_dim'. It can be provided by \code{Ano()}.} \item{dat_dim}{A character string indicating the name of the dataset -dimension in 'exp' and 'obs'. The default value is 'dataset'.} +dimension in 'exp' and 'obs'. The default value is 'dataset'. If there is no dataset +dimension, set NULL.} \item{memb_dim}{A character string indicating the name of the member dimension in 'exp' (and 'obs') for ensemble mean calculation. The default @@ -78,7 +79,7 @@ is an array of Brier scores or Brier skill scores. All the arrays have the same dimensions: c(nexp, nobs, no. of bins, the rest dimensions of 'exp' except 'time_dim' and 'memb_dim'). 'nexp' and 'nobs' is the length of dataset dimension in 'exp' -and 'obs' respectively.\cr +and 'obs' respectively. If dat_dim is NULL, nexp and nobs are omitted.\cr The list of 4 includes: \itemize{ \item{$bs: Brier Score} diff --git a/man/s2dv-package.Rd b/man/s2dv-package.Rd index 3c98a95154225719ceb248570f232b02e9434545..f0c407d5652edc0bdff367888e72101da43d7f7f 100644 --- a/man/s2dv-package.Rd +++ b/man/s2dv-package.Rd @@ -6,7 +6,7 @@ \alias{s2dv-package} \title{s2dv: A Set of Common Tools for Seasonal to Decadal Verification} \description{ -The advanced version of package 's2dverification'. It is intended for 'seasonal to decadal' (s2d) climate forecast verification, but it can also be used in other kinds of forecasts or general climate analysis. This package is specially designed for the comparison between the experimental and observational datasets. The functionality of the included functions covers from data retrieval, data post-processing, skill scores against observation, to visualization. Compared to 's2dverification', 's2dv' is more compatible with the package 'startR', able to use multiple cores for computation and handle multi-dimensional arrays with a higher flexibility. +The advanced version of package 's2dverification'. It is intended for 'seasonal to decadal' (s2d) climate forecast verification, but it can also be used in other kinds of forecasts or general climate analysis. This package is specially designed for the comparison between the experimental and observational datasets. The functionality of the included functions covers from data retrieval, data post-processing, skill scores against observation, to visualization. Compared to 's2dverification', 's2dv' is more compatible with the package 'startR', able to use multiple cores for computation and handle multi-dimensional arrays with a higher flexibility. The CDO version used in development is 1.9.8. } \references{ \url{https://earth.bsc.es/gitlab/es/s2dv/} @@ -36,6 +36,7 @@ Other contributors: \item Llorenç Lledó \email{llorenc.lledo@bsc.es} [contributor] \item Andrea Manrique \email{andrea.manrique@bsc.es} [contributor] \item Deborah Verfaillie \email{deborah.verfaillie@bsc.es} [contributor] + \item Eva Rifà \email{eva.rifarovira@bsc.es} [contributor] } } diff --git a/s2dv-manual.pdf b/s2dv-manual.pdf index 2b6da42257033ded7f67d7307378f372ae3a10fe..b4929e91355acf41086488ce94a23527e278f884 100644 Binary files a/s2dv-manual.pdf and b/s2dv-manual.pdf differ diff --git a/tests/testthat/test-ACC.R b/tests/testthat/test-ACC.R index 5c3672552930be48e114949fdb2301a8ab429bce..6431a9c05155fc76a94e4d92f271df482a3bcc38 100644 --- a/tests/testthat/test-ACC.R +++ b/tests/testthat/test-ACC.R @@ -62,7 +62,7 @@ test_that("1. Input checks", { # space_dim (deprecated) expect_warning( ACC(exp1, obs1, space_dim = c('lat', 'lon'), lat = c(1, 2)), - "Parameter 'space_dim' is deprecated. Use 'lat_dim' and 'lon_dim' instead." + "! Warning: Parameter 'space_dim' is deprecated. Use 'lat_dim' and 'lon_dim'\n! instead." ) # lat_dim expect_error( @@ -152,7 +152,7 @@ test_that("1. Input checks", { obs = array(1:4, dim = c(dataset = 2, member = 2, lat = 1, lon = 1)), lat = c(1, 2), lon = c(1), avg_dim = NULL), - "Parameter 'exp' and 'obs' must have same length of all the dimensions expect 'dat_dim' and 'memb_dim'." + "Parameter 'exp' and 'obs' must have same length of all the dimensions except 'dat_dim' and 'memb_dim'." ) }) diff --git a/tests/testthat/test-AbsBiasSS.R b/tests/testthat/test-AbsBiasSS.R new file mode 100644 index 0000000000000000000000000000000000000000..08a4a83d147be31fe3be3d69c796c55c59940c20 --- /dev/null +++ b/tests/testthat/test-AbsBiasSS.R @@ -0,0 +1,324 @@ +context("s2dv::AbsBiasSS tests") + +############################################## + +# dat1 +set.seed(1) +exp1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) +set.seed(2) +obs1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) +set.seed(3) +ref1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) + +# dat2 +set.seed(1) +exp2 <- array(rnorm(60), dim = c(member = 2, sdate = 10, lat = 3)) +set.seed(2) +obs2 <- array(rnorm(30), dim = c(member = 1, sdate = 10, lat = 3)) +set.seed(3) +ref2 <- array(rnorm(60), dim = c(member = 2, sdate = 10, lat = 3)) + +# dat3 +set.seed(1) +exp3 <- array(rnorm(80), dim = c(member = 2, sdate = 10, lat = 2, dataset = 2)) +set.seed(2) +obs3 <- array(rnorm(60), dim = c(sdate = 10, lat = 2, dataset = 3)) +set.seed(3) +ref3 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) + +# dat4 +set.seed(1) +exp4 <- array(rnorm(80), dim = c(member = 2, sdate = 10, lat = 2, dataset = 2)) +set.seed(2) +obs4 <- array(rnorm(60), dim = c(sdate = 10, lat = 2, dataset = 3)) +set.seed(3) +ref4 <- array(rnorm(40), dim = c(sdate = 10, lat = 2, dataset = 2)) + +# dat5 +set.seed(1) +exp5 <- array(rnorm(10), dim = c(sdate = 10)) +exp5_1 <- array(exp5, dim = c(sdate = 10, dataset = 1)) +exp5_2 <- exp5_1 +exp5_2[1] <- NA +set.seed(2) +obs5 <- array(rnorm(10), dim = c(sdate = 10)) +obs5_1 <- array(obs5, dim = c(sdate = 10, dataset = 1)) +obs5_2 <- obs5_1 +obs5_2[c(1, 3)] <- NA +set.seed(3) +ref5 <- array(rnorm(10), dim = c(sdate = 10)) + +############################################## +test_that("1. Input checks", { + # exp and obs (1) + expect_error( + AbsBiasSS(c()), + "Parameter 'exp' must be a numeric array." + ) + expect_error( + AbsBiasSS(exp1, c()), + "Parameter 'obs' must be a numeric array." + ) + expect_error( + AbsBiasSS(exp1, array(rnorm(20), dim = c(10, lat = 2))), + "Parameter 'exp' and 'obs' must have dimension names." + ) + expect_error( + AbsBiasSS(exp1, array(rnorm(20), dim = c(10, lat = 2))), + "Parameter 'exp' and 'obs' must have dimension names." + ) + expect_error( + AbsBiasSS(exp1, obs1, ref = 'ref'), + "Parameter 'ref' must be a numeric array." + ) + expect_error( + AbsBiasSS(exp1, obs1, ref = array(rnorm(20), dim = c(10, lat = 2))), + "Parameter 'ref' must have dimension names." + ) + # time_dim + expect_error( + AbsBiasSS(exp1, obs1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + AbsBiasSS(exp1, obs1, time_dim = 'time'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + ) + expect_error( + AbsBiasSS(exp1, obs1, ref = array(rnorm(20), dim = c(lon = 10, lat = 2)), time_dim = 'time'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + ) + # memb_dim + expect_error( + AbsBiasSS(exp1, obs1, memb_dim = TRUE), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + AbsBiasSS(exp1, obs1, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' dimension." + ) + expect_error( + AbsBiasSS(exp2, array(rnorm(20), dim = c(member = 3, sdate = 10, lat = 2)), memb_dim = 'member'), + "Not implemented for observations with members ('obs' can have 'memb_dim', but it should be of length = 1).", fixed = TRUE + ) + # dat_dim + expect_error( + AbsBiasSS(exp1, obs1, dat_dim = TRUE, ), + "Parameter 'dat_dim' must be a character string." + ) + expect_error( + AbsBiasSS(exp1, obs1, dat_dim = 'dat_dim'), + "Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension. Set it as NULL if there is no dataset dimension." + ) + # exp, ref, and obs (2) + expect_error( + AbsBiasSS(exp1, array(1:9, dim = c(sdate = 9))), + "Parameter 'exp' and 'obs' must have same length of all dimensions except 'memb_dim' and 'dat_dim'." + ) + expect_error( + AbsBiasSS(exp3, obs3, ref = obs3, dat_dim = 'dataset', memb_dim = 'member'), + "If parameter 'ref' has dataset dimension, it must be equal to dataset dimension of 'exp'." + ) + expect_error( + AbsBiasSS(exp1, obs1, ref = ref2), + "Parameter 'exp' and 'ref' must have the same length of all dimensions except 'memb_dim' and 'dat_dim' if there is only one reference dataset." + ) + # na.rm + expect_error( + AbsBiasSS(exp2, obs2, memb_dim = 'member', na.rm = 1.5), + "Parameter 'na.rm' must be one logical value." + ) + # ncores + expect_error( + AbsBiasSS(exp2, obs2, memb_dim = 'member', ncores = 1.5), + "Parameter 'ncores' must be either NULL or a positive integer." + ) + +}) + +############################################## +test_that("2. Output checks: dat1", { + + expect_equal( + dim(AbsBiasSS(exp1, obs1)$biasSS), + c(lat = 2) + ) + expect_equal( + dim(AbsBiasSS(exp1, obs1)$sign), + c(lat = 2) + ) + expect_equal( + dim(AbsBiasSS(exp1, obs1, ref1)$biasSS), + c(lat = 2) + ) + expect_equal( + dim(AbsBiasSS(exp1, obs1, ref1)$sign), + c(lat = 2) + ) + expect_equal( + as.vector(AbsBiasSS(exp1, obs1)$biasSS), + c(-0.3103594, 0.0772921), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp1, obs1, ref1)$biasSS), + c(-0.07871642, 0.28868904), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp1, obs1)$sign), + c(FALSE, FALSE), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp1, exp1)$sign), + c(TRUE, TRUE), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("3. Output checks: dat2", { + + expect_equal( + dim(AbsBiasSS(exp2, obs2, memb_dim = 'member')$biasSS), + c(lat = 3) + ) + expect_equal( + dim(AbsBiasSS(exp2, obs2, ref2, memb_dim = 'member')$biasSS), + c(lat = 3) + ) + expect_equal( + as.vector(AbsBiasSS(exp2, obs2, memb_dim = 'member')$biasSS), + c(-0.4743706, -0.2884077, -0.4064404), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp2, obs2, ref2, memb_dim = 'member')$biasSS), + c(-0.07319869, 0.06277502, -0.17321998), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("4. Output checks: dat3", { + + expect_equal( + dim(AbsBiasSS(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset')$biasSS), + c(nexp = 2, nobs = 3, lat = 2) + ) + expect_equal( + dim(AbsBiasSS(exp3, obs3, ref3, memb_dim = 'member', dat_dim = 'dataset')$biasSS), + c(nexp = 2, nobs = 3, lat = 2) + ) + expect_equal( + as.vector(AbsBiasSS(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset')$biasSS)[5:10], + c(-0.09794912, -0.11814710, -0.28840768, 0.02117376, -0.31282805, -0.08754112), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp3, obs3, ref3, memb_dim = 'member', dat_dim = 'dataset')$biasSS)[5:10], + c(0.264602089, 0.251073637, 0.006772886, 0.245427687, 0.168998894, 0.311602249), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp2, obs2, memb_dim = 'member')$biasSS)[1:2], + as.vector(AbsBiasSS(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset')$biasSS[1,1,]) + ) + expect_equal( + as.vector(AbsBiasSS(exp3, obs3, ref3, memb_dim = 'member', dat_dim = 'dataset', na.rm = TRUE)$biasSS)[1:5], + c(-0.21373395, -0.34444526, 0.11039962, 0.05523797, 0.26460209) + ) + +}) +############################################## +test_that("5. Output checks: dat4", { + + expect_equal( + dim(AbsBiasSS(exp4, obs4, memb_dim = 'member', dat_dim = 'dataset')$biasSS), + c(nexp = 2, nobs = 3, lat = 2) + ) + expect_equal( + dim(AbsBiasSS(exp4, obs4, ref4, memb_dim = 'member', dat_dim = 'dataset')$biasSS), + c(nexp = 2, nobs = 3, lat = 2) + ) + expect_equal( + as.vector(AbsBiasSS(exp4, obs4, memb_dim = 'member', dat_dim = 'dataset', na.rm = TRUE)$biasSS)[5:10], + c(-0.09794912, -0.11814710, -0.28840768, 0.02117376, -0.31282805, -0.08754112), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp4, obs4, ref4, memb_dim = 'member', dat_dim = 'dataset')$biasSS)[5:10], + c(0.264602089, 0.133379718, 0.006772886, 0.242372951, 0.168998894, 0.272767238), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp2, obs2, memb_dim = 'member')$biasSS)[1:2], + as.vector(AbsBiasSS(exp4, obs4, memb_dim = 'member', dat_dim = 'dataset')$biasSS[1,1,]) + ) + expect_equal( + as.vector(AbsBiasSS(exp4, obs4, ref4, memb_dim = 'member', dat_dim = 'dataset', na.rm = TRUE)$biasSS)[1:5], + c(-0.213733950, -0.214240924, 0.110399615, -0.009733463, 0.264602089) + ) + +}) + +############################################## +test_that("6. Output checks: dat5", { + expect_equal( + dim(AbsBiasSS(exp5, obs5)$biasSS), + NULL + ) + expect_equal( + dim(AbsBiasSS(exp5, obs5)$sign), + NULL + ) + expect_equal( + as.vector(AbsBiasSS(exp5, obs5)$biasSS), + -0.3103594, + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp5, obs5)$sign), + FALSE + ) + expect_equal( + as.vector(AbsBiasSS(exp5, obs5, ref5)$biasSS), + -0.07871642, + tolerance = 0.0001 + ) + #5_1 + expect_equal( + dim(AbsBiasSS(exp5_1, obs5_1, dat_dim = 'dataset')$biasSS), + c(nexp = 1, nobs = 1) + ) + expect_equal( + dim(AbsBiasSS(exp5_1, obs5_1, dat_dim = 'dataset')$sign), + c(nexp = 1, nobs = 1) + ) + expect_equal( + as.vector(AbsBiasSS(exp5_1, obs5_1, dat_dim = 'dataset')$biasSS), + as.vector(AbsBiasSS(exp5, obs5)$biasSS) + ) + expect_equal( + as.vector(AbsBiasSS(exp5_1, obs5_1, ref = ref5, dat_dim = 'dataset')$biasSS), + as.vector(AbsBiasSS(exp5, obs5, ref = ref5)$biasSS) + ) + #5_2: NA test + expect_equal( + as.vector(AbsBiasSS(exp5_1, obs5_2, dat_dim = 'dataset')$biasSS), + as.numeric(NA) + ) + expect_equal( + as.vector(AbsBiasSS(exp5_1, obs5_2, dat_dim = 'dataset', na.rm = T)$biasSS), + c(-0.4636772), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AbsBiasSS(exp5_2, obs5_2, ref = ref5, dat_dim = 'dataset', na.rm = T)$biasSS), + c(0.08069355), + tolerance = 0.0001 + ) +}) diff --git a/tests/testthat/test-Ano_CrossValid.R b/tests/testthat/test-Ano_CrossValid.R index b66fc5fbf54113b71826e7adf79d014890c003e0..2d7c00c127b75ad9e240630bce109fd9b001d904 100644 --- a/tests/testthat/test-Ano_CrossValid.R +++ b/tests/testthat/test-Ano_CrossValid.R @@ -13,6 +13,12 @@ exp2 <- array(rnorm(30), dim = c(member = 3, ftime = 2, sdate = 5)) set.seed(2) obs2 <- array(rnorm(20), dim = c(ftime = 2, member = 2, sdate = 5)) +# dat3 +set.seed(1) +exp3 <- array(rnorm(30), dim = c(ftime = 2, sdate = 5)) +set.seed(2) +obs3 <- array(rnorm(20), dim = c(ftime = 2, sdate = 5)) + ############################################## test_that("1. Input checks", { @@ -51,7 +57,7 @@ test_that("1. Input checks", { ) expect_error( Ano_CrossValid(exp1, obs1, dat_dim = 'dat'), - "Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension." + "Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension. Set it as NULL if there is no dataset dimension." ) # memb expect_error( @@ -136,6 +142,28 @@ test_that("3. dat2", { }) +############################################## +test_that("4. dat3", { + expect_equal( + names(Ano_CrossValid(exp3, obs3, dat_dim = NULL)), + c("exp", "obs") + ) + expect_equal( + dim(Ano_CrossValid(exp3, obs3, dat_dim = NULL)$exp), + c(sdate = 5, ftime = 2) + ) + expect_equal( + Ano_CrossValid(exp3, obs3, dat_dim = NULL)$exp[, 2], + c(-0.1182939, 1.6462530, -1.3734335, 0.5750579, -0.7295835), + tolerance = 0.0001 + ) + expect_equal( + Ano_CrossValid(exp3, obs3, dat_dim = NULL)$exp[, 2], + c(-0.1182939, 1.6462530, -1.3734335, 0.5750579, -0.7295835), + tolerance = 0.0001 + ) + +}) diff --git a/tests/testthat/test-Bias.R b/tests/testthat/test-Bias.R new file mode 100644 index 0000000000000000000000000000000000000000..842ecc2c2b626649603f3d964ca20adee2fd22df --- /dev/null +++ b/tests/testthat/test-Bias.R @@ -0,0 +1,240 @@ +context("s2dv::Bias tests") + +############################################## + +# dat1 +set.seed(1) +exp1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) +set.seed(2) +obs1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) + +# dat2 +set.seed(1) +exp2 <- array(rnorm(40), dim = c(member = 2, sdate = 10, lat = 2)) +set.seed(2) +obs2 <- array(rnorm(20), dim = c(member = 1, sdate = 10, lat = 2)) + +# dat3 +set.seed(1) +exp3 <- array(rnorm(80), dim = c(member = 2, sdate = 10, lat = 2, dataset = 2)) +set.seed(2) +obs3 <- array(rnorm(60), dim = c(sdate = 10, lat = 2, dataset = 3)) + +# dat4 +set.seed(1) +exp4 <- array(rnorm(10), dim = c(sdate = 10)) +exp4_1 <- array(exp4, dim = c(sdate = 10, dataset = 1)) +set.seed(2) +obs4 <- array(rnorm(10), dim = c(sdate = 10)) +obs4_1 <- array(obs4, dim = c(sdate = 10, dataset = 1)) +obs4_2 <- obs4_1 +obs4_2[c(1, 3)] <- NA + +############################################## +test_that("1. Input checks", { + # exp and obs (1) + expect_error( + Bias(c()), + "Parameter 'exp' must be a numeric array." + ) + expect_error( + Bias(exp1, c()), + "Parameter 'obs' must be a numeric array." + ) + expect_error( + Bias(exp1, array(rnorm(20), dim = c(10, lat = 2))), + "Parameter 'exp' and 'obs' must have dimension names." + ) + # time_dim + expect_error( + Bias(exp1, obs1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + Bias(exp1, obs1, time_dim = 'time'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + ) + # memb_dim + expect_error( + Bias(exp1, obs1, memb_dim = TRUE), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + Bias(exp1, obs1, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' dimension." + ) + expect_error( + Bias(exp2, array(rnorm(20), dim = c(member = 3, sdate = 10, lat = 2)), memb_dim = 'member'), + "Not implemented for observations with members ('obs' can have 'memb_dim', but it should be of length = 1).", fixed = TRUE + ) + # dat_dim + expect_error( + Bias(exp1, obs1, dat_dim = TRUE, ), + "Parameter 'dat_dim' must be a character string." + ) + expect_error( + Bias(exp1, obs1, dat_dim = 'dat_dim'), + "Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension. Set it as NULL if there is no dataset dimension." + ) + # exp, ref, and obs (2) + expect_error( + Bias(exp1, array(1:9, dim = c(sdate = 9))), + "Parameter 'exp' and 'obs' must have same length of all dimensions except 'memb_dim' and 'dat_dim'." + ) + # na.rm + expect_error( + Bias(exp2, obs2, memb_dim = 'member', na.rm = 1.5), + "Parameter 'na.rm' must be one logical value." + ) + # absolute + expect_error( + Bias(exp2, obs2, memb_dim = 'member', ncores = 1.5), + "Parameter 'ncores' must be either NULL or a positive integer." + ) + # time_mean + expect_error( + Bias(exp2, obs2, memb_dim = 'member', time_mean = 1.5), + "Parameter 'time_mean' must be one logical value." + ) + # ncores + expect_error( + Bias(exp2, obs2, memb_dim = 'member', ncores = 1.5), + "Parameter 'ncores' must be either NULL or a positive integer." + ) + +}) + +############################################## +test_that("2. Output checks: dat1", { + + expect_equal( + dim(Bias(exp1, obs1)), + c(lat = 2) + ) + expect_equal( + dim(Bias(exp1, obs1, time_mean = FALSE)), + c(sdate = 10, lat = 2) + ) + expect_equal( + as.vector(Bias(exp1, obs1)), + c(-0.07894886, 0.06907455), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Bias(exp1, obs1, absolute = TRUE)), + c(0.9557288, 0.8169118), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Bias(exp1, obs1, time_mean = FALSE, na.rm = TRUE))[1:5], + c(0.27046074, -0.00120586, -2.42347394, 2.72565648, 0.40975953), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("3. Output checks: dat2", { + + expect_equal( + dim(Bias(exp2, obs2, memb_dim = 'member')), + c(lat = 2) + ) + expect_equal( + dim(Bias(exp2, obs2, memb_dim = 'member', time_mean = FALSE)), + c(sdate = 10, lat = 2) + ) + expect_equal( + as.vector(Bias(exp2, obs2, memb_dim = 'member')), + c(-0.02062777, -0.18624194), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Bias(exp2, obs2, memb_dim = 'member', time_mean = FALSE)[1:2,1:2]), + c(0.6755093, 0.1949769, 0.4329061, -1.9391461), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("4. Output checks: dat3", { + + expect_equal( + dim(Bias(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset')), + c(nexp = 2, nobs = 3, lat = 2) + ) + expect_equal( + dim(Bias(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset', time_mean = FALSE)), + c(sdate = 10, nexp = 2, nobs = 3, lat = 2) + ) + expect_equal( + as.vector(Bias(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset'))[5:10], + c(0.23519286, 0.18346575, -0.18624194, -0.07803352, 0.28918537, 0.39739379), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Bias(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset', absolute = TRUE, time_mean = FALSE))[5:10], + c(0.2154482, 0.8183919, 2.1259250, 0.7796967, 1.5206510, 0.8463483), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Bias(exp2, obs2, memb_dim = 'member')), + as.vector(Bias(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset')[1,1,]) + ) + expect_equal( + as.vector(Bias(exp2, obs2, memb_dim = 'member', time_mean = FALSE)), + as.vector(Bias(exp3, obs3, memb_dim = 'member', dat_dim = 'dataset', time_mean = FALSE)[ ,1,1,]) + ) + +}) + +############################################## +test_that("5. Output checks: dat4", { + expect_equal( + dim(Bias(exp4, obs4)), + NULL + ) + expect_equal( + dim(Bias(exp4, obs4, time_mean = F)), + c(sdate = 10) + ) + expect_equal( + as.vector(Bias(exp4, obs4, time_mean = F)), + as.vector(exp4 - obs4) + ) + expect_equal( + as.vector(Bias(exp4, obs4, time_mean = F, absolute = T)), + abs(as.vector(exp4 - obs4)) + ) + expect_equal( + as.vector(Bias(exp4, obs4, absolute = T)), + mean(abs(as.vector(exp4 - obs4))) + ) + + expect_equal( + dim(Bias(exp4_1, obs4_1, dat_dim = 'dataset')), + c(nexp = 1, nobs = 1) + ) + expect_equal( + dim(Bias(exp4_1, obs4_1, dat_dim = 'dataset', time_mean = F)), + c(sdate = 10, nexp = 1, nobs = 1) + ) + expect_equal( + as.vector(Bias(exp4_1, obs4_1, dat_dim = 'dataset', time_mean = F)), + as.vector(Bias(exp4, obs4, time_mean = F)) + ) + # 4_2: NA + expect_equal( + as.vector(Bias(exp4_1, obs4_2, dat_dim = 'dataset')), + as.numeric(NA) + ) + expect_equal( + as.vector(Bias(exp4_1, obs4_2, dat_dim = 'dataset', time_mean = F))[c(1, 3)], + as.numeric(c(NA, NA)) + ) + expect_equal( + as.vector(Bias(exp4_1, obs4_2, dat_dim = 'dataset', time_mean = F))[c(2, 4:10)], + as.vector(Bias(exp4, obs4, time_mean = F))[c(2, 4:10)] + ) +}) diff --git a/tests/testthat/test-BrierScore.R b/tests/testthat/test-BrierScore.R index 5668a089972352b29db2d553acb7134a3ede2203..e2c34f95744114b72ff7f5ac89131bf29f5da250 100644 --- a/tests/testthat/test-BrierScore.R +++ b/tests/testthat/test-BrierScore.R @@ -51,7 +51,7 @@ test_that("1. Input checks", { expect_error( BrierScore(exp3, obs3), paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.") + "of all the dimensions except 'dat_dim' and 'memb_dim'.") ) # thresholds expect_error( diff --git a/tests/testthat/test-CRPS.R b/tests/testthat/test-CRPS.R new file mode 100644 index 0000000000000000000000000000000000000000..972eb45c7a7993ad3b7c535886b8f596ac09a56c --- /dev/null +++ b/tests/testthat/test-CRPS.R @@ -0,0 +1,138 @@ +context("s2dv::CRPS tests") + +############################################## + +# dat1 +set.seed(1) +exp1 <- array(rnorm(60), dim = c(member = 3, sdate = 10, lat = 2)) +set.seed(2) +obs1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) + +# dat2 +set.seed(1) +exp2 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) +set.seed(2) +obs2 <- array(rnorm(10), dim = c(sdate = 10)) + +# dat3 +set.seed(1) +exp3 <- array(rnorm(40), dim = c(member = 2, sdate = 10, dataset = 2)) +set.seed(2) +obs3 <- array(rnorm(30), dim = c(member = 1, sdate = 10, dataset = 3)) + +############################################## +test_that("1. Input checks", { + # exp and obs (1) + expect_error( + CRPS(c()), + "Parameter 'exp' must be a numeric array." + ) + expect_error( + CRPS(exp1, c()), + "Parameter 'obs' must be a numeric array." + ) + + # time_dim + expect_error( + CRPS(exp1, obs1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + CRPS(exp1, obs1, time_dim = 'time'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + ) + # memb_dim + expect_error( + CRPS(exp1, obs1, memb_dim = TRUE), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + CRPS(exp1, obs1, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' dimension." + ) + ## exp and obs (2) + expect_error(CRPS(exp1, array(1:40, dim = c(sdate = 10, lat = 2, member = 2))), + "Not implemented for observations with members ('obs' can have 'memb_dim', but it should be of length = 1).", fixed = TRUE + ) + expect_error( + CRPS(exp1, array(1:9, dim = c(sdate = 9))), + "Parameter 'exp' and 'obs' must have same length of all dimensions except 'memb_dim' and 'dat_dim'." + ) + # Fair + expect_error( + CRPS(exp1, obs1, Fair = 1), + "Parameter 'Fair' must be either TRUE or FALSE." + ) + # ncores + expect_error( + CRPS(exp2, obs2, ncores = 1.5), + "Parameter 'ncores' must be either NULL or a positive integer." + ) + +}) + +############################################## +test_that("2. Output checks: dat1", { + + expect_equal( + dim(CRPS(exp1, obs1)), + c(lat = 2) + ) + expect_equal( + as.vector(CRPS(exp1, obs1)), + c(0.5947612, 0.7511546), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPS(exp1, obs1, Fair = TRUE)), + c(0.4215127, 0.5891242), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPS(exp1, obs1, Fair = FALSE)), + c(0.5947612, 0.7511546), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("3. Output checks: dat2", { + + expect_equal( + dim(CRPS(exp2, obs2)), + NULL + ) + expect_equal( + CRPS(exp2, obs2), + 0.9350226, + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPS(exp2, obs2, Fair = TRUE)), + as.vector(CRPS(array(exp2, dim = c(dim(exp2), dataset = 1)), array(obs2, dim = c(dim(obs2), dataset = 1)), dat_dim = 'dataset', Fair = TRUE)), + tolerance = 0.0001 + ) +}) + + + +############################################## +test_that("3. Output checks: dat3", { + + expect_equal( + dim(CRPS(exp3, obs3, dat_dim = 'dataset')), + c(nexp = 2, nobs = 3) + ) + expect_equal( + as.vector(CRPS(exp3, obs3, dat_dim = 'dataset', Fair = FALSE)), + c(0.9350226, 0.8354833, 1.0047853, 0.9681745, 1.2192761, 1.0171790), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPS(exp3, obs3, dat_dim = 'dataset', Fair = TRUE)), + c(0.6701312, 0.6198684, 0.7398939, 0.7525596, 0.9543847, 0.8015641), + tolerance = 0.0001 + ) + +}) diff --git a/tests/testthat/test-CRPSS.R b/tests/testthat/test-CRPSS.R new file mode 100644 index 0000000000000000000000000000000000000000..6937edb2332888a8368663a1660c89db944e6749 --- /dev/null +++ b/tests/testthat/test-CRPSS.R @@ -0,0 +1,324 @@ +context("s2dv::CRPSS tests") + +############################################## + +# dat1 +set.seed(1) +exp1 <- array(rnorm(60), dim = c(member = 3, sdate = 10, lat = 2)) +set.seed(2) +obs1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) +set.seed(3) +ref1 <- array(rnorm(40), dim = c(member = 2, sdate = 10, lat = 2)) + +# dat2 +set.seed(1) +exp2 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) +set.seed(2) +obs2 <- array(rnorm(10), dim = c(sdate = 10)) +set.seed(3) +ref2 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) + +# dat2_2 +set.seed(1) +exp2_2 <- array(rnorm(20), dim = c(member = 2, sdate = 10, dataset = 1)) +set.seed(2) +obs2_2 <- array(rnorm(10), dim = c(sdate = 10, dataset = 1)) +set.seed(3) +ref2_2 <- array(rnorm(20), dim = c(member = 2, sdate = 10, dataset = 1)) + +# dat3 +set.seed(1) +exp3 <- array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3)) +set.seed(2) +obs3 <- array(rnorm(20), dim = c(member = 1, sdate = 10, dataset = 2)) +set.seed(3) +ref3 <- array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3)) + +# dat4 +set.seed(1) +exp4 <- array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3, lat = 2)) +set.seed(2) +obs4 <- array(rnorm(20), dim = c(member = 1, sdate = 10, dataset = 2, lat = 2)) +set.seed(3) +ref4 <- array(rnorm(60), dim = c(member = 2, sdate = 10, lat = 2)) + +############################################## +test_that("1. Input checks", { + # exp and obs (1) + expect_error( + CRPSS(c()), + "Parameter 'exp' must be a numeric array." + ) + expect_error( + CRPSS(exp1, c()), + "Parameter 'obs' must be a numeric array." + ) + + # time_dim + expect_error( + CRPSS(exp1, obs1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + CRPSS(exp1, obs1, time_dim = 'time'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + ) + expect_error( + CRPSS(exp2, obs2, array(rnorm(20), dim = c(member = 2, time = 10))), + "Parameter 'time_dim' is not found in 'ref' dimension." + ) + # memb_dim + expect_error( + CRPSS(exp1, obs1, memb_dim = TRUE), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + CRPSS(exp1, obs1, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' dimension." + ) + expect_error( + CRPSS(exp2, obs2, array(rnorm(20), dim = c(memb = 2, sdate = 10))), + "Parameter 'memb_dim' is not found in 'ref' dimension." + ) + # exp, ref, and obs (2) + expect_error( + CRPSS(exp1, array(1:9, dim = c(sdate = 9))), + "Parameter 'exp' and 'obs' must have same length of all dimensions except 'memb_dim' and 'dat_dim'." + ) + expect_error( + CRPSS(exp2_2, obs2_2, array(1:9, dim = c(sdate = 9, member = 2, dataset = 3)), dat_dim = 'dataset'), + "If parameter 'ref' has dataset dimension it must be equal to dataset dimension of 'exp'." + ) + expect_error( + CRPSS(exp1, obs1, ref2), + "Parameter 'exp' and 'ref' must have same length of all dimensions except 'memb_dim' and 'dat_dim' if there is only one reference dataset." + ) + expect_error( + CRPSS(exp3, array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3)), ref3, dat_dim = 'dataset'), + "Not implemented for observations with members ('obs' can have 'memb_dim', but it should be of length = 1)." + , fixed = TRUE + ) + # Fair + expect_error( + CRPSS(exp1, obs1, Fair = 1), + "Parameter 'Fair' must be either TRUE or FALSE." + ) + # ncores + expect_error( + CRPSS(exp2, obs2, ncores = 1.5), + "Parameter 'ncores' must be either NULL or a positive integer." + ) + +}) + +############################################## +test_that("2. Output checks: dat1", { + + expect_equal( + names(CRPSS(exp1, obs1)), + c("crpss", "sign") + ) + expect_equal( + names(CRPSS(exp1, obs1, ref1)), + c("crpss", "sign") + ) + expect_equal( + dim(CRPSS(exp1, obs1)$crpss), + c(lat = 2) + ) + expect_equal( + dim(CRPSS(exp1, obs1)$sign), + c(lat = 2) + ) + expect_equal( + dim(CRPSS(exp1, obs1, ref1)$crpss), + c(lat = 2) + ) + expect_equal( + dim(CRPSS(exp1, obs1, ref1)$sign), + c(lat = 2) + ) + # ref = NULL + expect_equal( + as.vector(CRPSS(exp1, obs1)$crpss), + c(-0.1582765, -0.2390707), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp1, obs1)$sign), + c(FALSE, FALSE), + ) + expect_equal( + as.vector(CRPSS(exp1, obs1, Fair = T)$crpss), + c(0.07650872, -0.09326681), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp1, obs1)$crpss), + c(-0.1582765, -0.2390707), + tolerance = 0.0001 + ) + # ref = ref + expect_equal( + as.vector(CRPSS(exp1, obs1, ref1)$crpss), + c(0.3491793, 0.3379610), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp1, obs1, ref1)$sign), + c(FALSE, FALSE) + ) + expect_equal( + as.vector(CRPSS(exp1, obs1, ref1, Fair = T)$crpss), + c( 0.3901440, 0.3788467), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp1, obs1, ref1)$crpss), + c( 0.3491793, 0.3379610), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("3. Output checks: dat2", { + + expect_equal( + names(CRPSS(exp2, obs2)), + c("crpss", "sign") + ) + expect_equal( + names(CRPSS(exp2, obs2, ref2)), + c("crpss", "sign") + ) + expect_equal( + dim(CRPSS(exp2, obs2)$crpss), + NULL + ) + expect_equal( + dim(CRPSS(exp2, obs2)$sign), + NULL + ) + expect_equal( + dim(CRPSS(exp2, obs2, ref2)$crpss), + NULL + ) + expect_equal( + dim(CRPSS(exp2, obs2, ref2)$sign), + NULL + ) + # ref = NULL + expect_equal( + as.vector(CRPSS(exp2, obs2)$crpss), + c(-0.8209236), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp2, obs2)$crpss), + as.vector(CRPSS(exp2_2, obs2_2, dat_dim = 'dataset')$crpss), + tolerance = 0.0001 + ) + + expect_equal( + as.vector(CRPSS(exp2, obs2)$sign), + TRUE, + ) + expect_equal( + as.vector(CRPSS(exp2, obs2, Fair = T)$crpss), + c(-0.468189), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp2, obs2, Fair = T)$crpss), + as.vector(CRPSS(exp2_2, obs2_2, dat_dim = 'dataset', Fair = T)$crpss), + tolerance = 0.0001 + ) + # ref = ref + expect_equal( + as.vector(CRPSS(exp2, obs2, ref2)$crpss), + -0.02315361, + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp2, obs2, ref2)$crpss), + as.vector(CRPSS(exp2_2, obs2_2, ref2_2, dat_dim = 'dataset')$crpss), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp2, obs2, ref2)$sign), + FALSE + ) + expect_equal( + as.vector(CRPSS(exp2, obs2, ref2, Fair = T)$crpss), + 0.030436, + tolerance = 0.0001 + ) + +}) +############################################## +test_that("4. Output checks: dat3", { + + expect_equal( + dim(CRPSS(exp3, obs3, dat_dim = 'dataset')$crpss), + c('nexp' = 3, 'nobs' = 2) + ) + expect_equal( + mean(CRPSS(exp3, obs3, dat_dim = 'dataset')$crpss), + c(-0.7390546), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp3, obs3, dat_dim = 'dataset')$crpss), + c(-0.8209236, -0.6270744, -1.0829403, -0.6574485, -0.5970569, -0.6488837), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp3, obs3, dat_dim = 'dataset')$sign), + rep(FALSE, 6), + ) + expect_equal( + mean(CRPSS(exp3, obs3, dat_dim = 'dataset', Fair = T)$crpss), + c(-0.5302703), + tolerance = 0.0001 + ) + expect_equal( + as.vector(CRPSS(exp3, obs3, dat_dim = 'dataset', Fair = T)$crpss), + c(-0.4681890, -0.3580685, -1.0116628, -0.3730576, -0.3965618, -0.5740819), + tolerance = 0.0001 + ) + # ref = ref3 + expect_equal( + as.vector(CRPSS(exp3, obs3, ref = ref3, dat_dim = 'dataset')$crpss), + c(-0.02315361, -0.05914715, -0.24638960, -0.09337738, 0.14668803, -0.01454008), + tolerance = 0.0001 + ) + + expect_equal( + as.vector(CRPSS(exp3, obs3, dat_dim = 'dataset')$crpss[1]), + as.vector(CRPSS(exp2, obs2)$crpss) + ) + +}) + +############################################## +test_that("5. Output checks: dat4", { + + expect_equal( + dim(CRPSS(exp4, obs4, ref4, dat_dim = 'dataset')$crpss), + c('nexp' = 3, 'nobs' = 2, 'lat' = 2) + ) + expect_equal( + as.vector(CRPSS(exp4, obs4, dat_dim = 'dataset', Fair = T)$crpss)[1:6], + c(-0.4681890, -0.3580685, -1.0116628, -0.3730576, -0.3965618, -0.5740819), + tolerance = 0.0001 + ) + # ref = ref3 + expect_equal( + as.vector(CRPSS(exp4, obs4, ref = ref4, dat_dim = 'dataset')$crpss)[1:6], + c(-0.02315361, 0.08576776, -0.17037744, -0.09337738, -0.05353853, -0.08772739), + tolerance = 0.0001 + ) + + +}) diff --git a/tests/testthat/test-Clim.R b/tests/testthat/test-Clim.R index 7751afb405c23c4e42cc5587eefa7f670182d14e..f5e288ec2c4b956a44c2494d8ae86f280288a2a1 100644 --- a/tests/testthat/test-Clim.R +++ b/tests/testthat/test-Clim.R @@ -134,7 +134,7 @@ test_that("1. Input checks", { expect_error( Clim(array(1:10, dim = c(dataset = 2, member = 5, sdate = 4, ftime = 3)), array(1:4, dim = c(dataset = 2, member = 2, sdate = 5, ftime = 3))), - "Parameter 'exp' and 'obs' must have the same dimensions expect 'dat_dim'." + "Parameter 'exp' and 'obs' must have the same dimensions except 'dat_dim'." ) }) diff --git a/tests/testthat/test-Consist_Trend.R b/tests/testthat/test-Consist_Trend.R index aa66f45761c6aa6b8bca1f02d7fbf8649882b038..91dacf7085035a0b16a6ab9689309a517c5ad5a6 100644 --- a/tests/testthat/test-Consist_Trend.R +++ b/tests/testthat/test-Consist_Trend.R @@ -62,7 +62,7 @@ test_that("1. Input checks", { Consist_Trend(array(1:10, dim = c(dataset = 2, member = 5, sdate = 4, ftime = 3)), array(1:4, dim = c(dataset = 2, member = 2, sdate = 5, ftime = 3))), paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension expect 'dat_dim'.") + "all dimension except 'dat_dim'.") ) # interval expect_error( diff --git a/tests/testthat/test-Corr.R b/tests/testthat/test-Corr.R index 9d5d4a3653ca55366919e8cf0bb87676972bf4b9..6e3c0162bb3c50cce3e28d0454c2da1672411ba2 100644 --- a/tests/testthat/test-Corr.R +++ b/tests/testthat/test-Corr.R @@ -40,6 +40,29 @@ context("s2dv::Corr tests") obs4 <- array(rnorm(10), dim = c(member = 1, dataset = 1, sdate = 5, lat = 2)) + # dat5: exp and obs have memb_dim and dataset = NULL + set.seed(1) + exp5 <- array(rnorm(90), dim = c(member = 3, sdate = 5, + lat = 2, lon = 3)) + + set.seed(2) + obs5 <- array(rnorm(30), dim = c(member = 1, sdate = 5, + lat = 2, lon = 3)) + + # dat6: exp and obs have memb_dim = NULL and dataset = NULL + set.seed(1) + exp6 <- array(rnorm(90), dim = c(sdate = 5, lat = 2, lon = 3)) + + set.seed(2) + obs6 <- array(rnorm(30), dim = c(sdate = 5, lat = 2, lon = 3)) + + # dat7: exp and obs have memb_dim = NULL and dataset = 1 + set.seed(1) + exp7 <- array(rnorm(90), dim = c(dataset = 1, sdate = 5, lat = 2, lon = 3)) + + set.seed(2) + obs7 <- array(rnorm(30), dim = c(dataset = 1, sdate = 5, lat = 2, lon = 3)) + ############################################## test_that("1. Input checks", { @@ -132,7 +155,7 @@ test_that("1. Input checks", { expect_error( Corr(exp = array(1:10, dim = c(sdate = 1, dataset = 5, a = 1)), obs = array(1:4, dim = c(a = 1, sdate = 2, dataset = 2))), - "Parameter 'exp' and 'obs' must have same length of all dimension expect 'dat_dim'." + "Parameter 'exp' and 'obs' must have same length of all dimension except 'dat_dim' and 'memb_dim'." ) expect_error( Corr(exp = array(1:10, dim = c(sdate = 2, dataset = 5, a = 1)), @@ -392,4 +415,70 @@ test_that("5. Output checks: dat4", { ) }) + +############################################## +test_that("6. Output checks: dat5", { + expect_equal( + dim(Corr(exp5, obs5, dat_dim = NULL, memb_dim = 'member')$corr), + c(exp_memb = 3, obs_memb = 1, lat = 2, lon = 3) + ) + expect_equal( + names(Corr(exp5, obs5, dat_dim = NULL, memb_dim = 'member')), + c("corr", "p.val", "conf.lower", "conf.upper") + ) + expect_equal( + names(Corr(exp5, obs5, dat_dim = NULL, memb_dim = 'member', pval = FALSE, conf = FALSE)), + c("corr") + ) + expect_equal( + mean(Corr(exp5, obs5, dat_dim = NULL, memb_dim = 'member', pval = FALSE, conf = FALSE)$corr), + 0.1880204, + tolerance = 0.0001 + ) +}) +############################################## +test_that("7. Output checks: dat6", { + expect_equal( + dim(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL)$corr), + c(lat = 2, lon = 3) + ) + expect_equal( + names(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL)), + c("corr", "p.val", "conf.lower", "conf.upper") + ) + expect_equal( + names(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL, pval = FALSE, conf = FALSE)), + c("corr") + ) + expect_equal( + mean(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL, pval = FALSE, conf = FALSE)$corr), + 0.1084488, + tolerance = 0.0001 + ) + # kendall + expect_equal( + as.vector(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL, method = 'kendall')$corr[2:4]), + c(0.0, 0.6, 0.2), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL, method = 'kendall')$p[2:4]), + c(0.5000000, 0.1423785, 0.3735300), + tolerance = 0.0001 + ) + expect_equal( + as.vector(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL, method = 'kendall')$conf.low[2:4]), + c(-0.8822664, -0.5997500, -0.8284490), + tolerance = 0.0001 + ) + +}) +############################################## +test_that("8. Output checks: dat6 and dat7", { + expect_equal( + mean(Corr(exp6, obs6, dat_dim = NULL, memb_dim = NULL, pval = FALSE, conf = FALSE)$corr), + mean(Corr(exp7, obs7, memb_dim = NULL, pval = FALSE, conf = FALSE)$corr), + tolerance = 0.0001 + ) +}) ############################################## diff --git a/tests/testthat/test-DiffCorr.R b/tests/testthat/test-DiffCorr.R index e0834e1d05196c34d6acdbe84b2359fbfee7b5ba..f47ac1bfec639e6d59f6fb69d2bdc8760ef17203 100644 --- a/tests/testthat/test-DiffCorr.R +++ b/tests/testthat/test-DiffCorr.R @@ -18,7 +18,9 @@ set.seed(2) ref2 <- array(rnorm(10), dim = c(sdate = 10)) set.seed(3) obs2 <- array(rnorm(10), dim = c(sdate = 10)) - +## generate time auto-correlation (Eno will change) +set.seed(3) +obs2_2 <- array(1:10 + rnorm(10), dim = c(sdate = 10)) ############################################## @@ -73,11 +75,10 @@ test_that("1. Input checks", { DiffCorr(exp1, obs1, ref1, method = 'asd', memb_dim = 'memb'), 'Parameter "method" must be "pearson" or "spearman".' ) - expect_warning( - DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', method = 'spearman'), - paste0("The test used in this function is built on Pearson method. ", - "To verify if Spearman method is reliable, you can run the ", - "Monte-Carlo simulations that are done in Siegert et al., 2017") + tmp <- capture_warnings(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', method = 'spearman')) + expect_match( + tmp, + "! Warning: The test used in this function is built on Pearson method. To verify if\n! Spearman method is reliable, you can run the Monte-Carlo simulations\n! that are done in Siegert et al., 2017", all = F ) # alpha expect_error( @@ -89,9 +90,14 @@ test_that("1. Input checks", { DiffCorr(exp2, obs2, ref2, handle.na = TRUE), 'Parameter "handle.na" must be "return.na", "only.complete.triplets" or "na.fail".' ) + # test.type + expect_error( + DiffCorr(exp2, obs2, ref2, test.type = "two.sided"), + "Parameter 'test.type' must be 'two-sided' or 'one-sided'." + ) # ncores expect_error( - DiffCorr(exp2, obs2, ref2, ncores = 1.5), + suppressWarnings(DiffCorr(exp2, obs2, ref2, ncores = 1.5)), 'Parameter "ncores" must be either NULL or a positive integer.' ) @@ -99,6 +105,8 @@ test_that("1. Input checks", { ############################################## test_that("2. Output checks: dat1", { +suppressWarnings({ + expect_equal( names(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb')), c("diff.corr", "p.val") @@ -117,7 +125,7 @@ c(0.27347087, 0.50556882, 0.08855968, 0.24199701, 0.22935182, 0.88336336), tolerance = 0.0001 ) expect_equal( -as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb')$p), +as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', test.type = "two-sided")$p), c(0.26166060, 0.15899774, 0.39264452, 0.27959883, 0.34736305, 0.07479832), tolerance = 0.0001 ) @@ -131,17 +139,25 @@ c(0.27347087, 0.50556882, 0.08855968, 0.24199701, 0.22935182, 0.88336336), tolerance = 0.0001 ) expect_equal( +as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', alpha = 0.05, test.type = "one-sided")$diff.corr), +as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', alpha = 0.05, test.type = "two-sided")$diff.corr) +) +expect_equal( as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', alpha = 0.05)$sign), rep(FALSE, 6) ) expect_equal( +as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', alpha = 0.05, test.type = "one-sided")$sign), +rep(FALSE, 6) +) +expect_equal( suppressWarnings(as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', method = "spearman")$diff.corr)), c(0.07272727, 0.54545455, 0.10909091, -0.01212121, -0.03636364, 1.01818182), tolerance = 0.0001 ) expect_equal( suppressWarnings(as.vector(DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', method = "spearman")$p)), -c(0.4358970, 0.1341575, 0.3448977, 0.5114262, 0.5264872, 0.0437861), +c(0.4358970, 0.1341575, 0.3448977, 0.4885738, 0.4735128, 0.0437861), tolerance = 0.0001 ) expect_equal( @@ -155,7 +171,6 @@ c(0.27841537, 0.15899774, 0.40096749, 0.27959883, 0.35889690, 0.07479832), tolerance = 0.0001 ) - #--------------------------- exp1[1] <- NA expect_equal( @@ -181,12 +196,15 @@ DiffCorr(exp1, obs1, ref1, memb_dim = 'memb', handle.na = 'only.complete.triplet "There is no complete set of forecasts and observations." ) - +}) # suppressWarnings }) ############################################## test_that("3. Output checks: dat2", { + +suppressWarnings({ + expect_equal( names(DiffCorr(exp2, obs2, ref2)), c("diff.corr", "p.val") @@ -200,14 +218,42 @@ dim(DiffCorr(exp2, obs2, ref2)$p), NULL ) expect_equal( -DiffCorr(exp2, obs2, ref2)$p, +DiffCorr(exp2, obs2, ref2, test.type = 'two-sided')$p, +0.3422608, +tolerance = 0.0001 +) +expect_equal( +DiffCorr(exp2, obs2, ref2, test.type = 'one-sided')$p, 0.6577392, tolerance = 0.0001 ) expect_equal( +DiffCorr(exp2, obs2, ref2, test.type = 'one-sided', alpha = 0.7)$sign, +FALSE +) +expect_equal( +DiffCorr(exp2, obs2, ref2, test.type = 'two-sided', alpha = 0.7)$sign, +TRUE +) +expect_equal( DiffCorr(exp2, obs2, ref2)$diff, -0.2434725, tolerance = 0.0001 ) +# obs2_2 +expect_equal( +DiffCorr(exp2, obs2_2, ref2, test.type = 'two-sided')$p, +0.4524316, +tolerance = 0.0001 +) +expect_equal( +DiffCorr(exp2, obs2_2, ref2, test.type = 'one-sided')$p, +0.5475684, +tolerance = 0.0001 +) + + + +}) # suppressWarnings }) diff --git a/tests/testthat/test-NAO.R b/tests/testthat/test-NAO.R index f3c6d21f5574be54e0b05513d887e927aa6f7a87..2da0d407ea986175a9a3d2c73605bd5aead29451 100644 --- a/tests/testthat/test-NAO.R +++ b/tests/testthat/test-NAO.R @@ -95,12 +95,12 @@ test_that("1. Input checks", { expect_error( NAO(exp1, array(rnorm(10), dim = c(member = 1, sdate = 3, ftime = 4, lat = 2, lon = 2))), paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'memb_dim'.") + "of all the dimensions except 'memb_dim'.") ) expect_error( NAO(exp1, array(rnorm(10), dim = c(dataset = 1, member = 1, sdate = 3, ftime = 4, lat = 1, lon = 2))), paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'memb_dim'.") + "of all the dimensions except 'memb_dim'.") ) # ftime_avg expect_error( diff --git a/tests/testthat/test-REOF.R b/tests/testthat/test-REOF.R index e118e1eac8284161c18fabdeee51c4ccf827101a..39747e2fafd0cf1efa758eb3ef5cb2fd10ee3267 100644 --- a/tests/testthat/test-REOF.R +++ b/tests/testthat/test-REOF.R @@ -92,10 +92,9 @@ test_that("1. Input checks", { ############################################## test_that("2. dat1", { - expect_warning( - REOF(dat1, lon = lon1, lat = lat1), - "Parameter 'ntrunc' is changed to 10, the minimum among the length of time_dim, the production of the length of space_dim, and ntrunc.", - fixed = TRUE + expect_equal( + suppressWarnings(REOF(dat1, lon = lon1, lat = lat1)), + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 10) ) expect_equal( names(REOF(dat1, lon = lon1, lat = lat1, ntrunc = 10)), diff --git a/tests/testthat/test-RMS.R b/tests/testthat/test-RMS.R index 6e18bee447b4397a471350b89a12cf3c1b663f67..f69cfd8a1de8e4db627dcfb5e9d0e0ca2a845080 100644 --- a/tests/testthat/test-RMS.R +++ b/tests/testthat/test-RMS.R @@ -17,6 +17,13 @@ context("s2dv::RMS tests") set.seed(6) obs2 <- rnorm(10) + # dat3 + set.seed(1) + exp3 <- array(rnorm(120), dim = c(sdate = 5, ftime = 2, lon = 1, lat = 4)) + + set.seed(2) + obs3 <- array(rnorm(80), dim = c(sdate = 5, ftime = 2, lon = 1, lat = 4)) + ############################################## test_that("1. Input checks", { @@ -89,7 +96,7 @@ test_that("1. Input checks", { expect_error( RMS(exp = array(1:10, dim = c(sdate = 1, dataset = 5, a = 1)), obs = array(1:4, dim = c(a = 1, sdate = 2, dataset = 2))), - "Parameter 'exp' and 'obs' must have same length of all dimension expect 'dat_dim'." + "Parameter 'exp' and 'obs' must have same length of all dimension except 'dat_dim'." ) expect_error( RMS(exp = array(1:5, dim = c(sdate = 1, dataset = 5, a = 1)), @@ -186,3 +193,18 @@ test_that("3. Output checks: dat2", { }) ############################################## +test_that("4. Output checks: dat3", { + + expect_equal( + dim(RMS(exp3, obs3, dat_dim = NULL)$rms), + c(ftime = 2, lon = 1, lat = 4) + ) + + expect_equal( + as.vector(RMS(exp3, obs3, dat_dim = NULL)$rms), + c(1.6458118, 0.8860392, 0.8261295, 1.1681939, 2.1693538, 1.3064454, 0.5384229, 1.1215333), + tolerance = 0.00001 + ) +}) + +############################################## \ No newline at end of file diff --git a/tests/testthat/test-RMSSS.R b/tests/testthat/test-RMSSS.R index 7d2a16da9da52c492dad263985f71c042783927b..d592130fc7c8f1ea6478da94a4e5d8677586fdb0 100644 --- a/tests/testthat/test-RMSSS.R +++ b/tests/testthat/test-RMSSS.R @@ -25,6 +25,12 @@ context("s2dv::RMSSS tests") set.seed(6) obs3 <- rnorm(10) + # case 4 + set.seed(7) + exp4 <- array(rnorm(120), dim = c(sdate = 10, dat = 1, lon = 3, lat = 2)) + set.seed(8) + obs4 <- array(rnorm(60), dim = c(dat = 1, sdate = 10, lat = 2, lon = 3)) + ############################################## test_that("1. Input checks", { @@ -64,7 +70,8 @@ test_that("1. Input checks", { ) expect_error( RMSSS(exp0, obs0, dat_dim = 'memb'), - "Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension." + paste0("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.", + " Set it as NULL if there is no dataset dimension.") ) expect_error( RMSSS(exp0, obs0, pval = c(T, T)), @@ -77,7 +84,7 @@ test_that("1. Input checks", { expect_error( RMSSS(exp = array(1:10, dim = c(sdate = 1, dataset = 5, a = 1)), obs = array(1:4, dim = c(a = 1, sdate = 2, dataset = 2))), - "Parameter 'exp' and 'obs' must have same length of all dimension expect 'dat_dim'." + "Parameter 'exp' and 'obs' must have same length of all dimension except 'dat_dim'." ) expect_error( RMSSS(exp = array(1:10, dim = c(sdate = 1, dataset = 5, a = 1)), @@ -157,5 +164,24 @@ test_that("4. Output checks: case 3", { tolerance = 0.00001 ) +}) + +############################################## +test_that("5. Output checks: case 4", { + + expect_equal( + dim(RMSSS(exp4, obs4, dat_dim = NULL)$rmsss), + c(dat = 1, lon = 3, lat = 2) + ) + expect_equal( + mean(RMSSS(exp4, obs4, dat_dim = NULL)$rmsss), + -0.3114424, + tolerance = 0.00001 + ) + expect_equal( + range(RMSSS(exp4, obs4, dat_dim = NULL)$p.val), + c(0.3560534, 0.9192801), + tolerance = 0.00001 + ) }) diff --git a/tests/testthat/test-RPS.R b/tests/testthat/test-RPS.R index 04df1bb397b6906c10a16a5be1f92c1858299103..9363a419f566712ce7fbd9d4a1c6f511b1c028eb 100644 --- a/tests/testthat/test-RPS.R +++ b/tests/testthat/test-RPS.R @@ -9,6 +9,7 @@ set.seed(2) obs1 <- array(rnorm(20), dim = c(sdate = 10, lat = 2)) set.seed(3) weights1 <- array(abs(rnorm(30)), dim = c(member = 3, sdate = 10)) + # dat2 set.seed(1) exp2 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) @@ -21,7 +22,13 @@ exp2_1 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) set.seed(2) obs2_1 <- array(rnorm(10), dim = c(member = 1, sdate = 10)) - +# dat3 +set.seed(1) +exp3 <- array(rnorm(40), dim = c(member = 2, sdate = 10, dataset = 2)) +set.seed(2) +obs3 <- array(rnorm(30), dim = c(member = 1, sdate = 10, dataset = 3)) +set.seed(3) +weights3 <- array(abs(rnorm(30)), dim = c(member = 2, sdate = 10, dataset = 2)) ############################################## test_that("1. Input checks", { @@ -56,7 +63,7 @@ test_that("1. Input checks", { # exp, ref, and obs (2) expect_error( RPS(exp1, array(1:9, dim = c(sdate = 9))), - "Parameter 'exp' and 'obs' must have same length of all dimensions expect 'memb_dim'." + "Parameter 'exp' and 'obs' must have same length of all dimensions except 'memb_dim' and 'dat_dim'." ) # prob_thresholds expect_error( @@ -80,15 +87,19 @@ test_that("1. Input checks", { # weights expect_error( RPS(exp1, obs1, weights = c(0, 1)), - 'Parameter "weights" must be a two-dimensional numeric array.' + "Parameter 'weights' must be a named numeric array." ) expect_error( RPS(exp1, obs1, weights = array(1, dim = c(member = 3, time = 10))), - "Parameter 'weights' must have two dimensions with the names of memb_dim and time_dim." + "Parameter 'weights' must have two dimensions with the names of 'memb_dim' and 'time_dim'." ) expect_error( RPS(exp1, obs1, weights = array(1, dim = c(member = 3, sdate = 1))), - "Parameter 'weights' must have the same dimension lengths as memb_dim and time_dim in 'exp'." + "Parameter 'weights' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'exp'." + ) + expect_error( + RPS(exp3, obs3, weights = array(1, dim = c(member = 3, time = 10, dataset = 3)), dat_dim = 'dataset'), + "Parameter 'weights' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'." ) # ncores expect_error( @@ -101,57 +112,87 @@ test_that("1. Input checks", { ############################################## test_that("2. Output checks: dat1", { -expect_equal( -dim(RPS(exp1, obs1)), -c(lat = 2) -) -expect_equal( -as.vector(RPS(exp1, obs1)), -c(0.3555556, 0.4444444), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPS(exp1, obs1, Fair = T)), -c(0.2000000, 0.2666667), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPS(exp1, obs1, indices_for_clim = 3:5)), -c(0.5000000, 0.4666667), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPS(exp1, obs1, prob_thresholds = seq(0.1, 0.9, 0.1))), -c(1.600000, 1.888889), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPS(exp1, obs1, weights = weights1)), -c(0.3692964, 0.5346627), -tolerance = 0.0001 -) + expect_equal( + dim(RPS(exp1, obs1)), + c(lat = 2) + ) + expect_equal( + as.vector(RPS(exp1, obs1)), + c(0.3555556, 0.4444444), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPS(exp1, obs1, Fair = T)), + c(0.2000000, 0.2666667), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPS(exp1, obs1, indices_for_clim = 3:5)), + c(0.5000000, 0.4666667), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPS(exp1, obs1, prob_thresholds = seq(0.1, 0.9, 0.1))), + c(1.600000, 1.888889), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPS(exp1, obs1, weights = weights1)), + c(0.3692964, 0.5346627), + tolerance = 0.0001 + ) }) ############################################## test_that("3. Output checks: dat2", { -expect_equal( -dim(RPS(exp2, obs2)), -NULL -) -expect_equal( -RPS(exp2, obs2), -0.75, -tolerance = 0.0001 -) -expect_equal( -RPS(exp2, obs2, indices_for_clim = 2:5, prob_thresholds = seq(0.1, 0.9, 0.1)), -2.75, -tolerance = 0.0001 -) -expect_equal( -RPS(exp2, obs2), -RPS(exp2_1, obs2_1) -) + expect_equal( + dim(RPS(exp2, obs2)), + NULL + ) + expect_equal( + RPS(exp2, obs2), + 0.75, + tolerance = 0.0001 + ) + expect_equal( + RPS(exp2, obs2, indices_for_clim = 2:5, prob_thresholds = seq(0.1, 0.9, 0.1)), + 2.75, + tolerance = 0.0001 + ) + expect_equal( + RPS(exp2, obs2), + RPS(exp2_1, obs2_1) + ) +}) + +############################################## +test_that("3. Output checks: dat3", { + + expect_equal( + dim(RPS(exp3, obs3, dat_dim = 'dataset')), + c(nexp = 2, nobs = 3) + ) + expect_equal( + as.vector(RPS(exp3, obs3, dat_dim = 'dataset')), + c(0.75, 0.65, 0.75, 0.85, 0.75, 0.55), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPS(exp3, obs3, dat_dim = 'dataset', indices_for_clim = 2:5, prob_thresholds = seq(0.1, 0.9, 0.1))), + c(2.75, 2.45, 2.55, 2.55, 2.65, 2.15), + tolerance = 0.0001 + ) + # weights + expect_equal( + dim(RPS(exp3, obs3, weights = weights3, dat_dim = 'dataset')), + c(nexp = 2, nobs = 3) + ) + expect_equal( + as.vector(RPS(exp3, obs3, weights = weights3, dat_dim = 'dataset')), + c(0.7365024, 0.8316852, 0.6778686, 1.0256509, 0.8406320, 0.6385640), + tolerance = 0.0001 + ) + }) diff --git a/tests/testthat/test-RPSS.R b/tests/testthat/test-RPSS.R index c63add02246ef4980a8c388bed7b54a239e62d24..79769057a6f69fe1f76a0d2f6338ea2b9e268318 100644 --- a/tests/testthat/test-RPSS.R +++ b/tests/testthat/test-RPSS.R @@ -11,6 +11,7 @@ set.seed(3) ref1 <- array(rnorm(40), dim = c(member = 2, sdate = 10, lat = 2)) set.seed(4) weights1 <- array(abs(rnorm(30)), dim = c(member = 3, sdate = 10)) + # dat2 set.seed(1) exp2 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) @@ -20,91 +21,126 @@ set.seed(2) obs2_1 <- array(rnorm(10), dim = c(member = 1, sdate = 10)) set.seed(3) ref2 <- array(rnorm(20), dim = c(member = 2, sdate = 10)) +set.seed(4) +weights2 <- array(abs(rnorm(60)), dim = c(member = 2, sdate = 10)) + +# dat3 +set.seed(1) +exp3 <- array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3)) +set.seed(2) +obs3 <- array(rnorm(20), dim = c(member = 1, sdate = 10, dataset = 2)) +set.seed(3) +ref3 <- array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3)) +set.seed(4) +weights3 <- array(abs(rnorm(60)), dim = c(member = 2, sdate = 10, dataset = 3)) +# dat4 +set.seed(1) +exp4 <- array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 3, lat = 2)) +set.seed(2) +obs4 <- array(rnorm(20), dim = c(member = 1, sdate = 10, dataset = 2, lat = 2)) +set.seed(3) +ref4 <- array(rnorm(40), dim = c(member = 2, sdate = 10, lat = 2)) +set.seed(4) +weights_exp4 <- array(abs(rnorm(60)), dim = c(member = 2, sdate = 10, dataset = 3)) +set.seed(5) +weights_ref4 <- array(abs(rnorm(20)), dim = c(member = 2, sdate = 10)) ############################################## test_that("1. Input checks", { # exp and obs (1) expect_error( - RPSS(c()), - 'Parameter "exp" must be a numeric array.' + RPSS(c()), + "Parameter 'exp' must be a numeric array." ) expect_error( - RPSS(exp1, c()), - 'Parameter "obs" must be a numeric array.' + RPSS(exp1, c()), + "Parameter 'obs' must be a numeric array." ) # time_dim expect_error( - RPSS(exp1, obs1, time_dim = 1), - 'Parameter "time_dim" must be a character string.' + RPSS(exp1, obs1, time_dim = 1), + "Parameter 'time_dim' must be a character string." ) expect_error( - RPSS(exp1, obs1, time_dim = 'time'), - "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + RPSS(exp1, obs1, time_dim = 'time'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." ) expect_error( - RPSS(exp2, obs2, array(rnorm(20), dim = c(member = 2, time = 10))), - "Parameter 'time_dim' is not found in 'ref' dimension." + RPSS(exp2, obs2, array(rnorm(20), dim = c(member = 2, time = 10))), + "Parameter 'time_dim' is not found in 'ref' dimension." ) # memb_dim expect_error( - RPSS(exp1, obs1, memb_dim = TRUE), - "Parameter 'memb_dim' must be a character string." + RPSS(exp1, obs1, memb_dim = TRUE), + "Parameter 'memb_dim' must be a character string." ) expect_error( - RPSS(exp1, obs1, memb_dim = 'memb'), - "Parameter 'memb_dim' is not found in 'exp' dimension." + RPSS(exp1, obs1, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' dimension." ) expect_error( - RPSS(exp2, obs2, array(rnorm(20), dim = c(memb = 2, sdate = 10))), - "Parameter 'memb_dim' is not found in 'ref' dimension." + RPSS(exp2, obs2, array(rnorm(20), dim = c(memb = 2, sdate = 10))), + "Parameter 'memb_dim' is not found in 'ref' dimension." ) # exp, ref, and obs (2) expect_error( - RPSS(exp1, array(1:9, dim = c(sdate = 9))), - "Parameter 'exp' and 'obs' must have same length of all dimensions expect 'memb_dim'." + RPSS(exp1, array(1:9, dim = c(sdate = 9))), + "Parameter 'exp' and 'obs' must have same length of all dimensions except 'memb_dim' and 'dat_dim'." + ) + expect_error( + RPSS(exp3, obs3, array(rnorm(60), dim = c(member = 2, sdate = 10, dataset = 4)), dat_dim = 'dataset'), + "If parameter 'ref' has dataset dimension, it must be equal to dataset dimension of 'exp'." ) expect_error( - RPSS(exp1, obs1, ref2), - "Parameter 'exp' and 'obs' must have same length of all dimensions expect 'memb_dim'." + RPSS(exp1, obs1, ref2), + "Parameter 'exp' and 'ref' must have the same length of all dimensions except 'memb_dim' and 'dat_dim' if there is only one reference dataset." ) # prob_thresholds expect_error( - RPSS(exp1, obs1, ref1, prob_thresholds = 1), - "Parameter 'prob_thresholds' must be a numeric vector between 0 and 1." + RPSS(exp1, obs1, ref1, prob_thresholds = 1), + "Parameter 'prob_thresholds' must be a numeric vector between 0 and 1." ) # indices_for_clim expect_error( - RPSS(exp1, obs1, ref1, indices_for_clim = array(1:6, dim = c(2, 3))), - "Parameter 'indices_for_clim' must be NULL or a numeric vector." + RPSS(exp1, obs1, ref1, indices_for_clim = array(1:6, dim = c(2, 3))), + "Parameter 'indices_for_clim' must be NULL or a numeric vector." ) expect_error( - RPSS(exp1, obs1, indices_for_clim = 3:11), - "Parameter 'indices_for_clim' should be the indices of 'time_dim'." + RPSS(exp1, obs1, indices_for_clim = 3:11), + "Parameter 'indices_for_clim' should be the indices of 'time_dim'." ) # Fair expect_error( - RPSS(exp1, obs1, Fair = 1), - "Parameter 'Fair' must be either TRUE or FALSE." + RPSS(exp1, obs1, Fair = 1), + "Parameter 'Fair' must be either TRUE or FALSE." + ) + # weights_exp and weights_ref + expect_error( + RPSS(exp1, obs1, weights_exp = c(0, 1)), + "Parameter 'weights_exp' must be a named numeric array." ) - # weights expect_error( - RPS(exp1, obs1, weights = c(0, 1)), - 'Parameter "weights" must be a two-dimensional numeric array.' + RPSS(exp1, obs1, weights_exp = array(1, dim = c(member = 3, time = 10))), + "Parameter 'weights_exp' must have two dimensions with the names of 'memb_dim' and 'time_dim'." ) expect_error( - RPS(exp1, obs1, weights = array(1, dim = c(member = 3, time = 10))), - "Parameter 'weights' must have two dimensions with the names of memb_dim and time_dim." + RPSS(exp1, obs1, ref1, weights_ref = array(1, dim = c(member = 3, sdate = 1))), + "Parameter 'weights_ref' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'ref'." ) expect_error( - RPS(exp1, obs1, weights = array(1, dim = c(member = 3, sdate = 1))), - "Parameter 'weights' must have the same dimension lengths as memb_dim and time_dim in 'exp'." + RPSS(exp3, obs3, dat_dim = 'dataset', weights_exp = weights1), + "Parameter 'weights_exp' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'." + ) + expect_error( + RPSS(exp4, obs4, ref4, dat_dim = 'dataset', weights_ref = weights1), + "Parameter 'weights_ref' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'ref'." ) # ncores expect_error( - RPSS(exp2, obs2, ncores = 1.5), - "Parameter 'ncores' must be either NULL or a positive integer." + RPSS(exp2, obs2, ncores = 1.5), + "Parameter 'ncores' must be either NULL or a positive integer." ) }) @@ -112,184 +148,257 @@ test_that("1. Input checks", { ############################################## test_that("2. Output checks: dat1", { -expect_equal( -names(RPSS(exp1, obs1)), -c("rpss", "sign") -) -expect_equal( -names(RPSS(exp1, obs1, ref1)), -c("rpss", "sign") -) -expect_equal( -dim(RPSS(exp1, obs1)$rpss), -c(lat = 2) -) -expect_equal( -dim(RPSS(exp1, obs1)$sign), -c(lat = 2) -) -expect_equal( -dim(RPSS(exp1, obs1, ref1)$rpss), -c(lat = 2) -) -expect_equal( -dim(RPSS(exp1, obs1, ref1)$sign), -c(lat = 2) -) -# ref = NULL -expect_equal( -as.vector(RPSS(exp1, obs1)$rpss), -c(0.15789474, -0.05263158), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1)$sign), -c(FALSE, FALSE), -) -expect_equal( -as.vector(RPSS(exp1, obs1, Fair = T)$rpss), -c(0.5263158, 0.3684211), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, indices_for_clim = 3:5)$rpss), -c(-0.4062500, -0.1052632), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), -c(0.03030303, -0.14478114), -tolerance = 0.0001 -) -# ref = ref -expect_equal( -as.vector(RPSS(exp1, obs1, ref1)$rpss), -c(0.5259259, 0.4771242), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1, weights = weights1)$rpss), -c(0.6596424, 0.4063579), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1)$sign), -c(FALSE, FALSE) -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1, Fair = T)$rpss), -c(0.6000000, 0.6190476), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1, indices_for_clim = 3:5)$rpss), -c(0.2857143, 0.4166667), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1, indices_for_clim = 3:5)$sign), -c(FALSE, FALSE) -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), -c(0.4754098, 0.3703704), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp1, obs1, ref1, prob_thresholds = seq(0.1, 0.9, 0.1))$sign), -c(T, F) -) + expect_equal( + names(RPSS(exp1, obs1)), + c("rpss", "sign") + ) + expect_equal( + names(RPSS(exp1, obs1, ref1)), + c("rpss", "sign") + ) + expect_equal( + dim(RPSS(exp1, obs1)$rpss), + c(lat = 2) + ) + expect_equal( + dim(RPSS(exp1, obs1)$sign), + c(lat = 2) + ) + expect_equal( + dim(RPSS(exp1, obs1, ref1)$rpss), + c(lat = 2) + ) + expect_equal( + dim(RPSS(exp1, obs1, ref1)$sign), + c(lat = 2) + ) + # ref = NULL + expect_equal( + as.vector(RPSS(exp1, obs1)$rpss), + c(0.15789474, -0.05263158), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1)$sign), + c(FALSE, FALSE), + ) + expect_equal( + as.vector(RPSS(exp1, obs1, Fair = T)$rpss), + c(0.5263158, 0.3684211), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, indices_for_clim = 3:5)$rpss), + c(-0.4062500, -0.1052632), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), + c(0.03030303, -0.14478114), + tolerance = 0.0001 + ) + # ref = ref + expect_equal( + as.vector(RPSS(exp1, obs1, ref1)$rpss), + c(0.5259259, 0.4771242), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1, weights_exp = weights1, weights_ref = weights1)$rpss), + c(0.6596424, 0.4063579), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1)$sign), + c(FALSE, FALSE) + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1, Fair = T)$rpss), + c(0.6000000, 0.6190476), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1, indices_for_clim = 3:5)$rpss), + c(0.2857143, 0.4166667), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1, indices_for_clim = 3:5)$sign), + c(FALSE, FALSE) + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), + c(0.4754098, 0.3703704), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp1, obs1, ref1, prob_thresholds = seq(0.1, 0.9, 0.1))$sign), + c(T, F) + ) }) ############################################## test_that("3. Output checks: dat2", { -expect_equal( -names(RPSS(exp2, obs2)), -c("rpss", "sign") -) -expect_equal( -names(RPSS(exp2, obs2, ref2)), -c("rpss", "sign") -) -expect_equal( -dim(RPSS(exp2, obs2)$rpss), -NULL -) -expect_equal( -dim(RPSS(exp2, obs2)$sign), -NULL -) -expect_equal( -dim(RPSS(exp2, obs2, ref2)$rpss), -NULL -) -expect_equal( -dim(RPSS(exp2, obs2, ref2)$sign), -NULL -) -# ref = NULL -expect_equal( -as.vector(RPSS(exp2, obs2)$rpss), -c(-0.7763158), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2)$sign), -FALSE, -) -expect_equal( -as.vector(RPSS(exp2, obs2, Fair = T)$rpss), -c(-0.1842105), -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2, indices_for_clim = 3:5)$rpss), --0.8984375, -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), -c(-0.7272727), -tolerance = 0.0001 -) -# ref = ref -expect_equal( -as.vector(RPSS(exp2, obs2, ref2)$rpss), -0, -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2, ref2)$sign), -FALSE -) -expect_equal( -as.vector(RPSS(exp2, obs2, ref2, Fair = T)$rpss), -0, -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2, ref2, indices_for_clim = 3:5)$rpss), -0.03571429, -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2, ref2, indices_for_clim = 3:5)$sign), -FALSE -) -expect_equal( -as.vector(RPSS(exp2, obs2, ref2, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), -0.06557377, -tolerance = 0.0001 -) -expect_equal( -as.vector(RPSS(exp2, obs2, ref2, prob_thresholds = seq(0.1, 0.9, 0.1))$sign), -FALSE -) -expect_equal( -RPSS(exp2, obs2), -RPSS(exp2, obs2_1) -) + expect_equal( + names(RPSS(exp2, obs2)), + c("rpss", "sign") + ) + expect_equal( + names(RPSS(exp2, obs2, ref2)), + c("rpss", "sign") + ) + expect_equal( + dim(RPSS(exp2, obs2)$rpss), + NULL + ) + expect_equal( + dim(RPSS(exp2, obs2)$sign), + NULL + ) + expect_equal( + dim(RPSS(exp2, obs2, ref2)$rpss), + NULL + ) + expect_equal( + dim(RPSS(exp2, obs2, ref2)$sign), + NULL + ) + # ref = NULL + expect_equal( + as.vector(RPSS(exp2, obs2)$rpss), + c(-0.7763158), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2)$sign), + FALSE, + ) + expect_equal( + as.vector(RPSS(exp2, obs2, Fair = T)$rpss), + c(-0.1842105), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2, indices_for_clim = 3:5)$rpss), + -0.8984375, + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), + c(-0.7272727), + tolerance = 0.0001 + ) + # ref = ref + expect_equal( + as.vector(RPSS(exp2, obs2, ref2)$rpss), + 0, + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2, ref2)$sign), + FALSE + ) + expect_equal( + as.vector(RPSS(exp2, obs2, ref2, Fair = T)$rpss), + 0, + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2, ref2, indices_for_clim = 3:5)$rpss), + 0.03571429, + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2, ref2, indices_for_clim = 3:5)$sign), + FALSE + ) + expect_equal( + as.vector(RPSS(exp2, obs2, ref2, prob_thresholds = seq(0.1, 0.9, 0.1))$rpss), + 0.06557377, + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp2, obs2, ref2, prob_thresholds = seq(0.1, 0.9, 0.1))$sign), + FALSE + ) + expect_equal( + RPSS(exp2, obs2), + RPSS(exp2, obs2_1) + ) + +}) +############################################## +test_that("4. Output checks: dat3", { + + expect_equal( + dim(RPSS(exp3, obs3, dat_dim = 'dataset')$rpss), + c('nexp' = 3, 'nobs' = 2) + ) + expect_equal( + mean(RPSS(exp3, obs3, dat_dim = 'dataset')$rpss), + c(-0.8157895), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp3, obs3, dat_dim = 'dataset')$sign)[1:3], + c(FALSE, FALSE, FALSE), + ) + expect_equal( + mean(RPSS(exp3, obs3, dat_dim = 'dataset', weights_exp = weights3, Fair = T)$rpss), + c(-0.7015067), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp3, obs3, dat_dim = 'dataset', weights_exp = weights3, Fair = T)$rpss), + c(-0.7962495, -0.4511230, -0.8497759, -0.5538201, -1.1312592, -0.4268125), + tolerance = 0.0001 + ) + expect_equal( + mean(RPSS(exp3, obs3, ref3, dat_dim = 'dataset', weights_ref = weights3, Fair = T)$rpss), + c(0.06145283), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp3, obs3, ref3, dat_dim = 'dataset', weights_ref = weights3, Fair = T)$rpss), + c(0.32938699, 0.29749323, -0.66130649, 0.09722641, 0.10193502, 0.20398179), + tolerance = 0.0001 + ) + expect_equal( + RPSS(exp3, obs3, ref3, dat_dim = 'dataset', weights_ref = weights3, Fair = T)$rpss[1, ], + RPSS(exp3, obs3, ref2, dat_dim = 'dataset', weights_ref = weights2, Fair = T)$rpss[1, ] + ) + expect_equal( + RPSS(exp3, obs3, dat_dim = 'dataset')$rpss[1], + RPSS(exp2, obs2)$rpss + ) +}) + +############################################## +test_that("5. Output checks: dat4", { + + expect_equal( + dim(RPSS(exp4, obs4, ref4, dat_dim = 'dataset')$rpss), + c('nexp' = 3, 'nobs' = 2, 'lat' = 2) + ) + expect_equal( + mean(RPSS(exp4, obs4, ref4, dat_dim = 'dataset', weights_exp = weights_exp4, weights_ref = weights_ref4)$rpss), + c(-0.03715614), + tolerance = 0.0001 + ) + expect_equal( + as.vector(RPSS(exp4, obs4, ref4, dat_dim = 'dataset', weights_exp = weights_exp4, weights_ref = weights_ref4)$rpss[, , 2]), + c(-0.22913563, 0.04784362, -0.15832178, 0.13330236, -0.05285335, 0.26871923), + tolerance = 0.0001 + ) + expect_equal( + RPSS(exp4, obs4, dat_dim = 'dataset', weights_exp = weights_exp4)$rpss[1], + RPSS(exp2, obs2, weights_exp = weights2)$rpss + ) + expect_equal( + RPSS(exp4, obs4, dat_dim = 'dataset', weights_exp = weights_exp4)$rpss[, , 1], + RPSS(exp3, obs3, weights_exp = weights3, dat_dim = 'dataset')$rpss + ) }) diff --git a/tests/testthat/test-RatioSDRMS.R b/tests/testthat/test-RatioSDRMS.R index 4b93fafa213dcac0e831b7ac59d7646064f8f856..5dbc171337d4bec4fe9db6e2c491ec527511efc3 100644 --- a/tests/testthat/test-RatioSDRMS.R +++ b/tests/testthat/test-RatioSDRMS.R @@ -77,7 +77,7 @@ test_that("1. Input checks", { expect_error( RatioSDRMS(exp = exp3, obs = array(1:2, dim = c(member = 1, sdate = 2)), dat_dim = NULL), - "Parameter 'exp' and 'obs' must have same length of all the dimensions expect 'dat_dim' and 'memb_dim'." + "Parameter 'exp' and 'obs' must have same length of all the dimensions except 'dat_dim' and 'memb_dim'." ) }) diff --git a/tests/testthat/test-ResidualCorr.R b/tests/testthat/test-ResidualCorr.R index c15276c93368322eec48e8b33657474fb8f4a1c4..be71b4748295f70ddc43f7c3d3bccdf1d1f60100 100644 --- a/tests/testthat/test-ResidualCorr.R +++ b/tests/testthat/test-ResidualCorr.R @@ -66,7 +66,7 @@ test_that("1. Input checks", { # exp, ref, and obs (2) expect_error( ResidualCorr(exp1, obs1, array(1:10, dim = c(sdate = 10, memb = 1)), memb_dim = 'memb'), - "Parameter 'exp', 'obs', and 'ref' must have same length of all dimensions expect 'memb_dim'." + "Parameter 'exp', 'obs', and 'ref' must have same length of all dimensions except 'memb_dim'." ) # method expect_error( diff --git a/tests/testthat/test-UltimateBrier.R b/tests/testthat/test-UltimateBrier.R index 654aad020d5d7df65981316ab1918b3cece94c51..09412f00cf1ce52265328f9da89f2f404081877a 100644 --- a/tests/testthat/test-UltimateBrier.R +++ b/tests/testthat/test-UltimateBrier.R @@ -7,7 +7,11 @@ exp1 <- array(rnorm(30), dim = c(dataset = 1, member = 3, sdate = 5, ftime = 2)) set.seed(2) obs1 <- array(round(rnorm(10)), dim = c(dataset = 1, sdate = 5, ftime = 2)) - +# dat2 +set.seed(1) +exp2 <- array(rnorm(30), dim = c(member = 3, sdate = 5, ftime = 2)) +set.seed(2) +obs2 <- array(round(rnorm(10)), dim = c(sdate = 5, ftime = 2)) ############################################## test_that("1. Input checks", { # exp and obs @@ -26,7 +30,7 @@ test_that("1. Input checks", { # dat_dim expect_error( UltimateBrier(exp1, obs1, dat_dim = 2), - "Parameter 'dat_dim' must be a character string." + "Parameter 'dat_dim' must be a character string or NULL." ) expect_error( UltimateBrier(exp1, obs1, dat_dim = 'dat'), @@ -58,12 +62,12 @@ test_that("1. Input checks", { expect_error( UltimateBrier(exp1, array(1:10, dim = c(dataset = 1, sdate = 6, ftime = 2))), paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.") + "of all the dimensions except 'dat_dim' and 'memb_dim'.") ) expect_error( UltimateBrier(exp1, array(1:10, dim = c(dataset = 1, sdate = 5, time = 2))), paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions expect 'dat_dim' and 'memb_dim'.") + "of all the dimensions except 'dat_dim' and 'memb_dim'.") ) # quantile expect_error( @@ -105,136 +109,269 @@ test_that("1. Input checks", { ############################################## test_that("2. Output checks: dat1", { -# 'BS' -expect_equal( -is.list(UltimateBrier(exp1, obs1)), -TRUE -) -expect_equal( -names(UltimateBrier(exp1, obs1)), -c('bs', 'rel', 'res', 'unc') -) -expect_equal( -is.list(UltimateBrier(exp1, obs1, decomposition = FALSE)), -FALSE -) -expect_equal( -dim(UltimateBrier(exp1, obs1, decomposition = FALSE)), -c(nexp = 1, nobs = 1, bin = 3, ftime = 2) -) -expect_equal( -dim(UltimateBrier(exp1, obs1, decomposition = FALSE, thr = c(0.25, 0.5, 0.75))), -c(nexp = 1, nobs = 1, bin = 4, ftime = 2) -) -expect_equal( -UltimateBrier(exp1, obs1)$bs, -UltimateBrier(exp1, obs1, decomposition = FALSE) -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1)$bs), -c(0.42222222, 0.44444444, 0.02222222, 0.48888889, 0.37777778, 0.02222222), -tolerance = 0.0001 -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1)$rel), -c(0.22222222, 0.31111111, 0.02222222, 0.28888889, 0.24444444, 0.02222222), -tolerance = 0.0001 -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1)$res), -c(0.0400000, 0.1066667, 0.0000000, 0.0400000, 0.1066667, 0.0000000), -tolerance = 0.0001 -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1)$unc), -c(0.24, 0.24, 0.00, 0.24, 0.24, 0.00), -tolerance = 0.0001 -) - -# 'BSS' -expect_equal( -dim(UltimateBrier(exp1, obs1, type = 'BSS')), -c(nexp = 1, nobs = 1, bin = 3, ftime = 2) -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'BSS')), -c(-0.7592593, -0.8518519, -Inf, -1.0370370, -0.5740741, -Inf), -tolerance = 0.0001 -) - -# 'FairStartDatesBS' -expect_equal( -is.list(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')), -TRUE -) -expect_equal( -names(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')), -c('bs', 'rel', 'res', 'unc') -) -expect_equal( -is.list(UltimateBrier(exp1, obs1, decomposition = FALSE, type = 'FairStartDatesBS')), -FALSE -) -expect_equal( -dim(UltimateBrier(exp1, obs1, decomposition = FALSE, type = 'FairStartDatesBS')), -c(nexp = 1, nobs = 1, bin = 3, ftime = 2) -) -expect_equal( -UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$bs, -UltimateBrier(exp1, obs1, decomposition = FALSE, type = 'FairStartDatesBS') -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$bs), -c(0.42222222, 0.44444444, 0.02222222, 0.48888889, 0.37777778, 0.02222222), -tolerance = 0.0001 -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$rel), -c(0.22222222, 0.31111111, 0.02222222, 0.28888889, 0.24444444, 0.02222222), -tolerance = 0.0001 -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$res), -c(0.0400000, 0.1066667, 0.0000000, 0.0400000, 0.1066667, 0.0000000), -tolerance = 0.0001 -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$unc), -c(0.24, 0.24, 0.00, 0.24, 0.24, 0.00), -tolerance = 0.0001 -) - -# 'FairStartDatesBSS' -expect_equal( -dim(UltimateBrier(exp1, obs1, type = 'FairStartDatesBSS')), -c(nexp = 1, nobs = 1, bin = 3, ftime = 2) -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBSS')), -c(-0.7592593, -0.8518519, -Inf, -1.0370370, -0.5740741, -Inf), -tolerance = 0.0001 -) -# 'FairEnsembleBS' -expect_equal( -dim(UltimateBrier(exp1, obs1, type = 'FairEnsembleBS')), -c(nexp = 1, nobs = 1, bin = 3, ftime = 2) -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairEnsembleBS')), -c(0.1333333, 0.2000000, 0.2000000, 0.1333333, 0.4000000, 0.2000000), -tolerance = 0.0001 -) -# 'FairEnsembleBSS' -expect_equal( -dim(UltimateBrier(exp1, obs1, type = 'FairEnsembleBSS')), -c(nexp = 1, nobs = 1, bin = 3, ftime = 2) -) -expect_equal( -as.vector(UltimateBrier(exp1, obs1, type = 'FairEnsembleBSS')), -c(-0.1111111, -0.6666667, -0.6666667, 0.2592593, -1.2222222, -0.6666667), -tolerance = 0.0001 -) + # 'BS' + expect_equal( + is.list(UltimateBrier(exp1, obs1)), + TRUE + ) + expect_equal( + names(UltimateBrier(exp1, obs1)), + c('bs', 'rel', 'res', 'unc') + ) + expect_equal( + is.list(UltimateBrier(exp1, obs1, decomposition = FALSE)), + FALSE + ) + expect_equal( + dim(UltimateBrier(exp1, obs1, decomposition = FALSE)), + c(nexp = 1, nobs = 1, bin = 3, ftime = 2) + ) + expect_equal( + dim(UltimateBrier(exp1, obs1, decomposition = FALSE, thr = c(0.25, 0.5, 0.75))), + c(nexp = 1, nobs = 1, bin = 4, ftime = 2) + ) + expect_equal( + UltimateBrier(exp1, obs1)$bs, + UltimateBrier(exp1, obs1, decomposition = FALSE) + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1)$bs), + c(0.42222222, 0.44444444, 0.02222222, 0.48888889, 0.37777778, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1)$rel), + c(0.22222222, 0.31111111, 0.02222222, 0.28888889, 0.24444444, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1)$res), + c(0.0400000, 0.1066667, 0.0000000, 0.0400000, 0.1066667, 0.0000000), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1)$unc), + c(0.24, 0.24, 0.00, 0.24, 0.24, 0.00), + tolerance = 0.0001 + ) + + # 'BSS' + expect_equal( + dim(UltimateBrier(exp1, obs1, type = 'BSS')), + c(nexp = 1, nobs = 1, bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'BSS')), + c(-0.7592593, -0.8518519, -Inf, -1.0370370, -0.5740741, -Inf), + tolerance = 0.0001 + ) + + # 'FairStartDatesBS' + expect_equal( + is.list(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')), + TRUE + ) + expect_equal( + names(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')), + c('bs', 'rel', 'res', 'unc') + ) + expect_equal( + is.list(UltimateBrier(exp1, obs1, decomposition = FALSE, type = 'FairStartDatesBS')), + FALSE + ) + expect_equal( + dim(UltimateBrier(exp1, obs1, decomposition = FALSE, type = 'FairStartDatesBS')), + c(nexp = 1, nobs = 1, bin = 3, ftime = 2) + ) + expect_equal( + UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$bs, + UltimateBrier(exp1, obs1, decomposition = FALSE, type = 'FairStartDatesBS') + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$bs), + c(0.42222222, 0.44444444, 0.02222222, 0.48888889, 0.37777778, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$rel), + c(0.22222222, 0.31111111, 0.02222222, 0.28888889, 0.24444444, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$res), + c(0.0400000, 0.1066667, 0.0000000, 0.0400000, 0.1066667, 0.0000000), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBS')$unc), + c(0.24, 0.24, 0.00, 0.24, 0.24, 0.00), + tolerance = 0.0001 + ) + + # 'FairStartDatesBSS' + expect_equal( + dim(UltimateBrier(exp1, obs1, type = 'FairStartDatesBSS')), + c(nexp = 1, nobs = 1, bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairStartDatesBSS')), + c(-0.7592593, -0.8518519, -Inf, -1.0370370, -0.5740741, -Inf), + tolerance = 0.0001 + ) + # 'FairEnsembleBS' + expect_equal( + dim(UltimateBrier(exp1, obs1, type = 'FairEnsembleBS')), + c(nexp = 1, nobs = 1, bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairEnsembleBS')), + c(0.1333333, 0.2000000, 0.2000000, 0.1333333, 0.4000000, 0.2000000), + tolerance = 0.0001 + ) + # 'FairEnsembleBSS' + expect_equal( + dim(UltimateBrier(exp1, obs1, type = 'FairEnsembleBSS')), + c(nexp = 1, nobs = 1, bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp1, obs1, type = 'FairEnsembleBSS')), + c(-0.1111111, -0.6666667, -0.6666667, 0.2592593, -1.2222222, -0.6666667), + tolerance = 0.0001 + ) }) +############################################## +test_that("3. Output checks: dat2", { + # 'BS' + expect_equal( + is.list(UltimateBrier(exp2, obs2, dat_dim = NULL)), + TRUE + ) + expect_equal( + names(UltimateBrier(exp2, obs2, dat_dim = NULL)), + c('bs', 'rel', 'res', 'unc') + ) + expect_equal( + is.list(UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE)), + FALSE + ) + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE)), + c(bin = 3, ftime = 2) + ) + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE, thr = c(0.25, 0.5, 0.75))), + c(bin = 4, ftime = 2) + ) + expect_equal( + UltimateBrier(exp2, obs2, dat_dim = NULL)$bs, + UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE) + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL)$bs), + c(0.42222222, 0.44444444, 0.02222222, 0.48888889, 0.37777778, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL)$rel), + c(0.22222222, 0.31111111, 0.02222222, 0.28888889, 0.24444444, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL)$res), + c(0.0400000, 0.1066667, 0.0000000, 0.0400000, 0.1066667, 0.0000000), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL)$unc), + c(0.24, 0.24, 0.00, 0.24, 0.24, 0.00), + tolerance = 0.0001 + ) + + # 'BSS' + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'BSS')), + c(bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'BSS')), + c(-0.7592593, -0.8518519, -Inf, -1.0370370, -0.5740741, -Inf), + tolerance = 0.0001 + ) + + # 'FairStartDatesBS' + expect_equal( + is.list(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')), + TRUE + ) + expect_equal( + names(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')), + c('bs', 'rel', 'res', 'unc') + ) + expect_equal( + is.list(UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE, type = 'FairStartDatesBS')), + FALSE + ) + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE, type = 'FairStartDatesBS')), + c(bin = 3, ftime = 2) + ) + expect_equal( + UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')$bs, + UltimateBrier(exp2, obs2, dat_dim = NULL, decomposition = FALSE, type = 'FairStartDatesBS') + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')$bs), + c(0.42222222, 0.44444444, 0.02222222, 0.48888889, 0.37777778, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')$rel), + c(0.22222222, 0.31111111, 0.02222222, 0.28888889, 0.24444444, 0.02222222), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')$res), + c(0.0400000, 0.1066667, 0.0000000, 0.0400000, 0.1066667, 0.0000000), + tolerance = 0.0001 + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBS')$unc), + c(0.24, 0.24, 0.00, 0.24, 0.24, 0.00), + tolerance = 0.0001 + ) + + # 'FairStartDatesBSS' + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBSS')), + c(bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairStartDatesBSS')), + c(-0.7592593, -0.8518519, -Inf, -1.0370370, -0.5740741, -Inf), + tolerance = 0.0001 + ) + # 'FairEnsembleBS' + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairEnsembleBS')), + c(bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairEnsembleBS')), + c(0.1333333, 0.2000000, 0.2000000, 0.1333333, 0.4000000, 0.2000000), + tolerance = 0.0001 + ) + # 'FairEnsembleBSS' + expect_equal( + dim(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairEnsembleBSS')), + c(bin = 3, ftime = 2) + ) + expect_equal( + as.vector(UltimateBrier(exp2, obs2, dat_dim = NULL, type = 'FairEnsembleBSS')), + c(-0.1111111, -0.6666667, -0.6666667, 0.2592593, -1.2222222, -0.6666667), + tolerance = 0.0001 + ) + +})