diff --git a/R/RPSS.R b/R/RPSS.R index 3b24777ddde51eaab88286ca6479a07724e7eeb3..f97080c4d70e04421cdabaaea7d85fc9f90dbeb1 100644 --- a/R/RPSS.R +++ b/R/RPSS.R @@ -34,11 +34,15 @@ #'@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 two-dimensional numerical array of the forecast +#' ensemble 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_ref Same as 'weights_exp' but for the reference ensemble. #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' @@ -66,8 +70,8 @@ #'@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) { + 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) @@ -142,15 +146,35 @@ RPSS <- function(exp, obs, ref = NULL, 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'.") + 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.")) + 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 two-dimensional numeric array.') + 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)) + } + ## weights_ref + if (!is.null(weights_ref)) { + if (!is.array(weights_ref) | !is.numeric(weights_ref)) + stop('Parameter "weights_ref" must be a two-dimensional numeric array.') + 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 'exp'.") } - weights <- Reorder(weights, c(time_dim, memb_dim)) + weights_ref <- Reorder(weights_ref, c(time_dim, memb_dim)) } ## ncores if (!is.null(ncores)) { @@ -184,21 +208,23 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', fun = .RPSS, 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) { + indices_for_clim = NULL, Fair = FALSE, + weights_exp = NULL, weights_ref = NULL) { # exp: [sdate, memb] # obs: [sdate, (memb)] # ref: [sdate, memb] or NULL # 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) + 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 @@ -227,7 +253,7 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } 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) + indices_for_clim = indices_for_clim, Fair = Fair, weights = weights_ref) } # RPSS diff --git a/man/RPSS.Rd b/man/RPSS.Rd index 5b8bd7ec07dfc58f5a588fd2113009b441eb1445..893169d87b3e0814a31af70f98c0938d7693daf1 100644 --- a/man/RPSS.Rd +++ b/man/RPSS.Rd @@ -14,6 +14,8 @@ RPSS( indices_for_clim = NULL, Fair = FALSE, weights = NULL, + weights_exp = NULL, + weights_ref = NULL, ncores = NULL ) } @@ -48,11 +50,17 @@ 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 two-dimensional numerical array of the forecast +ensemble 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_ref}{Same as 'weights_exp' but for the reference ensemble.} \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} diff --git a/tests/testthat/test-RPSS.R b/tests/testthat/test-RPSS.R index c63add02246ef4980a8c388bed7b54a239e62d24..6473b247f13bb947d543624c0ea015f0d87e45a0 100644 --- a/tests/testthat/test-RPSS.R +++ b/tests/testthat/test-RPSS.R @@ -88,18 +88,18 @@ test_that("1. Input checks", { RPSS(exp1, obs1, Fair = 1), "Parameter 'Fair' must be either TRUE or FALSE." ) - # weights + # weights_exp and weights_ref expect_error( - RPS(exp1, obs1, weights = c(0, 1)), - 'Parameter "weights" must be a two-dimensional numeric array.' + RPSS(exp1, obs1, weights_exp = c(0, 1)), + 'Parameter "weights_exp" must be a two-dimensional 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." + 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, sdate = 1))), - "Parameter 'weights' must have the same dimension lengths as memb_dim and time_dim in 'exp'." + RPSS(exp1, obs1, 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 'exp'." ) # ncores expect_error( @@ -168,7 +168,7 @@ c(0.5259259, 0.4771242), tolerance = 0.0001 ) expect_equal( -as.vector(RPSS(exp1, obs1, ref1, weights = weights1)$rpss), +as.vector(RPSS(exp1, obs1, ref1, weights_exp = weights1, weights_ref = weights1)$rpss), c(0.6596424, 0.4063579), tolerance = 0.0001 )