diff --git a/NAMESPACE b/NAMESPACE index 5884b2e411691d6b4ac1984dc618f7349ad10e0e..20d5458dc1f6267beff212e01f9aebd735f68a3b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,10 +3,14 @@ export(AdamontAnalog) export(AdamontQQCorr) export(Analogs) +export(BEI_EMWeighting) export(BEI_PDFBest) +export(BEI_ProbsWeighting) +export(BEI_TercilesWeighting) export(BEI_Weights) export(BiasCorrection) export(CST_AdamontAnalog) +export(CST_AdamontQQCorr) export(CST_Analogs) export(CST_AnalogsPredictors) export(CST_Anomaly) @@ -38,6 +42,7 @@ export(EnsClustering) export(MergeDims) export(MultiEOF) export(MultiMetric) +export(PDFIndexHind) export(PlotCombinedMap) export(PlotForecastPDF) export(PlotMostLikelyQuantileMap) diff --git a/R/BEI_PDFBest.R b/R/BEI_PDFBest.R index d2abc028aa95d1202f2de0030d4b0d244890d075..61313008f103ee8ab7a5285d98e32a416f759be0 100644 --- a/R/BEI_PDFBest.R +++ b/R/BEI_PDFBest.R @@ -83,10 +83,7 @@ #' dim(index_fcst2) <- c(time = 1, member = 9, season = 2) #' method_BC <- 'ME' #' res <- BEI_PDFBest(index_obs, index_hind1, index_hind2, index_fcst1, -#' index_fcst2, method_BC) -#' dim(res) -#' # time statistic season -#' # 1 2 2 +#' index_fcst2, method_BC) #' # Example 2 for the BEI_PDFBest function #' index_obs<- rnorm(10, sd = 3) #' dim(index_obs) <- c(time = 5, season = 2) @@ -101,14 +98,12 @@ #' method_BC <- c('LMEV', 'ME') #' res <- BEI_PDFBest(index_obs, index_hind1, index_hind2, index_fcst1, #' index_fcst2, method_BC) -#' dim(res) -#' # time statistic season -#' # 1 2 2 #'@import multiApply +#'@importFrom verification verify #'@export -BEI_PDFBest <- function(index_obs, index_hind1, index_hind2, - index_fcst1 = NULL, index_fcst2 = NULL, method_BC = 'none', - time_dim_name = 'time', na.rm = FALSE) { +BEI_PDFBest <- function(index_obs, index_hind1, index_hind2, index_fcst1 = NULL, + index_fcst2 = NULL, method_BC = 'none', + time_dim_name = 'time', na.rm = FALSE) { if (!is.logical(na.rm)) { stop("Parameter 'na.rm' must be a logical value.") @@ -364,10 +359,6 @@ BEI_PDFBest <- function(index_obs, index_hind1, index_hind2, #' pdf_2 <- c(1,0.5,1.5,0.8) #' dim(pdf_2) <- c(statistic = 4) #' res <- .BEI_PDFBest(pdf_1, pdf_2, bc_dataset1 = TRUE, bc_dataset2 = FALSE) -#' str(res) -#' dim(res) -#' # statistic -#' # 2 #'@noRd .BEI_PDFBest <- function(pdf_1, pdf_2, bc_dataset1 = TRUE, bc_dataset2 = TRUE) { if(bc_dataset1){ @@ -449,10 +440,9 @@ BEI_PDFBest <- function(index_obs, index_hind1, index_hind2, #' index_hind <- 1 : (5 * 2 * 3) #' dim(index_hind) <- c(time = 5, statistic = 2, season = 3) #' res <- PDFIndexHind(index_hind, index_obs) -#' dim(res) -#' # time statistic season -#' # 5 4 3 -#'@noRd +#'@import multiApply +#'@importFrom verification verify +#'@export PDFIndexHind <- function(index_hind, index_obs, method ='ME', time_dim_name = 'time', na.rm = FALSE) { if (!is.character(time_dim_name)) { @@ -550,8 +540,6 @@ PDFIndexHind <- function(index_hind, index_obs, method ='ME', #'The third statistic is the parameter 'mean' of the PDF with bias corrected #'for the hindcast period. The fourth statistic is the parameter 'standard #'deviation' of the PDF with bias corrected for the hindcast period. -#'@import multiApply -#'@importFrom verification verify #'@examples #' # Example for the Atomic PDFIndexHind function #' index_obs <- 1 : 10 @@ -559,9 +547,8 @@ PDFIndexHind <- function(index_hind, index_obs, method ='ME', #' index_hind <- 1 : (10 * 3) #' dim(index_hind) <- c(time = 10, member = 3) #' res <- .PDFIndexHind(index_hind, index_obs) -#' dim(res) -#' # time statistic -#' # 10 4 +#'@import multiApply +#'@importFrom verification verify #'@noRd .PDFIndexHind <- function(index_hind, index_obs, method = 'ME', time_dim_name = 'time', na.rm = FALSE) { diff --git a/R/BEI_Weights.R b/R/BEI_Weights.R index 40b32ded560512df1b6ef0ea052bb1cdd6066752..f5cc7f59336d24f2091a0d76daba058b4507c9d9 100644 --- a/R/BEI_Weights.R +++ b/R/BEI_Weights.R @@ -27,8 +27,6 @@ #'@return BEI_Weights() returns a normalized weights array with the same #' dimensions that index_weight. #' -#'@import multiApply -#' #'@examples #' # Example for the BEI_Weights function #' index_weight <- 1 : (10 * 3 * 5 * 1) @@ -40,6 +38,7 @@ #' # sdate dataset member season #' # 10 3 5 1 #' +#'@import multiApply #'@export BEI_Weights <- function(index_weight, pdf_weight, time_dim_name = 'time') { diff --git a/R/CST_AdamontAnalog.R b/R/CST_AdamontAnalog.R index 81951f1e1ec0349f4ad1ec0e6a01e11c5b17e637..23bdb5315f7b0b0f25ea67b64823a22eb4c35b07 100644 --- a/R/CST_AdamontAnalog.R +++ b/R/CST_AdamontAnalog.R @@ -7,23 +7,18 @@ #'@author Paola Marson, \email{paola.marson@meteo.fr} for PROSNOW version #'@author Lauriane Batté, \email{lauriane.batte@meteo.fr} for CSTools adaptation #' -#'@param exp \itemize{ -#' \item\code{CST_AdamontAnalog}{experiment data an object of class -#' \code{s2dv_cube}, can be output from quantile correction using -#' CST_AdamontQQCorr.} -#' \item\code{AdamontAnalog}{experiment data array with named dimension.}} +#'@param exp Experiment data an object of class \code{s2dv_cube}, can be output +#' from quantile correction using CST_AdamontQQCorr. #'@param wt_exp Corresponding weather types (same dimensions as \code{exp$data} #' but lat/lon). -#'@param obs \itemize{ -#' \item\code{CST_AdamontAnalog}{reference data, also of class \code{s2dv_cube}.} -#' \item\code{AdamontAnalog}{reference data array with named dimension.}} -#' Note that lat/lon dimensions need to be the same as \code{exp} +#'@param obs Reference data, also of class \code{s2dv_cube}. Note that lat/lon +#' dimensions need to be the same as \code{exp}. #'@param wt_obs Corresponding weather types (same dimensions as \code{obs$data} #' but lat/lon) #'@param nanalogs Integer defining the number of analog values to return -#' (default: 5) +#' (default: 5). #'@param method A character string indicating the method used for analog -#' definition. Coded are: +#' definition. It can be: #' \itemize{ #' \item{'pattcorr': pattern correlation.} #' \item{'rain1' (for precip patterns): rain occurrence consistency.} @@ -31,63 +26,61 @@ #' consistency} #' } #'@param thres Real number indicating the threshold to define rain -#' occurrence/non occurrence in rain(0)1 +#' occurrence/non occurrence in rain (0)1. #'@param search_obsdims List of dimensions in \code{obs} along which analogs are #' searched for. #'@param londim Name of longitude dimension. #'@param latdim Name of latitude dimension. -#'@return analog_vals -#'\itemize{ -#' \item\code{CST_AdamontAnalog}{An object of class \code{s2dv_cube} containing -#' nanalogs analog values for each value of \code{exp} input data.} -#' \item\code{AdamontAnalog}{An array containing nanalogs analog values.}} +#'@return analog_vals An object of class \code{s2dv_cube} containing +#' nanalogs analog values for each value of \code{exp} input data. +#'@examples +#'wt_exp <- sample(1:3, 15*6*3, replace = TRUE) +#'dim(wt_exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3) +#'wt_obs <- sample(1:3, 6*3, replace = TRUE) +#'dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3) +#'exp <- NULL +#'exp$data <- 1 : c(1 * 15 * 6 * 3 * 8 * 8) +#'dim(exp$data) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3, +#' lat = 8, lon = 8) +#'class(exp) <- 's2dv_cube' +#'obs <- NULL +#'obs$data <- 101 : c(100 + 1 * 1 * 6 * 3 * 8 * 8) +#'dim(obs$data) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3, +#' lat = 8, lon = 8) +#'class(obs) <- 's2dv_cube' +#'analog_vals <- CST_AdamontAnalog(exp = exp, obs = obs, wt_exp = wt_exp, +#' wt_obs = wt_obs, nanalogs = 2) #'@import multiApply #'@importFrom ClimProjDiags Subset -#'@examples -#'\dontrun{ -#'wt_exp <- sample(1:3, 15*6*3, replace=T) -#'dim(wt_exp) <- c(dataset=1, member=15, sdate=6, ftime=3) -#'wt_obs <- sample(1:3, 6*3, replace=T) -#'dim(wt_obs) <- c(dataset=1, member=1, sdate=6, ftime=3) -#'analog_vals <- CST_AdamontAnalog(exp = lonlat_temp$exp, obs = lonlat_temp$obs, -#' wt_exp = wt_exp, wt_obs = wt_obs, nanalogs = 2) -#'} -#'\dontrun{ -#'wt_exp <- sample(1:3, 15*6*3, replace=T) -#'dim(wt_exp) <- c(dataset=1, member=15, sdate=6, ftime=3) -#'wt_obs <- sample(1:3, 6*3, replace=T) -#'dim(wt_obs) <- c(dataset=1, member=1, sdate=6, ftime=3) -# analog_vals <- AdamontAnalog(exp=lonlat_temp$exp$data, -#' obs=lonlat_temp$obs$data, wt_exp=wt_exp, wt_obs=wt_obs, nanalogs=2) -#'} #'@export CST_AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs, - method = 'pattcorr', thres = NULL, - search_obsdims = c('member', 'sdate', 'ftime'), - londim = 'lon', latdim = 'lat') { + method = 'pattcorr', thres = NULL, + search_obsdims = c('member', 'sdate', 'ftime'), + londim = 'lon', latdim = 'lat') { dimnames <- names(dim(obs$data)) dimnamesexp <- names(dim(exp$data)) + if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { stop("Inputs 'exp' and 'obs' must be of class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + "as output by CSTools::CST_Load.") } if (!(method %in% c('pattcorr','rain1','rain01'))) { stop("Input parameter 'method' must be 'pattcorr', 'rain1', or 'rain01'") } - if (is.null(nanalogs)){ + if (is.null(nanalogs)) { nanalogs <- 5 } if (!(latdim %in% dimnames) || !(londim %in% dimnames)){ stop("'londim' or 'latdim' input doesn't match with 'obs$data' dimension", - " names") + " names") } if (!(latdim %in% dimnamesexp) || !(londim %in% dimnamesexp)){ stop("'londim' or 'latdim' input doesn't match with 'exp$data' dimension", - " names") + " names") } if (!all(search_obsdims %in% dimnames)) { stop("Names in parameter 'search_obsdims' should match 'obs$data' ", - "dimension names.") + "dimension names.") } if (!all(dim(wt_exp) %in% dim(exp$data))) { stop("Dimensions for 'wt_exp' should match 'exp$data' except lat/lon") @@ -95,48 +88,91 @@ CST_AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs, if (!all(dim(wt_obs) %in% dim(obs$data))) { stop("Dimensions for 'wt_obs' should match 'obs$data' except lat/lon") } - plat_exp <- which(dimnamesexp==latdim) - plon_exp <- which(dimnamesexp==londim) - plat_obs <- which(dimnames==latdim) - plon_obs <- which(dimnames==londim) - if ((dim(obs$data)[plon_obs]!=dim(exp$data)[plon_exp]) || - (dim(obs$data)[plat_obs]!=dim(exp$data)[plat_exp])){ + plat_exp <- which(dimnamesexp == latdim) + plon_exp <- which(dimnamesexp == londim) + plat_obs <- which(dimnames == latdim) + plon_obs <- which(dimnames == londim) + if ((dim(obs$data)[plon_obs] != dim(exp$data)[plon_exp]) || + (dim(obs$data)[plat_obs] != dim(exp$data)[plat_exp])){ stop("Element 'data' from parameters 'obs' and 'exp' should have", "same lon / lat dimensions if working with regular grids.") } # End of sanity checks; call AdamontAnalog function analog_vals <- AdamontAnalog(exp = exp$data, obs = obs$data, wt_exp = wt_exp, - wt_obs = wt_obs, nanalogs = nanalogs, - method = method, thres = thres, - search_obsdims = search_obsdims, londim = londim, - latdim = latdim ) + wt_obs = wt_obs, nanalogs = nanalogs, + method = method, thres = thres, + search_obsdims = search_obsdims, londim = londim, + latdim = latdim ) return(analog_vals) } - -#'AdamontAnalog finds analogous data in the reference dataset to experiment data -#'based on weather types +#'AdamontAnalog finds analogous data in the reference dataset to experiment +#'data based on weather types #' +#'@description This function searches for analogs in a reference dataset for +#'experiment data, based on corresponding weather types. The experiment data is +#'typically a hindcast, observations are typically provided by reanalysis data. +#'@author Paola Marson, \email{paola.marson@meteo.fr} for PROSNOW version +#'@author Lauriane Batté, \email{lauriane.batte@meteo.fr} for CSTools adaptation +#' +#' +#'@param exp A multidimensional array with named dimensions containing the +#' experiment data. +#'@param wt_exp Corresponding weather types (same dimensions as \code{exp$data} +#' but lat/lon). +#'@param obs A multidimensional array with named dimensions containing the +#' reference data. Note that lat/lon dimensions need to be the same as +#' \code{exp}. +#'@param wt_obs Corresponding weather types (same dimensions as \code{obs$data} +#' but lat/lon). +#'@param nanalogs Integer defining the number of analog values to return +#' (default: 5). +#'@param method A character string indicating the method used for analog +#' definition. It can be: +#' \itemize{ +#' \item{'pattcorr': pattern correlation.} +#' \item{'rain1' (for precip patterns): rain occurrence consistency.} +#' \item{'rain01' (for precip patterns): rain occurrence/non occurrence +#' consistency} +#' } +#'@param thres Real number indicating the threshold to define rain +#' occurrence/non occurrence in rain (0)1. +#'@param search_obsdims List of dimensions in \code{obs} along which analogs are +#' searched for. +#'@param londim Name of longitude dimension. +#'@param latdim Name of latitude dimension. +#'@return analog_vals An array containing nanalogs analog values. +#'@examples +#'wt_exp <- sample(1:3, 15*6*3, replace = TRUE) +#'dim(wt_exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3) +#'wt_obs <- sample(1:3, 6*3, replace = TRUE) +#'dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3) +#'exp <- 1 : c(1 * 15 * 6 * 3 * 8 * 8) +#'dim(exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3, lat = 8, lon = 8) +#'obs <- 101 : c(100 + 1 * 1 * 6 * 3 * 8 * 8) +#'dim(obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3, lat = 8, lon = 8) +#'analog_vals <- AdamontAnalog(exp = exp, obs = obs, wt_exp = wt_exp, +#' wt_obs = wt_obs, nanalogs = 2) #'@import multiApply #'@importFrom ClimProjDiags Subset #'@rdname CST_AdamontAnalog #'@export -AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs=5, - method = 'pattcorr', thres = NULL, - search_obsdims = c('member', 'sdate', 'ftime'), - londim = 'lon', latdim = 'lat') { +AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs = 5, + method = 'pattcorr', thres = NULL, + search_obsdims = c('member', 'sdate', 'ftime'), + londim = 'lon', latdim = 'lat') { # exp: lat, lon, sdate, ftime, member # obs: lat, lon, dims for searching 'sdate' 'ftime'... # wt_exp: sdate, ftime, member # wt_obs: the dims for searching dimnames <- names(dim(obs)) dimnamesexp <- names(dim(exp)) - if (method %in% c('rain1','rain01') & is.null(thres)){ + if (method %in% c('rain1','rain01') & is.null(thres)) { stop("Threshold 'thres' must be defined with methods 'rain1' and 'rain01'") } - if (method == 'pattcorr' & !is.null(thres)){ + if (method == 'pattcorr' & !is.null(thres)) { warning("Parameter 'thres' is not used with method 'pattcorr'.") } - if (!(latdim %in% dimnamesexp) || !(londim %in% dimnamesexp)){ + if (!(latdim %in% dimnamesexp) || !(londim %in% dimnamesexp)) { stop("'londim' or 'latdim' input doesn't match with 'exp' dimension names") } # Position of lat/lon dimensions in exp data @@ -144,7 +180,7 @@ AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs=5, poslonexp <- which(dimnamesexp == londim) poslatobs <- which(dimnames == latdim) poslonobs <- which(dimnames == londim) - if (!all(search_obsdims %in% dimnames)){ + if (!all(search_obsdims %in% dimnames)) { stop("Names in parameter 'search_obsdims' should match 'obs' ", "dimension names.") } @@ -179,7 +215,7 @@ AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs=5, target_dims = list(c(londim, latdim), c(londim, latdim, 'time', 'type'), NULL), - .analogs, method = method, thres = thres)$output1 + .aanalogs, method = method, thres = thres)$output1 # Reshaping output: analog_vals <- Subset(analog_vals, along = 'type', indices = 1, drop = 'selected') @@ -200,7 +236,7 @@ AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs=5, } -.analogs <- function(exp, obs, wt_exp, nanalogs = 5, method = 'pattcorr', +.aanalogs <- function(exp, obs, wt_exp, nanalogs = 5, method = 'pattcorr', thres = NULL, londimexp = 'lon', latdimexp = 'lat', londimobs = 'lon', latdimobs = 'lat') { # exp: lon, lat @@ -208,15 +244,16 @@ AdamontAnalog <- function(exp, obs, wt_exp, wt_obs, nanalogs=5, # wt_exp: wt single scalar search_analog <- switch(method, 'rain1' = .rain1, 'rain01' = .rain01, - 'pattcorr' = .pattcor, + 'pattcorr' = .pattcor, stop(paste0("Adamont Analog function only supports ", - "methods 'rain1', 'rain01', 'pattcorr'"))) + "methods 'rain1', 'rain01', 'pattcorr'"))) obs <- Subset(obs, along = 'type', indices = wt_exp) accuracy <- Apply(list(exp, obs), target_dims = list(c(londimexp, latdimexp), c(londimobs, latdimobs)), search_analog, thres = thres)$output1 - obs <- Subset(obs, along = 'time', indices = order(accuracy, decreasing = TRUE)[1:nanalogs]) + obs <- Subset(obs, along = 'time', + indices = order(accuracy, decreasing = TRUE)[1:nanalogs]) return(obs) } diff --git a/R/CST_AdamontQQCorr.R b/R/CST_AdamontQQCorr.R index ac6c07b37e133c37a185b1bbfd188f681e71fcf8..3309180358435ca8793c437c698c239b81c4be4e 100644 --- a/R/CST_AdamontQQCorr.R +++ b/R/CST_AdamontQQCorr.R @@ -28,74 +28,86 @@ #'lat/lon grid of \code{obs} input data, corrected by quantile mapping #'depending on the weather types \code{wt_exp}. #' +#'@examples +#'wt_exp <- c(1,1,2,3,3,2,2,1,1,2,2,3) +#'dim(wt_exp) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +#'wt_obs <- c(3,3,1,2,2,2,2,1,3,1,1,2) +#'dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +#'exp <- NULL +#'exp$data <- 1 : c(1 * 1 * 4 * 3 * 4 * 4) +#'dim(exp$data) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, +#' lat = 4, lon = 4) +#'class(exp) <- 's2dv_cube' +#'obs <- NULL +#'obs$data <- 101 : c(100 + 1 * 1 * 4 * 3 * 4 * 4) +#'dim(obs$data) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, +#' lat = 4, lon = 4) +#'class(obs) <- 's2dv_cube' +#'exp_corr <- CST_AdamontQQCorr(exp = exp, wt_exp = wt_exp, +#' obs = obs, wt_obs = wt_obs, +#' corrdims = c('dataset','member','sdate','ftime')) #'@import qmap #'@importFrom ClimProjDiags Subset #'@import multiApply #'@import abind -#'@examples -#'\dontrun{ -#'wt_exp <- sample(1:3, 15*6*3, replace=T) -#'dim(wt_exp) <- c(dataset=1, member=15, sdate=6, ftime=3) -#'wt_obs <- sample(1:3, 6*3, replace=T) -#'dim(wt_obs) <- c(dataset=1, member=1, sdate=6, ftime=3) -#'exp_corr <- CST_AdamontQQCorr(exp = lonlat_temp$exp, wt_exp = wt_exp, -#' obs=lonlat_temp$obs, wt_obs = wt_obs, -#' corrdims = c('dataset','member','sdate','ftime')) -#'} +#'@export CST_AdamontQQCorr <- function(exp, wt_exp, obs, wt_obs, - corrdims = c('member','sdate','ftime'), - londim = 'lon', latdim = 'lat') { + corrdims = c('member', 'sdate', 'ftime'), + londim = 'lon', latdim = 'lat') { - if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')){ - stop("Inputs 'exp' and 'obs' must be of class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } - dimnames <- names(dim(obs$data)) - dimnamesexp <- names(dim(exp$data)) - if (!(latdim %in% dimnames) || !(londim %in% dimnames)){ - stop("'londim' or 'latdim' input doesn't match with 'obs$data' dimension", - " names") - } - if (!(latdim %in% dimnamesexp) || !(londim %in% dimnamesexp)){ - stop("'londim' or 'latdim' input doesn't match with 'exp$data' dimension", - " names") - } - if (!(('time' %in% corrdims) || ('ftime' %in% corrdims))){ - warning("Forecast time should be one of the dimensions for the correction - specified in corrdims input list") - } - if (!all(corrdims %in% dimnamesexp)){ - stop("Names in parameter 'corrdims' should match input dimension names.") - } - if (!all(dim(wt_exp) %in% dim(exp$data))){ - stop("Dimensions for 'wt_exp' should match 'exp$data' except lat/lon") - } - if (!all(dim(wt_obs) %in% dim(obs$data))){ - stop("Dimensions for 'wt_obs' should match 'obs$data' except lat/lon") - } - if ((length(dim(exp$lon))==2) || (length(dim(obs$lon))==2)){ - myNN <- .NearestNeighbors(exp=exp, obs=obs, method='ADA') - exp_corr <- AdamontQQCorr(exp=exp$data, wt_exp=wt_exp, obs=obs$data, - wt_obs=wt_obs, corrdims=corrdims, - londim=londim, latdim=latdim, - regrid=TRUE, NN=myNN) - } else { - ## If not (standard case) - ## exp$data lat/lon dimensions should match obs$data - plat_exp <- which(dimnamesexp==latdim) - plon_exp <- which(dimnamesexp==londim) - plat_obs <- which(dimnames==latdim) - plon_obs <- which(dimnames==londim) - if ((dim(obs$data)[plon_obs]!=dim(exp$data)[plon_exp]) || - (dim(obs$data)[plat_obs]!=dim(exp$data)[plat_exp])){ - stop("Element 'data' from parameters 'obs' and 'exp' should have", - "same lon / lat dimensions if working with regular grids.") - } - exp_corr <- AdamontQQCorr(exp=exp$data, wt_exp=wt_exp, obs=obs$data, - wt_obs=wt_obs, corrdims=corrdims, - londim=londim, latdim=latdim, regrid=FALSE) - } - return(exp_corr) + if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')){ + stop("Inputs 'exp' and 'obs' must be of class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + dimnames <- names(dim(obs$data)) + dimnamesexp <- names(dim(exp$data)) + if (!(latdim %in% dimnames) || !(londim %in% dimnames)) { + stop("'londim' or 'latdim' input doesn't match with 'obs$data' dimension", + " names") + } + if (!(latdim %in% dimnamesexp) || !(londim %in% dimnamesexp)) { + stop("'londim' or 'latdim' input doesn't match with 'exp$data' dimension", + " names") + } + if (!(('time' %in% corrdims) || ('ftime' %in% corrdims))) { + warning("Forecast time should be one of the dimensions for the correction ", + "specified in corrdims input list") + } + if (!all(corrdims %in% dimnamesexp)) { + stop("Names in parameter 'corrdims' should match input dimension names.") + } + if (!all(dim(wt_exp) %in% dim(exp$data))) { + stop("Dimensions for 'wt_exp' should match 'exp$data' except lat/lon") + } + if (!all(dim(wt_obs) %in% dim(obs$data))) { + stop("Dimensions for 'wt_obs' should match 'obs$data' except lat/lon") + } + if ((length(dim(exp$coords[[londim]])) == 2) || + (length(dim(obs$coords[[londim]])) == 2)) { + myNN <- .NearestNeighbors(exp = exp, obs = obs, method = 'ADA') + exp_corr <- AdamontQQCorr(exp = exp$data, wt_exp = wt_exp, obs = obs$data, + wt_obs = wt_obs, corrdims = corrdims, + londim = londim, latdim = latdim, regrid = TRUE, + NN = myNN) + } else { + ## If not (standard case) + ## exp$data lat/lon dimensions should match obs$data + plat_exp <- which(dimnamesexp == latdim) + plon_exp <- which(dimnamesexp == londim) + plat_obs <- which(dimnames == latdim) + plon_obs <- which(dimnames == londim) + if ((dim(obs$data)[plon_obs] != dim(exp$data)[plon_exp]) || + (dim(obs$data)[plat_obs] != dim(exp$data)[plat_exp])) { + stop("Element 'data' from parameters 'obs' and 'exp' should have ", + "same lon / lat dimensions if working with regular grids.") + } + exp_corr <- AdamontQQCorr(exp = exp$data, wt_exp = wt_exp, obs = obs$data, + wt_obs = wt_obs, corrdims = corrdims, + londim = londim, latdim = latdim, + regrid = FALSE) + } + exp$data <- exp_corr + return(exp) } @@ -135,164 +147,173 @@ CST_AdamontQQCorr <- function(exp, wt_exp, obs, wt_obs, #'lat/lon grid of \code{obs} array, corrected by quantile mapping depending on #'the weather types \code{wt_exp} #' +#'@examples +#'wt_exp <- c(1,1,2,3,3,2,2,1,1,2,2,3) +#'dim(wt_exp) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +#'wt_obs <- c(3,3,1,2,2,2,2,1,3,1,1,2) +#'dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +#'exp <- 1 : c(1 * 1 * 4 * 3 * 4 * 4) +#'dim(exp) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, +#' lat = 4, lon = 4) +#'obs <- 101 : c(100 + 1 * 1 * 4 * 3 * 4 * 4) +#'dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, +#' lat = 4, lon = 4) +#'exp_corr <- AdamontQQCorr(exp = exp, wt_exp = wt_exp, +#' obs = obs, wt_obs = wt_obs, +#' corrdims = c('dataset', 'member', 'sdate', 'ftime')) #'@import qmap #'@importFrom ClimProjDiags Subset #'@import multiApply #'@import abind -#'@examples -#'\dontrun{ -#'wt_exp <- sample(1:3, 15*6*3, replace=T) -#'dim(wt_exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3) -#'wt_obs <- sample(1:3, 6*3, replace = T) -#'dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3) -#'exp_corr <- AdamontQQCorr(exp = lonlat_temp$exp$data, wt_exp = wt_exp, -#' obs = lonlat_temp$obs$data, wt_obs = wt_obs, -#' corrdims = c('dataset','member','sdate','ftime')) -#'} #'@export AdamontQQCorr <- function(exp, wt_exp, obs, wt_obs, - corrdims = c('member', 'sdate', 'ftime'), - londim = 'lon', latdim = 'lat', regrid = FALSE, + corrdims = c('member', 'sdate', 'ftime'), + londim = 'lon', latdim = 'lat', regrid = FALSE, NN = NULL) { - dimnames <- names(dim(obs)) - dimnamesexp <- names(dim(exp)) - if (!(latdim %in% dimnames) || !(londim %in% dimnames)){ - stop("'londim' or 'latdim' input doesn't match with 'obs' dimension names") - } - if (!(('time' %in% corrdims) || ('ftime' %in% corrdims))){ - warning("Forecast time should be one of the dimensions for the correction", - " specified in corrdims input list") - } - if (!all(corrdims %in% dimnamesexp)){ - stop("Names in parameter 'corrdims' should match input dimension names.") - } - if (!all(dim(wt_exp) %in% dim(exp))){ - stop("Dimensions for 'wt_exp' should match 'exp' except lat/lon") - } - if (!all(dim(wt_obs) %in% dim(obs))){ - stop("Dimensions for 'wt_obs' should match 'obs' except lat/lon") - } - if ((regrid == 'TRUE') & is.null(NN)){ - stop("regrid set to TRUE: provide nearest neighbors input NN") - } - # The regridding part should only be done if lat/lon dimensions of obs and - # exp differ. - if (regrid == 'TRUE'){ - obsdims <- names(dim(obs)) - poslat <- which(obsdims == latdim) - poslon <- which(obsdims == londim) - nlat_o <- dim(obs)[poslat] - nlon_o <- dim(obs)[poslon] - ilat_o <- array(c(1:nlat_o)) - names(dim(ilat_o))[1] <- latdim - ilon_o <- array(c(1:nlon_o)) - names(dim(ilon_o))[1] <- londim - ## First step if obs data is higher resolution than exp data is to use - ## nearest neighbor to compute downscaling of exp data - exp_corr <- Apply(list(exp,ilat_o,ilon_o), - target_dims=list(c(latdim,londim),latdim,londim), - .getNN,NN=NN)$output1 + dimnames <- names(dim(obs)) + dimnamesexp <- names(dim(exp)) - ## Reorder exp_corr dimensions to match exp dimensions - dexpc <- match(names(dim(exp)), names(dim(exp_corr))) - exp_corr <- aperm(exp_corr,dexpc) - dimnames(exp_corr) <- dimnames(exp)[dexpc] - ## Keep original wt_exp for remapping data - wt_exp2 <- wt_exp - ## Both exp and obs data are now on the same grid - } else { - ## exp lat/lon dimensions should match obs - plat_exp <- which(dimnamesexp==latdim) - plon_exp <- which(dimnamesexp==londim) - plat_obs <- which(dimnames==latdim) - plon_obs <- which(dimnames==londim) - if ((dim(obs)[plon_obs]!=dim(exp)[plon_exp]) || - (dim(obs)[plat_obs]!=dim(exp)[plat_exp])){ - stop("Parameters 'obs' and 'exp' should have same lon / lat", - " dimensions if regrid set to 'FALSE' (regular grid case).") - } - exp_corr <- exp - ## Keep original wt_exp for remapping data - wt_exp2 <- wt_exp - } + if (!(latdim %in% dimnames) || !(londim %in% dimnames)) { + stop("'londim' or 'latdim' input doesn't match with 'obs' dimension names") + } + if (!(('time' %in% corrdims) || ('ftime' %in% corrdims))) { + warning("Forecast time should be one of the dimensions for the correction", + " specified in corrdims input list") + } + if (!all(corrdims %in% dimnamesexp)) { + stop("Names in parameter 'corrdims' should match input dimension names.") + } + if (!all(dim(wt_exp) %in% dim(exp))) { + stop("Dimensions for 'wt_exp' should match 'exp' except lat/lon") + } + if (!all(dim(wt_obs) %in% dim(obs))) { + stop("Dimensions for 'wt_obs' should match 'obs' except lat/lon") + } + if ((regrid == 'TRUE') & is.null(NN)) { + stop("regrid set to TRUE: provide nearest neighbors input NN") + } + # The regridding part should only be done if lat/lon dimensions of obs and + # exp differ. + if (regrid == 'TRUE') { + obsdims <- names(dim(obs)) + poslat <- which(obsdims == latdim) + poslon <- which(obsdims == londim) + nlat_o <- dim(obs)[poslat] + nlon_o <- dim(obs)[poslon] + ilat_o <- array(c(1:nlat_o)) + names(dim(ilat_o))[1] <- latdim + ilon_o <- array(c(1:nlon_o)) + names(dim(ilon_o))[1] <- londim + ## First step if obs data is higher resolution than exp data is to use + ## nearest neighbor to compute downscaling of exp data + exp_corr <- Apply(list(exp, ilat_o, ilon_o), + target_dims = list(c(latdim,londim), latdim, londim), .getNN, NN = NN)$output1 + ## Reorder exp_corr dimensions to match exp dimensions + dexpc <- match(names(dim(exp)), names(dim(exp_corr))) + exp_corr <- aperm(exp_corr, dexpc) + dimnames(exp_corr) <- dimnames(exp)[dexpc] + ## Keep original wt_exp for remapping data + wt_exp2 <- wt_exp + ## Both exp and obs data are now on the same grid + } else { + ## exp lat/lon dimensions should match obs + plat_exp <- which(dimnamesexp == latdim) + plon_exp <- which(dimnamesexp == londim) + plat_obs <- which(dimnames == latdim) + plon_obs <- which(dimnames == londim) + if ((dim(obs)[plon_obs] != dim(exp)[plon_exp]) || + (dim(obs)[plat_obs] != dim(exp)[plat_exp])) { + stop("Parameters 'obs' and 'exp' should have same lon / lat ", + "dimensions if regrid set to 'FALSE' (regular grid case).") + } + exp_corr <- exp + ## Keep original wt_exp for remapping data + wt_exp2 <- wt_exp + } - ## Use CST_QuantileMapping function for quantile mapping - ## depending on weather type - for (i in 1:(length(corrdims) - 1)) { - obs <- MergeDims(obs, corrdims[i:(i+1)], rename_dim=corrdims[i+1]) - wt_obs <- MergeDims(wt_obs, corrdims[i:(i+1)], rename_dim=corrdims[i+1]) - exp_corr <- MergeDims(exp_corr, corrdims[i:(i+1)], rename_dim=corrdims[i+1]) - wt_exp2 <- MergeDims(wt_exp2, corrdims[i:(i+1)], rename_dim=corrdims[i+1]) - } - names(dim(obs))[which(names(dim(obs)) == corrdims[length(corrdims)])] <- 'time' - names(dim(wt_obs))[which(names(dim(wt_obs)) == corrdims[length(corrdims)])] <- 'time' - names(dim(exp_corr))[which(names(dim(exp_corr)) == corrdims[length(corrdims)])] <- 'time' - names(dim(wt_exp2))[which(names(dim(wt_exp2)) == corrdims[length(corrdims)])] <- 'time' - # Split 'time' dim in weather types - obs <- SplitDim(obs, split_dim='time',indices=as.vector(wt_obs), - new_dim_name='type') - exp_corr <- SplitDim(exp_corr, split_dim='time',indices=as.vector(wt_exp2), - new_dim_name='type') - ## Add NAs to exp_corr if needed to have compatible sample dimensions - numtobs <- dim(obs)[which(names(dim(obs))=='time')] - numtexp <- dim(exp_corr)[which(names(dim(exp_corr))=='time')] - if (numtexp%%numtobs > 0){ - ## Create extra dimension and include NAs - ndimexp <- names(dim(exp_corr)) - ndimobs <- names(dim(obs)) - postime <- which(ndimexp=='time') - dimadd <- dim(exp_corr) - dimadd[postime] <- ceiling(numtexp/numtobs)*numtobs-numtexp - exp_corr <- abind::abind(exp_corr,array(NA,dimadd),along=postime) - names(dim(exp_corr)) <- ndimexp - exp_corr <- SplitDim(exp_corr,'time',freq=numtobs,indices=NULL) - dimobs <- c(dim(obs),1) - dim(obs) <- dimobs - names(dim(obs)) <- c(ndimobs,'index') - res <- QuantileMapping(exp=exp_corr,obs=obs,sample_dims=c('time','index'), - method='RQUANT') - res <- MergeDims(res,c('time','index')) - ## Remove the extra NA values added previously - res <- Subset(res,along = 'time', indices = 1:numtexp) - } else { - ## Apply QuantileMapping to exp_corr depending on weather type - res <- QuantileMapping(exp = exp_corr, obs = obs, sample_dims = 'time', - samplemethod = 'RQUANT') - } - rm(exp_corr) # Save space in memory - ## Reshape exp_corr data onto time dimension before 'Split' - rep_pos <- array(NA,c(time=length(wt_exp2))) - pos_time <- which(names(dim(res)) == 'time') - pos_type <- which(names(dim(res)) == 'type') - for (x in unique(wt_exp2)){ - rep_pos[which(wt_exp2==x)]<-1:length(which(wt_exp2==x)) - } - exp_corr <- .unsplit_wtype(exp=res,wt_exp=wt_exp2,rep_pos=rep_pos, - pos_time=pos_time) - # Now reshape exp_corr data onto original dimensions - dim(exp_corr) <- c(dim(wt_exp), dim(exp_corr)[-c(pos_time,pos_type)]) - return(exp_corr) + ## Use CST_QuantileMapping function for quantile mapping + ## depending on weather type + for (i in 1:(length(corrdims) - 1)) { + obs <- MergeDims(obs, corrdims[i:(i+1)], rename_dim = corrdims[i+1]) + wt_obs <- MergeDims(wt_obs, corrdims[i:(i+1)], rename_dim = corrdims[i+1]) + exp_corr <- MergeDims(exp_corr, corrdims[i:(i+1)], rename_dim = corrdims[i+1]) + wt_exp2 <- MergeDims(wt_exp2, corrdims[i:(i+1)], rename_dim = corrdims[i+1]) + } + + names(dim(obs))[which(names(dim(obs)) == corrdims[length(corrdims)])] <- 'time' + names(dim(wt_obs))[which(names(dim(wt_obs)) == corrdims[length(corrdims)])] <- 'time' + names(dim(exp_corr))[which(names(dim(exp_corr)) == corrdims[length(corrdims)])] <- 'time' + names(dim(wt_exp2))[which(names(dim(wt_exp2)) == corrdims[length(corrdims)])] <- 'time' + + # Split 'time' dim in weather types + obs <- SplitDim(obs, split_dim = 'time', indices = as.vector(wt_obs), + new_dim_name = 'type') + exp_corr <- SplitDim(exp_corr, split_dim = 'time', indices = as.vector(wt_exp2), + new_dim_name = 'type') + ## Add NAs to exp_corr if needed to have compatible sample dimensions + numtobs <- dim(obs)[which(names(dim(obs)) == 'time')] + numtexp <- dim(exp_corr)[which(names(dim(exp_corr)) == 'time')] + + if (numtexp%%numtobs > 0) { + ## Create extra dimension and include NAs + ndimexp <- names(dim(exp_corr)) + ndimobs <- names(dim(obs)) + postime <- which(ndimexp == 'time') + dimadd <- dim(exp_corr) + dimadd[postime] <- ceiling(numtexp/numtobs) * numtobs - numtexp + exp_corr <- abind::abind(exp_corr, array(NA, dimadd), along = postime) + names(dim(exp_corr)) <- ndimexp + exp_corr <- SplitDim(exp_corr, 'time', freq = numtobs, indices = NULL) + dimobs <- c(dim(obs), 1) + dim(obs) <- dimobs + names(dim(obs)) <- c(ndimobs, 'index') + res <- QuantileMapping(exp = exp_corr, obs = obs, memb_dim = 'index', + sdate_dim = 'time', method = 'RQUANT', na.rm = TRUE) + res <- MergeDims(res, c('time','index')) + ## Remove the extra NA values added previously + res <- Subset(res, along = 'time', indices = 1:numtexp) + } else { + ## Apply QuantileMapping to exp_corr depending on weather type + exp_corr <- InsertDim(exp_corr, posdim = 1, lendim = 1, name = 'member') + res <- QuantileMapping(exp = exp_corr, obs = obs, sdate_dim = 'time', + samplemethod = 'RQUANT', na.rm = TRUE) + dim(res) <- dim(res)[-which(names(dim(res)) == 'member')] + } + rm(exp_corr) # Save space in memory + ## Reshape exp_corr data onto time dimension before 'Split' + rep_pos <- array(NA, c(time = length(wt_exp2))) + pos_time <- which(names(dim(res)) == 'time') + pos_type <- which(names(dim(res)) == 'type') + for (x in unique(wt_exp2)) { + rep_pos[which(wt_exp2 == x)] <- 1:length(which(wt_exp2 == x)) + } + exp_corr <- .unsplit_wtype(exp = res, wt_exp = wt_exp2, rep_pos = rep_pos, + pos_time = pos_time) + # Now reshape exp_corr data onto original dimensions + dim(exp_corr) <- c(dim(wt_exp), dim(exp_corr)[-c(pos_time,pos_type)]) + return(exp_corr) } -.getNN <- function(exp,ilat,ilon,NN){ - return(exp[NN$imin_lat[ilat,ilon],NN$imin_lon[ilat,ilon]]) +.getNN <- function(exp, ilat, ilon, NN) { + return(exp[NN$imin_lat[ilat, ilon], NN$imin_lon[ilat, ilon]]) } -.unsplit_wtype <- function(exp=exp,dim_wt='type',wt_exp=wt_exp, - dim_time='time',rep_pos=rep_pos,pos_time=1){ - # Initiate output - new <- Subset(Subset(exp, along=dim_wt, indices=wt_exp[1]), along=dim_time, - indices=rep_pos[1]) - dimnames <- names(dim(new)) - for (x in 2:length(wt_exp)){ - dat <- Subset(Subset(exp, along=dim_wt, indices=wt_exp[x]), - along=dim_time, indices=rep_pos[x]) - new <- abind::abind(new,dat,along=pos_time) - } - names(dim(new)) <- dimnames - return(new) +.unsplit_wtype <- function(exp = exp,dim_wt = 'type', wt_exp = wt_exp, + dim_time = 'time', rep_pos = rep_pos, pos_time = 1) { + # Initiate output + new <- Subset(Subset(exp, along = dim_wt, indices = wt_exp[1]), + along = dim_time, indices = rep_pos[1]) + dimnames <- names(dim(new)) + for (x in 2:length(wt_exp)) { + dat <- Subset(Subset(exp, along = dim_wt, indices = wt_exp[x]), + along = dim_time, indices = rep_pos[x]) + new <- abind::abind(new, dat, along = pos_time) + } + names(dim(new)) <- dimnames + return(new) } + #'ADAMONT Nearest Neighbors computes the distance between reference data grid #'centroid and SF data grid #' @@ -328,84 +349,106 @@ AdamontQQCorr <- function(exp, wt_exp, obs, wt_obs, #'@importFrom ClimProjDiags Subset #'@import ncdf4 #'@noRd -.NearestNeighbors <- function (exp, obs, method='ADA') { - - if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { - stop("Inputs 'exp' and 'obs' must be of class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } - exp_lon <- exp$lon - exp_lat <- exp$lat - obs_lon <- obs$lon - obs_lat <- obs$lat - dim_exp_lon <- dim(exp_lon) - dim_exp_lat <- dim(exp_lat) - dim_obs_lon <- dim(obs_lon) - dim_obs_lat <- dim(obs_lat) - # Check if one of the grids is non-regular: - if ((length(dim_exp_lon)==2) || (length(dim_obs_lon)==2)){ - # Flatten longitudes and latitudes in case of 2-D longitudes and latitudes (Lambert grids, etc.) - if ((length(dim_exp_lon)==2) & (length(dim_exp_lat)==2)){ - dim(exp_lon) <- c(dim_exp_lon[1]*dim_exp_lon[2]) - dim(exp_lat) <- c(dim_exp_lat[1]*dim_exp_lat[2]) +.NearestNeighbors <- function (exp, obs, method = 'ADA') { + # Check 's2dv_cube' + if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { + stop("Inputs 'exp' and 'obs' must be of class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + # Check 'exp' and 'obs' object structure + if (!all(c('data', 'coords') %in% names(exp))) { + stop("Parameter 'exp' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + + if (!any(names(exp$coords) %in% .KnownLonNames()) | + !any(names(exp$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of parameter 'exp' do not match any ", + "of the names accepted by the package.") + } + if (!all(names(exp$coords) %in% names(obs$coords))) { + stop("Coordinates names must be equal in 'exp' and in 'obs'.") + } + + lon_name <- names(exp$coords)[[which(names(exp$coords) %in% .KnownLonNames())]] + lat_name <- names(exp$coords)[[which(names(exp$coords) %in% .KnownLatNames())]] + exp_lon <- exp$coords[[lon_name]] + exp_lat <- exp$coords[[lat_name]] + obs_lon <- obs$coords[[lon_name]] + obs_lat <- obs$coords[[lat_name]] + dim_exp_lon <- dim(exp_lon) + dim_exp_lat <- dim(exp_lat) + dim_obs_lon <- dim(obs_lon) + dim_obs_lat <- dim(obs_lat) + + # Check if one of the grids is non-regular: + if ((length(dim_exp_lon) == 2) || (length(dim_obs_lon) == 2)) { + # Flatten longitudes and latitudes in case of 2-D longitudes and latitudes (Lambert grids, etc.) + if ((length(dim_exp_lon) == 2) & (length(dim_exp_lat) == 2)) { + dim(exp_lon) <- c(dim_exp_lon[1] * dim_exp_lon[2]) + dim(exp_lat) <- c(dim_exp_lat[1] * dim_exp_lat[2]) + } + if ((length(dim_obs_lon) == 2) & (length(dim_obs_lat) == 2)) { + dim(obs_lon) <- c(dim_obs_lon[1] * dim_obs_lon[2]) + dim(obs_lat) <- c(dim_obs_lat[1] * dim_obs_lat[2]) + } + # Now lat and lon arrays have 1 dimension, length npt (= nlat*nlon) + OBS_grid <- cbind(obs_lon, obs_lat) + EXP_grid <- cbind(exp_lon, exp_lat) + dist_min <- min_lon <- min_lat <- imin_lon <- imin_lat <- array(dim = nrow(OBS_grid)) + if (method == 'ADA') { + C <- cos(OBS_grid[,2] * pi/180)^2 + for (i in 1:nrow(OBS_grid)) { + dist <- (OBS_grid[i, 2] - EXP_grid[, 2])^2 + + C[i] * (OBS_grid[i, 1] - EXP_grid[, 1])^2 + dist_min[i] < -min(dist) + min_lon[i] <- EXP_grid[which.min(dist), 1] + min_lat[i] <- EXP_grid[which.min(dist), 2] + imin_lon[i] <- which(exp_lon == min_lon[i]) + imin_lat[i] <- which(exp_lat == min_lat[i]) } - if ((length(dim_obs_lon)==2) & (length(dim_obs_lat)==2)){ - dim(obs_lon) <- c(dim_obs_lon[1]*dim_obs_lon[2]) - dim(obs_lat) <- c(dim_obs_lat[1]*dim_obs_lat[2]) + } else if (method == 'simple') { + for (i in 1:nrow(OBS_grid)) { + dist <- (OBS_grid[i, 2] - EXP_grid[, 2])^2 + (OBS_grid[i, 1] - EXP_grid[, 1])^2 + dist_min[i] <- min(dist) + min_lon[i] <- EXP_grid[which.min(dist), 1] + min_lat[i] <- EXP_grid[which.min(dist), 2] + imin_lon[i] < -which(exp_lon == min_lon[i]) + imin_lat[i] <- which(exp_lat == min_lat[i]) } - # Now lat and lon arrays have 1 dimension, length npt (= nlat*nlon) - OBS_grid <- cbind(obs_lon,obs_lat) - EXP_grid <- cbind(exp_lon,exp_lat) - dist_min<-min_lon<-min_lat<-imin_lon<-imin_lat<-array(dim=nrow(OBS_grid)) - if (method == 'ADA'){ - C<-cos(OBS_grid[,2]*pi/180)^2 - for (i in 1:nrow(OBS_grid)){ - dist<-(OBS_grid[i,2]-EXP_grid[,2])^2+C[i]*(OBS_grid[i,1]-EXP_grid[,1])^2 - dist_min[i]<-min(dist) - min_lon[i]<-EXP_grid[which.min(dist),1] - min_lat[i]<-EXP_grid[which.min(dist),2] - imin_lon[i]<-which(exp_lon==min_lon[i]) - imin_lat[i]<-which(exp_lat==min_lat[i]) - } - } else if (method == 'simple'){ - for (i in 1:nrow(OBS_grid)){ - dist<-(OBS_grid[i,2]-EXP_grid[,2])^2+(OBS_grid[i,1]-EXP_grid[,1])^2 - dist_min[i]<-min(dist) - min_lon[i]<-EXP_grid[which.min(dist),1] - min_lat[i]<-EXP_grid[which.min(dist),2] - imin_lon[i]<-which(exp_lon==min_lon[i]) - imin_lat[i]<-which(exp_lat==min_lat[i]) - } - } else if (method == 'radius'){ - R <- 6371e3 # metres, Earth radius - EXP_gridr<-EXP_grid*pi/180 - OBS_gridr<-OBS_grid*pi/180 - for (i in 1:nrow(OBS_grid)){ - a<-sin((OBS_gridr[i,2]-EXP_gridr[,2])/2)^2 + cos(OBS_gridr[i,2])*cos(EXP_gridr[,2])*sin((OBS_gridr[i,1]-EXP_gridr[,1])/2)^2 - c<-2*atan2(sqrt(a),sqrt(1-a)) - dist<-R*c - dist_min[i]<-min(dist) - min_lon[i]<-EXP_grid[which.min(dist),1] - min_lat[i]<-EXP_grid[which.min(dist),2] - imin_lon[i]<-which(exp_lon==min_lon[i]) - imin_lat[i]<-which(exp_lat==min_lat[i]) - } - } else { - stop("AdamontNearestNeighbors supports method = 'ADA', 'simple' or 'radius' only.") + } else if (method == 'radius') { + R <- 6371e3 # metres, Earth radius + EXP_gridr <- EXP_grid * pi/180 + OBS_gridr <- OBS_grid * pi/180 + for (i in 1:nrow(OBS_grid)) { + a <- sin((OBS_gridr[i,2] - EXP_gridr[,2])/2)^2 + cos(OBS_gridr[i, 2]) * + cos(EXP_gridr[, 2]) * sin((OBS_gridr[i, 1] - EXP_gridr[, 1])/2)^2 + c <- 2*atan2(sqrt(a), sqrt(1 - a)) + dist <- R*c + dist_min[i] <- min(dist) + min_lon[i] <- EXP_grid[which.min(dist), 1] + min_lat[i] <- EXP_grid[which.min(dist), 2] + imin_lon[i] <- which(exp_lon == min_lon[i]) + imin_lat[i] <- which(exp_lat == min_lat[i]) } - - # Reshape outputs to original grid - dim(min_lon)=dim_obs_lon - dim(min_lat)=dim_obs_lat - dim(imin_lon)=dim_obs_lon - dim(imin_lat)=dim_obs_lat + } else { + stop("AdamontNearestNeighbors supports method = 'ADA', 'simple' or 'radius' only.") + } + + # Reshape outputs to original grid + dim(min_lon)=dim_obs_lon + dim(min_lat)=dim_obs_lat + dim(imin_lon)=dim_obs_lon + dim(imin_lat)=dim_obs_lat - } else { - # Regular lon/lat grid case: has been handled by CST_Load() - stop("AdamontNearestNeighbors is meant for non-regular lat/lon grids; use e.g. CST_Load to interpolate exp onto obs grid") - } + } else { + # Regular lon/lat grid case: has been handled by CST_Load() + stop(paste0("AdamontNearestNeighbors is meant for non-regular lat/lon ", + "grids; use e.g. CST_Load to interpolate exp onto obs grid")) + } - NN=list(min_lon=min_lon, min_lat=min_lat, imin_lon=imin_lon, imin_lat=imin_lat) + NN = list(min_lon = min_lon, min_lat = min_lat, imin_lon = imin_lon, + imin_lat = imin_lat) - return(NN) + return(NN) } diff --git a/R/CST_Analogs.R b/R/CST_Analogs.R index c13fb4a19ca5f714c0cd30114e4996f4b3eca51e..b6cbfa4e3fb5f4764985a6ae0ec13db84069274b 100644 --- a/R/CST_Analogs.R +++ b/R/CST_Analogs.R @@ -41,7 +41,9 @@ #' criterias. If parameter 'expVar' is not provided, the function will return #' the expL analog. The element 'data' in the 's2dv_cube' object must have, at #' least, latitudinal and longitudinal dimensions. The object is expect to be -#' already subset for the desired large scale region. +#' already subset for the desired large scale region. Latitudinal dimension +#' accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. Longitudinal +#' dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 'nav_lon'. #'@param obsL An 's2dv_cube' object containing the observational field on the #' large scale. The element 'data' in the 's2dv_cube' object must have the same #' latitudinal and longitudinal dimensions as parameter 'expL' and a temporal @@ -72,10 +74,10 @@ #' time_obsL), by default time_expL will be removed during the search of analogs. #'@param time_expL A character string indicating the date of the experiment #' in the same format than time_obsL (i.e. "yyyy-mm-dd"). By default it is NULL -#' and dates are taken from element \code{$Dates$start} from expL. +#' and dates are taken from element \code{$attrs$Dates} from expL. #'@param time_obsL A character string indicating the date of the observations #' in the date format (i.e. "yyyy-mm-dd"). By default it is NULL and dates are -#' taken from element \code{$Dates$start} from obsL. +#' taken from element \code{$attrs$Dates} from obsL. #'@param region A vector of length four indicating the minimum longitude, #' the maximum longitude, the minimum latitude and the maximum latitude. #'@param nAnalogs Number of Analogs to be selected to apply the criterias @@ -108,17 +110,22 @@ #'elements 'analogs', 'metric' and 'dates'. #'@examples #'expL <- rnorm(1:200) -#'dim(expL) <- c(member = 10,lat = 4, lon = 5) -#'obsL <- c(rnorm(1:180),expL[1,,]*1.2) -#'dim(obsL) <- c(time = 10,lat = 4, lon = 5) -#'time_obsL <- paste(rep("01", 10), rep("01", 10), 1994:2003, sep = "-") +#'dim(expL) <- c(member = 10, lat = 4, lon = 5) +#'obsL <- c(rnorm(1:180), expL[1, , ]*1.2) +#'dim(obsL) <- c(time = 10, lat = 4, lon = 5) +#'time_obsL <- as.POSIXct(paste(rep("01", 10), rep("01", 10), 1994:2003, sep = "-"), +#' format = "%d-%m-%y") +#'dim(time_obsL) <- c(time = 10) #'time_expL <- time_obsL[1] -#'lon <- seq(-1,5,1.5) -#'lat <- seq(30,35,1.5) -#'expL <- s2dv_cube(data = expL, lat = lat, lon = lon, -#' Dates = list(start = time_expL, end = time_expL)) -#'obsL <- s2dv_cube(data = obsL, lat = lat, lon = lon, -#' Dates = list(start = time_obsL, end = time_obsL)) +#'lon <- seq(-1, 5, 1.5) +#'lat <- seq(30, 35, 1.5) +#'coords <- list(lon = seq(-1, 5, 1.5), lat = seq(30, 35, 1.5)) +#'attrs_expL <- list(Dates = time_expL) +#'attrs_obsL <- list(Dates = time_obsL) +#'expL <- list(data = expL, coords = coords, attrs = attrs_expL) +#'obsL <- list(data = obsL, coords = coords, attrs = attrs_obsL) +#'class(expL) <- 's2dv_cube' +#'class(obsL) <- 's2dv_cube' #'region <- c(min(lon), max(lon), min(lat), max(lat)) #'downscaled_field <- CST_Analogs(expL = expL, obsL = obsL, region = region) #' @@ -131,6 +138,8 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, time_expL = NULL, time_obsL = NULL, nAnalogs = NULL, AnalogsInfo = FALSE, ncores = NULL) { + + # Check 's2dv_cube' if (!inherits(expL, "s2dv_cube") || !inherits(obsL, "s2dv_cube")) { stop("Parameter 'expL' and 'obsL' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -143,6 +152,41 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, stop("Parameter 'obsVar' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } + + # Check 'obsL' object structure + if (!all(c('data', 'coords', 'attrs') %in% names(obsL))) { + stop("Parameter 'obsL' must have 'data', 'coords' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + } + + if (!any(names(obsL$coords) %in% .KnownLonNames()) | + !any(names(obsL$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of parameter 'obsL' do not match any ", + "of the names accepted by the package.") + } + + lon_name <- names(obsL$coords)[[which(names(obsL$coords) %in% .KnownLonNames())]] + lat_name <- names(obsL$coords)[[which(names(obsL$coords) %in% .KnownLatNames())]] + + # Check 'obsVar' object structure + if (!is.null(obsVar)) { + if (!all(c('data', 'coords', 'attrs') %in% names(obsVar))) { + stop("Parameter 'obsVar' must have 'data', 'coords' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + } + if (!any(names(obsVar$coords) %in% .KnownLonNames()) | + !any(names(obsVar$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of parameter 'obsVar' do not match any ", + "of the names accepted by the package.") + } + lonVar <- obsVar$coords[[which(names(obsVar$coords) %in% .KnownLonNames())]] + latVar <- obsVar$coords[[which(names(obsVar$coords) %in% .KnownLatNames())]] + } else { + lonVar <- NULL + latVar <- NULL + } + + # Check temporal dimensions if (any(names(dim(obsL$data)) %in% 'sdate')) { if (any(names(dim(obsL$data)) %in% 'ftime')) { obsL <- CST_MergeDims(obsL, c('ftime', 'sdate'), rename_dim = 'time') @@ -160,36 +204,47 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, } } if (is.null(time_expL)) { - time_expL <- expL$Dates$start + time_expL <- expL$attrs$Dates } if (is.null(time_obsL)) { - time_obsL <- obsL$Dates$start + time_obsL <- obsL$attrs$Dates } + res <- Analogs(expL$data, obsL$data, time_obsL = time_obsL, - time_expL = time_expL, lonL = expL$lon, - latL = expL$lat, expVar = expVar$data, + time_expL = time_expL, + lonL = as.vector(obsL$coords[[lon_name]]), + latL = as.vector(obsL$coords[[lat_name]]), + expVar = expVar$data, obsVar = obsVar$data, criteria = criteria, excludeTime = excludeTime, region = region, - lonVar = as.vector(obsVar$lon), latVar = as.vector(obsVar$lat), + lonVar = as.vector(lonVar), latVar = as.vector(latVar), nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, ncores = ncores) + if (AnalogsInfo) { if (is.numeric(res$dates)) { res$dates <- as.POSIXct(res$dates, origin = '1970-01-01', tz = 'UTC') } } + expL$data <- res - if (is.null(region)) { - expL$lon <- obsL$lon - expL$lat <- obsL$lat - } else { - expL$lon <- SelBox(obsL$data, lon = as.vector(obsL$lon), - lat = as.vector(obsL$lat), - region = region)$lon - expL$lat <- SelBox(obsL$data, lon = as.vector(obsL$lon), - lat = as.vector(obsL$lat), - region = region)$lat + + if (!is.null(obsL$coords[[lon_name]]) | !is.null(obsL$coords[[lat_name]])) { + if (is.null(region)) { + expL$coords[[lon_name]] <- obsL$coords[[lon_name]] + expL$coords[[lat_name]] <- obsL$coords[[lat_name]] + } else { + expL$coords[[lon_name]] <- SelBox(obsL$data, + lon = as.vector(obsL$coords[[lon_name]]), + lat = as.vector(obsL$coords[[lat_name]]), + region = region)$lon + expL$coords[[lat_name]] <- SelBox(obsL$data, + lon = as.vector(obsL$coords[[lon_name]]), + lat = as.vector(obsL$coords[[lat_name]]), + region = region)$lat + } } + return(expL) } @@ -240,7 +295,10 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' all the criterias. If parameter 'expVar' is not provided, the function will #' return the expL analog. The element 'data' in the 's2dv_cube' object must #' have, at least, latitudinal and longitudinal dimensions. The object is -#' expect to be already subset for the desired large scale region. +#' expect to be already subset for the desired large scale region. Latitudinal +#' dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. +#' Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', +#' 'nav_lon'. #'@param obsL An array of N named dimensions containing the observational field #' on the large scale. The element 'data' in the 's2dv_cube' object must have #' the same latitudinal and longitudinal dimensions as parameter 'expL' and a @@ -319,23 +377,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #'downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, obsVar = obs.pr, #' time_obsL = time_obsSLP, time_expL = "01-01-1994") #' -#'# Example 3: List of best Analogs using criteria 'Large_dist' and a single -#'obsSLP <- c(rnorm(1:1980), expSLP * 1.5) -#'dim(obsSLP) <- c(lat = 4, lon = 5, time = 100) -#'time_obsSLP <- paste(rep("01", 100), rep("01", 100), 1920 : 2019, sep = "-") -#'downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, time_obsSLP, -#' nAnalogs = 5, time_expL = "01-01-2003", -#' AnalogsInfo = TRUE, excludeTime = "01-01-2003") -#' -#'# Example 4: List of best Analogs using criteria 'Large_dist' and 2 variables: -#'obsSLP <- c(rnorm(1:180), expSLP * 2) -#'dim(obsSLP) <- c(lat = 4, lon = 5, time = 10) -#'time_obsSLP <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-") -#'downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, obsVar = obs.pr, -#' time_obsL = time_obsSLP, nAnalogs = 5, -#' time_expL = "01-10-2003", AnalogsInfo = TRUE) -#' -#'# Example 5: Downscaling using criteria 'Local_dist' and 2 variables: +#'# Example 3: Downscaling using criteria 'Local_dist' and 2 variables: #'# analogs of local scale using criteria 2 #'region = c(lonmin = -1 ,lonmax = 2, latmin = 30, latmax = 33) #'Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, @@ -344,21 +386,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' region = region,time_expL = "01-10-2000", #' nAnalogs = 10, AnalogsInfo = TRUE) #' -#'# Example 6: list of best analogs using criteria 'Local_dist' and 2 -#'Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, -#' criteria = "Local_dist", lonL = seq(-1, 5, 1.5), -#' latL = seq(30, 35, 1.5), region = region, -#' time_expL = "01-10-2000", nAnalogs = 5, -#' AnalogsInfo = TRUE) -#' -#'# Example 7: Downscaling using Local_dist criteria -#'Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, -#' criteria = "Local_dist", lonL = seq(-1, 5, 1.5), -#' latL = seq(30, 35, 1.5), region = region, -#' time_expL = "01-10-2000", -#' nAnalogs = 10, AnalogsInfo = FALSE) -#' -#'# Example 8: Downscaling using criteria 'Local_cor' and 2 variables: +#'# Example 4: Downscaling using criteria 'Local_cor' and 2 variables: #'exp.pr <- c(rnorm(1:20) * 0.001) #'dim(exp.pr) <- dim(expSLP) #'Local_scalecor <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, @@ -367,15 +395,8 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' time_expL = "01-10-2000", latL = seq(30, 35, 1.5), #' lonVar = seq(-1, 5, 1.5), latVar = seq(30, 35, 1.5), #' nAnalogs = 8, region = region, AnalogsInfo = FALSE) -#'# same but without imposing nAnalogs, so nAnalogs will be set by default as 10 -#'Local_scalecor <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, -#' obsVar = obs.pr, expVar = exp.pr, -#' lonVar = seq(-1, 5, 1.5), latVar = seq(30, 35, 1.5), -#' criteria = "Local_cor", lonL = seq(-1,5,1.5), -#' time_expL = "01-10-2000", latL = seq(30, 35, 1.5), -#' region = region, AnalogsInfo = TRUE) #' -#'#'Example 9: List of best analogs in the three criterias Large_dist, +#'# Example 5: List of best analogs in the three criterias Large_dist, #'Large_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, #' criteria = "Large_dist", time_expL = "01-10-2000", #' nAnalogs = 7, AnalogsInfo = TRUE) @@ -390,19 +411,6 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' lonVar = seq(-1, 5, 1.5), latVar = seq(30, 35, 1.5), #' nAnalogs = 7, region = region, #' AnalogsInfo = TRUE) -#'#Example 10: Downscaling using criteria 'Large_dist' and a single variable, -#'# more than 1 sdate: -#'expSLP <- rnorm(1:40) -#'dim(expSLP) <- c(sdate = 2, lat = 4, lon = 5) -#'obsSLP <- c(rnorm(1:180), expSLP * 1.2) -#'dim(obsSLP) <- c(time = 11, lat = 4, lon = 5) -#'time_obsSLP <- paste(rep("01", 11), rep("01", 11), 1993 : 2003, sep = "-") -#'time_expSLP <- paste(rep("01", 2), rep("01", 2), 1994 : 1995, sep = "-") -#'excludeTime <- c("01-01-2003", "01-01-2003") -#'dim(excludeTime) <- c(sdate = 2) -#'downscale_field_exclude <- Analogs(expL = expSLP, obsL = obsSLP, -#' time_obsL = time_obsSLP, time_expL = time_expSLP, -#' excludeTime = excludeTime, AnalogsInfo = TRUE) #'@import multiApply #'@import abind #'@importFrom ClimProjDiags SelBox Subset @@ -441,6 +449,17 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, if (!any(.KnownLatNames() %in% obsdims) | !any(.KnownLatNames() %in% expdims)) { stop("Parameter 'expL' and 'obsL' must have latitudinal dimension.") } + + # Know spatial coordinates names + if (!any(obsdims %in% .KnownLonNames()) | + !any(obsdims %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + } + + lon_name <- obsdims[[which(obsdims %in% .KnownLonNames())]] + lat_name <- obsdims[[which(obsdims %in% .KnownLatNames())]] + # criteria if (!criteria %in% c('Large_dist', 'Local_dist', 'Local_cor')) { stop("Parameter 'criteria' can only be: 'Large_dist', 'Local_dist' or 'Local_cor'.") @@ -465,7 +484,8 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, stop("Parameters 'lonL' and 'latL' need to be a vector.") } } - } else if (criteria == "Local_cor") { + } + if (criteria == "Local_cor") { if (is.null(lonVar) | is.null(latVar)) { stop("Parameters 'lonVar' and 'latVar' cannot be NULL.") } @@ -665,14 +685,19 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, } } names(dim(expL)) <- replace_repeat_dimnames(names(dim(expL)), - names(dim(obsL))) + names(dim(obsL)), + lon_name = lon_name, + lat_name = lat_name) if (!is.null(expVar)) { names(dim(expVar)) <- replace_repeat_dimnames(names(dim(expVar)), - names(dim(obsVar))) + names(dim(obsVar)), + lon_name = lon_name, + lat_name = lat_name) } if (is.null(excludeTime)) { excludeTime <- vector(mode = "character", length = length(time_expL)) + } if (length(time_expL) == length(excludeTime)) { if (any(names(dim(expL)) %in% c('sdate_exp'))) { @@ -699,68 +724,73 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, if (!AnalogsInfo) { if (is.null(obsVar)) { res <- Apply(list(expL, obsL), - target_dims = list(c('lat', 'lon'), c('time','lat','lon')), + target_dims = list(c(lat_name, lon_name), c('time', lat_name, lon_name)), fun = .analogs, time_obsL, expVar = expVar, time_expL = time_expL, excludeTime = excludeTime, obsVar = obsVar, criteria = criteria, lonL = lonL, latL = latL, lonVar = lonVar, latVar = latVar, region = region, - nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, - output_dims = c('nAnalogs', 'lat', 'lon'), + nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, + lon_name = lon_name, lat_name = lat_name, + output_dims = c('nAnalogs', lat_name, lon_name), ncores = ncores)$output1 } else if (!is.null(obsVar) && is.null(expVar)) { res <- Apply(list(expL, obsL, obsVar), - target_dims = list(c('lat', 'lon'), c('time','lat','lon'), - c('time', 'lat', 'lon')), + target_dims = list(c(lat_name, lon_name), c('time', lat_name, lon_name), + c('time', lat_name, lon_name)), fun = .analogs, time_obsL, time_expL = time_expL, excludeTime = excludeTime, expVar = expVar, criteria = criteria, lonL = lonL, latL = latL, lonVar = lonVar, latVar = latVar, region = region, nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, - output_dims = c('nAnalogs', 'lat', 'lon'), + lon_name = lon_name, lat_name = lat_name, + output_dims = c('nAnalogs', lat_name, lon_name), ncores = ncores)$output1 } else if (!is.null(obsVar) && !is.null(expVar)) { res <- Apply(list(expL, obsL, obsVar, expVar), - target_dims = list(c('lat', 'lon'), c('time','lat','lon'), - c('time','lat','lon'), c('lat','lon')), + target_dims = list(c(lat_name, lon_name), c('time', lat_name, lon_name), + c('time', lat_name, lon_name), c(lat_name, lon_name)), fun = .analogs, criteria = criteria, time_obsL, time_expL = time_expL, excludeTime = excludeTime, lonL = lonL, latL = latL, lonVar = lonVar, latVar = latVar, region = region, - nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, - output_dims = c('nAnalogs', 'lat', 'lon'), + nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, + lon_name = lon_name, lat_name = lat_name, + output_dims = c('nAnalogs', lat_name, lon_name), ncores = ncores)$output1 } } else { if (is.null(obsVar)) { res <- Apply(list(expL, obsL), - target_dims = list(c('lat', 'lon'), c('time','lat','lon')), + target_dims = list(c(lat_name, lon_name), c('time', lat_name, lon_name)), fun = .analogs, time_obsL, expVar = expVar, time_expL = time_expL, excludeTime = excludeTime, obsVar = obsVar, criteria = criteria, lonL = lonL, latL = latL, lonVar = lonVar, latVar = latVar, region = region, - nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, - output_dims = list(fields = c('nAnalogs', 'lat', 'lon'), + nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, + lon_name = lon_name, lat_name = lat_name, + output_dims = list(fields = c('nAnalogs', lat_name, lon_name), analogs = c('nAnalogs'), metric = c('nAnalogs', 'metric'), dates = c('nAnalogs')), ncores = ncores) } else if (!is.null(obsVar) && is.null(expVar)) { res <- Apply(list(expL, obsL, obsVar), - target_dims = list(c('lat', 'lon'), c('time','lat','lon'), - c('time', 'lat', 'lon')), + target_dims = list(c(lat_name, lon_name), c('time', lat_name, lon_name), + c('time', lat_name, lon_name)), fun = .analogs, time_obsL, time_expL = time_expL, excludeTime = excludeTime, expVar = expVar, criteria = criteria, lonL = lonL, latL = latL, lonVar = lonVar, latVar = latVar, region = region, - nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, - output_dims = list(fields = c('nAnalogs', 'lat', 'lon'), + nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, + lon_name = lon_name, lat_name = lat_name, + output_dims = list(fields = c('nAnalogs', lat_name, lon_name), analogs = c('nAnalogs'), metric = c('nAnalogs', 'metric'), dates = c('nAnalogs')), @@ -768,15 +798,16 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, } else if (!is.null(obsVar) && !is.null(expVar)) { res <- Apply(list(expL, obsL, obsVar, expVar), - target_dims = list(c('lat', 'lon'), c('time', 'lat', 'lon'), - c('time', 'lat', 'lon'), c('lat', 'lon')), + target_dims = list(c(lat_name, lon_name), c('time', lat_name, lon_name), + c('time', lat_name, lon_name), c(lat_name, lon_name)), fun = .analogs, time_obsL, criteria = criteria, time_expL = time_expL, excludeTime = excludeTime, lonL = lonL, latL = latL, lonVar = lonVar, latVar = latVar, region = region, - nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, - output_dims = list(fields = c('nAnalogs', 'lat', 'lon'), + nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, + lon_name = lon_name, lat_name = lat_name, + output_dims = list(fields = c('nAnalogs', lat_name, lon_name), analogs = c('nAnalogs'), metric = c('nAnalogs', 'metric'), dates = c('nAnalogs')), @@ -790,7 +821,8 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, time_obsL, criteria = "Large_dist", lonL = NULL, latL = NULL, lonVar = NULL, latVar = NULL, region = NULL, - nAnalogs = NULL, AnalogsInfo = FALSE) { + nAnalogs = NULL, AnalogsInfo = FALSE, lon_name = 'lon', + lat_name = 'lat') { if (all(excludeTime == "")) { excludeTime = NULL @@ -868,7 +900,8 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, AnalogsInfo = AnalogsInfo, nAnalogs = nAnalogs, lonL = lonL, latL = latL, lonVar = lonVar, - latVar = latVar, region = region) + latVar = latVar, region = region, + lon_name = lon_name, lat_name = lat_name) if (AnalogsInfo == TRUE) { return(list(AnalogsFields = Analog_result$AnalogsFields, AnalogsInfo = Analog_result$Analog, @@ -881,15 +914,17 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, FindAnalog <- function(expL, obsL, time_obsL, expVar, obsVar, criteria, lonL, latL, lonVar, latVar, region, nAnalogs = nAnalogs, - AnalogsInfo = AnalogsInfo) { + AnalogsInfo = AnalogsInfo, lon_name = 'lon', lat_name = 'lat') { position <- Select(expL = expL, obsL = obsL, expVar = expVar, obsVar = obsVar, criteria = criteria, lonL = lonL, latL = latL, lonVar = lonVar, - latVar = latVar, region = region)$position + latVar = latVar, region = region, + lon_name = lon_name, lat_name = lat_name)$position metrics <- Select(expL = expL, obsL = obsL, expVar = expVar, obsVar = obsVar, criteria = criteria, lonL = lonL, latL = latL, lonVar = lonVar, - latVar = latVar, region = region)$metric.original + latVar = latVar, region = region, + lon_name = lon_name, lat_name = lat_name)$metric.original best <- Apply(list(position), target_dims = c('time', 'pos'), fun = BestAnalog, criteria = criteria, AnalogsInfo = AnalogsInfo, nAnalogs = nAnalogs)$output1 @@ -926,8 +961,8 @@ FindAnalog <- function(expL, obsL, time_obsL, expVar, obsVar, criteria, } } - lon_dim <- which(names(dim(Analogs_fields)) == 'lon') - lat_dim <- which(names(dim(Analogs_fields)) == 'lat') + lon_dim <- which(names(dim(Analogs_fields)) == lon_name) + lat_dim <- which(names(dim(Analogs_fields)) == lat_name) Analogs_metrics <- Subset(metrics, along = which(names(dim(metrics)) == 'time'), @@ -1030,11 +1065,15 @@ BestAnalog <- function(position, nAnalogs = nAnalogs, AnalogsInfo = FALSE, } Select <- function(expL, obsL, expVar = NULL, obsVar = NULL, criteria = "Large_dist", lonL = NULL, latL = NULL, - lonVar = NULL, latVar = NULL, region = NULL) { + lonVar = NULL, latVar = NULL, region = NULL, + lon_name = 'lon', lat_name = 'lat') { names(dim(expL)) <- replace_repeat_dimnames(names(dim(expL)), - names(dim(obsL))) - metric1 <- Apply(list(obsL), target_dims = list(c('lat', 'lon')), - fun = .select, expL, metric = "dist")$output1 + names(dim(obsL)), + lon_name = lon_name, + lat_name = lat_name) + metric1 <- Apply(list(obsL), target_dims = list(c(lat_name, lon_name)), + fun = .select, expL, metric = "dist", + lon_name = lon_name, lat_name = lat_name)$output1 metric1.original = metric1 if (length(dim(metric1)) > 1) { dim_time_obs <- which(names(dim(metric1)) == 'time' | @@ -1065,8 +1104,9 @@ Select <- function(expL, obsL, expVar = NULL, obsVar = NULL, if (criteria == "Local_dist" | criteria == "Local_cor") { obs <- SelBox(obsL, lon = lonL, lat = latL, region = region)$data exp <- SelBox(expL, lon = lonL, lat = latL, region = region)$data - metric2 <- Apply(list(obs), target_dims = list(c('lat', 'lon')), - fun = .select, exp, metric = "dist")$output1 + metric2 <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)), + fun = .select, exp, metric = "dist", + lon_name = lon_name, lat_name = lat_name)$output1 metric2.original = metric2 dim(metric2) <- c(dim(metric2), metric=1) margins <- c(1 : (length(dim(metric2))))[-dim_time_obs] @@ -1090,8 +1130,9 @@ Select <- function(expL, obsL, expVar = NULL, obsVar = NULL, if (criteria == "Local_cor") { obs <- SelBox(obsVar, lon = lonVar, lat = latVar, region = region)$data exp <- SelBox(expVar, lon = lonVar, lat = latVar, region = region)$data - metric3 <- Apply(list(obs), target_dims = list(c('lat', 'lon')), - fun = .select, exp, metric = "cor")$output1 + metric3 <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)), + fun = .select, exp, metric = "cor", + lon_name = lon_name, lat_name = lat_name)$output1 metric3.original = metric3 dim(metric3) <- c(dim(metric3), metric=1) margins <- c(1 : (length(dim(metric3))))[-dim_time_obs] @@ -1117,12 +1158,13 @@ Select <- function(expL, obsL, expVar = NULL, obsVar = NULL, "'Local_dist','Local_cor'.") } } -.select <- function(exp, obs, metric = "dist") { +.select <- function(exp, obs, metric = "dist", + lon_name = 'lon', lat_name = 'lat') { if (metric == "dist") { - result <- Apply(list(obs), target_dims = list(c('lat', 'lon')), + result <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)), fun = function(x) {sqrt(sum((x - exp) ^ 2, na.rm = TRUE))})$output1 } else if (metric == "cor") { - result <- Apply(list(obs), target_dims = list(c('lat', 'lon')), + result <- Apply(list(obs), target_dims = list(c(lat_name, lon_name)), fun = function(x) {cor(as.vector(x), as.vector(exp), method = "spearman")})$output1 diff --git a/R/CST_Anomaly.R b/R/CST_Anomaly.R index f38e39b050f7c46be452ac6e6571542c465264b9..489835c67e4fd4cceaa0d02a185a37c8635ac5d4 100644 --- a/R/CST_Anomaly.R +++ b/R/CST_Anomaly.R @@ -41,15 +41,15 @@ #'in CSTools. #' #'@examples -#'# Example 1: #'mod <- 1 : (2 * 3 * 4 * 5 * 6 * 7) #'dim(mod) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) #'obs <- 1 : (1 * 1 * 4 * 5 * 6 * 7) #'dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp <- list(data = mod, lat = lat, lon = lon) -#'obs <- list(data = obs, lat = lat, lon = lon) +#'coords <- list(lon = lon, lat = lat) +#'exp <- list(data = mod, coords = coords) +#'obs <- list(data = obs, coords = coords) #'attr(exp, 'class') <- 's2dv_cube' #'attr(obs, 'class') <- 's2dv_cube' #' @@ -60,10 +60,11 @@ #'@import multiApply #'@importFrom s2dv InsertDim Clim Ano_CrossValid Reorder #'@export -CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', cross = FALSE, - memb_dim = 'member', memb = TRUE, dat_dim = c('dataset', 'member'), - filter_span = NULL, ftime_dim = 'ftime', ncores = NULL) { - # s2dv_cube +CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', + cross = FALSE, memb_dim = 'member', memb = TRUE, + dat_dim = c('dataset', 'member'), filter_span = NULL, + ftime_dim = 'ftime', ncores = NULL) { + # Check 's2dv_cube' if (!inherits(exp, 's2dv_cube') & !is.null(exp) || !inherits(obs, 's2dv_cube') & !is.null(obs)) { stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", @@ -84,12 +85,12 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', cross = FALS case_exp = 1 warning("Parameter 'obs' is not provided and 'exp' will be used instead.") } - if(any(is.null(names(dim(exp$data))))| any(nchar(names(dim(exp$data))) == 0) | - any(is.null(names(dim(obs$data))))| any(nchar(names(dim(obs$data))) == 0)) { + if (any(is.null(names(dim(exp$data))))| any(nchar(names(dim(exp$data))) == 0) | + any(is.null(names(dim(obs$data))))| any(nchar(names(dim(obs$data))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names in element 'data'.") } - if(!all(names(dim(exp$data)) %in% names(dim(obs$data))) | - !all(names(dim(obs$data)) %in% names(dim(exp$data)))) { + if (!all(names(dim(exp$data)) %in% names(dim(obs$data))) | + !all(names(dim(obs$data)) %in% names(dim(exp$data)))) { stop("Parameter 'exp' and 'obs' must have same dimension names in element 'data'.") } dim_exp <- dim(exp$data) @@ -112,18 +113,18 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', cross = FALS "'exp' and 'obs' must be greater than 1.") } # cross - if (!is.logical(cross) | !is.logical(memb) ) { + if (!is.logical(cross) | !is.logical(memb)) { stop("Parameters 'cross' and 'memb' must be logical.") } - if (length(cross) > 1 | length(memb) > 1 ) { + if (length(cross) > 1 | length(memb) > 1) { cross <- cross[1] - warning("Parameter 'cross' has length greater than 1 and only the first element", + warning("Parameter 'cross' has length greater than 1 and only the first element ", "will be used.") } # memb if (length(memb) > 1) { memb <- memb[1] - warning("Parameter 'memb' has length greater than 1 and only the first element", + warning("Parameter 'memb' has length greater than 1 and only the first element ", "will be used.") } # memb_dim @@ -141,15 +142,15 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', cross = FALS 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 in element 'data'.", - " Set it as NULL if there is no dataset dimension.") + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension in element 'data'. ", + "Set it as NULL if there is no dataset dimension.") } } # filter_span if (!is.null(filter_span)) { if (!is.numeric(filter_span)) { - warning("Paramater 'filter_span' is not numeric and any filter", - " is being applied.") + warning("Paramater 'filter_span' is not numeric and any filter ", + "is being applied.") filter_span <- NULL } # ncores @@ -173,21 +174,15 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', cross = FALS # With cross-validation if (cross) { - ano <- Ano_CrossValid(exp = exp$data, obs = obs$data, - time_dim = dim_anom, - memb_dim = memb_dim, - memb = memb, - dat_dim = dat_dim, - ncores = ncores) + ano <- Ano_CrossValid(exp = exp$data, obs = obs$data, time_dim = dim_anom, + memb_dim = memb_dim, memb = memb, dat_dim = dat_dim, + ncores = ncores) # Without cross-validation } else { - tmp <- Clim(exp = exp$data, obs = obs$data, - time_dim = dim_anom, - memb_dim = memb_dim, - memb = memb, - dat_dim = dat_dim, - ncores = ncores) + tmp <- Clim(exp = exp$data, obs = obs$data, time_dim = dim_anom, + memb_dim = memb_dim, memb = memb, dat_dim = dat_dim, + ncores = ncores) if (!is.null(filter_span)) { tmp$clim_exp <- Apply(tmp$clim_exp, target_dims = c(ftime_dim), @@ -206,8 +201,8 @@ CST_Anomaly <- function(exp = NULL, obs = NULL, dim_anom = 'sdate', cross = FALS clim_exp <- tmp$clim_exp clim_obs <- tmp$clim_obs } else { - clim_exp <- InsertDim(tmp$clim_exp, 1, dim_exp[memb_dim]) - clim_obs <- InsertDim(tmp$clim_obs, 1, dim_obs[memb_dim]) + clim_exp <- InsertDim(tmp$clim_exp, 1, dim_exp[memb_dim]) + clim_obs <- InsertDim(tmp$clim_obs, 1, dim_obs[memb_dim]) } clim_exp <- InsertDim(clim_exp, 1, dim_exp[dim_anom]) clim_obs <- InsertDim(clim_obs, 1, dim_obs[dim_anom]) diff --git a/R/CST_BEI_Weighting.R b/R/CST_BEI_Weighting.R index 16c0b5d1bf49d0f54e145692a4b9e4a1ec9de98b..885e1d84714dfe1ea1ed40f2c2659d2434ea72cf 100644 --- a/R/CST_BEI_Weighting.R +++ b/R/CST_BEI_Weighting.R @@ -39,6 +39,8 @@ #' means computing with weighted members. #'@param time_dim_name A character string indicating the name of the #' temporal dimension, by default 'time'. +#'@param memb_dim A character string indicating the name of the +#' member dimension, by default 'member'. #' #'@return CST_BEI_Weighting() returns a CSTools object (i.e., of the #'class 's2dv_cube'). @@ -56,22 +58,17 @@ #'var_exp <- list(data = var_exp) #'class(var_exp) <- 's2dv_cube' #'res_CST <- CST_BEI_Weighting(var_exp, aweights) -#'dim(res_CST$data) -#'# time lat lon dataset -#'# 2 3 2 2 #'@export CST_BEI_Weighting <- function(var_exp, aweights, terciles = NULL, - type = 'ensembleMean', time_dim_name = 'time') { + type = 'ensembleMean', time_dim_name = 'time', + memb_dim = 'member') { - if (!is.character(time_dim_name)) { - stop("Parameter 'time_dim_name' must be a character string indicating", - " the name of the temporal dimension.") - } - if (length(time_dim_name) > 1) { - warning("Parameter 'time_dim_name' has length greater than 1 and ", - "only the first element will be used.") - time_dim_name <- time_dim_name[1] + # s2dv_cube + if (!inherits(var_exp, "s2dv_cube")) { + stop("Parameter 'var_exp' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") } + # type if (!is.character(type)) { stop("Parameter 'type' must be a character string, 'probs' or ", "'ensembleMean', indicating the type of output.") @@ -81,70 +78,19 @@ CST_BEI_Weighting <- function(var_exp, aweights, terciles = NULL, "only the first element will be used.") type <- type[1] } - if (!inherits(var_exp, 's2dv_cube')) { - stop("Parameter 'var_exp' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } - if (!is.null(terciles)){ - if(!is.array(terciles)){ - stop("Parameter 'terciles' must be an array.") - } - if (is.null(names(dim(terciles)))) { - stop("Parameters 'terciles' should have dimmension names.") - } - if(!('tercil' %in% names(dim(terciles)))) { - stop("Parameter 'terciles' must have dimension 'tercil'.") - } - if (dim(terciles)['tercil'] != 2) { - stop("Length of dimension 'tercil' ", - "of parameter 'terciles' must be equal to 2.") - } - if(time_dim_name %in% names(dim(terciles))) { - stop("Parameter 'terciles' must not have temporal dimension.") - } - if('member' %in% names(dim(terciles))) { - stop("Parameter 'terciles' must not have dimension 'member'.") - } - } - if (!is.array(aweights)) { - stop("Parameter 'aweights' must be an array.") - } - if (is.null(names(dim(var_exp$data))) || is.null(names(dim(aweights)))) { - stop("Element 'data' from parameter 'var_exp' and parameter 'aweights'", - " should have dimmension names.") - } - if(!(time_dim_name %in% names(dim(var_exp$data)))) { - stop("Element 'data' from parameter 'var_exp' must have ", - "temporal dimension.") - } - if(!(time_dim_name %in% names(dim(aweights)))) { - stop("Parameter 'aweights' must have temporal dimension.") - } - if(!('member' %in% names(dim(var_exp$data)))) { - stop("Element 'data' from parameter 'var_exp' must have ", - "dimension 'member'.") - } - if(!('member' %in% names(dim(aweights)))) { - stop("Parameter 'aweights' must have dimension 'member'.") - } - if (dim(var_exp$data)[time_dim_name] != dim(aweights)[time_dim_name]) { - stop("Length of temporal dimensions ", - "of element 'data' from parameter 'var_exp' and parameter ", - "'aweights' must be equals.") - } - if (dim(var_exp$data)['member'] != dim(aweights)['member']) { - stop("Length of dimension 'member' of element 'data' from ", - "parameter 'var_exp' and parameter 'aweights' must be equals.") - } - if (type == 'ensembleMean'){ - em <- BEI_EMWeighting(var_exp$data, aweights, time_dim_name) + if (type == 'ensembleMean') { + em <- BEI_EMWeighting(var_exp$data, aweights, time_dim_name, memb_dim) var_exp$data <- em - } else if (type == 'probs'){ - if (is.null(terciles)){ - terciles <- BEI_TercilesWeighting(var_exp$data, aweights, time_dim_name) + } else if (type == 'probs') { + if (is.null(terciles)) { + terciles <- BEI_TercilesWeighting(var_exp$data, aweights, + time_dim_name = time_dim_name, + memb_dim = memb_dim) } - probs <- BEI_ProbsWeighting(var_exp$data, aweights, terciles, time_dim_name) + probs <- BEI_ProbsWeighting(var_exp$data, aweights, terciles, + time_dim_name = time_dim_name, + memb_dim = memb_dim) var_exp$data <- probs } else { stop("Parameter 'type' must be a character string ('probs' or ", @@ -153,7 +99,6 @@ CST_BEI_Weighting <- function(var_exp, aweights, terciles = NULL, return(var_exp) } - #'@title Computing the weighted ensemble means for SFSs. #'@author Eroteida Sanchez-Garcia - AEMET, \email{esanchezg@aemet.es} #'@description This function implements the computation to obtain the weighted @@ -171,36 +116,43 @@ CST_BEI_Weighting <- function(var_exp, aweights, terciles = NULL, #' (time, member), when 'time' is the temporal dimension as default. #'@param time_dim_name A character string indicating the name of the #' temporal dimension, by default 'time'. +#'@param memb_dim A character string indicating the name of the +#' member dimension, by default 'member'. #' #'@return BEI_EMWeighting() returns an array with at least one or three #'dimensions depending if the variable is spatially aggregated variable #'(as e.g. NAO index)(time) or it is spatial variable (as e.g. precipitation #'or temperature) (time, lat, lon), containing the ensemble means computing #'with weighted members. -#'@import multiApply #' #'@examples #'# Example 1 #'var_exp <- 1 : (2 * 3 * 4) #'dim(var_exp) <- c(time = 2, dataset = 3, member = 4) -#'aweights<- runif(24, min=0.001, max=0.999) +#'aweights <- runif(24, min = 0.001, max = 0.999) #'dim(aweights) <- c(time = 2, dataset = 3, member = 4) #'res <- BEI_EMWeighting(var_exp, aweights) -#'dim(res) -#'# time dataset -#'# 2 3 +#' #'# Example 2 #'var_exp <- 1 : (2 * 4 * 2 * 3) #'dim(var_exp) <- c(time = 2, member = 4, lat = 2, lon = 3) -#'aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +#'aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) #'dim(aweights) <- c(time = 2, member = 4) #'res <- BEI_EMWeighting(var_exp, aweights) -#'dim(res) -#'# time lat lon -#'# 2 2 3 #' -#'@noRd -BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time') { +#'@import multiApply +#'@export +BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time', + memb_dim = 'member') { + # var_exp + if (!is.array(var_exp)) { + stop("Parameter 'var_exp' must be an array.") + } + # aweights + if (!is.array(aweights)) { + stop("Parameter 'aweights' must be an array.") + } + # time_dim_name if (!is.character(time_dim_name)) { stop("Parameter 'time_dim_name' must be a character string indicating", " the name of the temporal dimension.") @@ -210,40 +162,39 @@ BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time') { "only the first element will be used.") time_dim_name <- time_dim_name[1] } - if (!is.array(var_exp)) { - stop("Parameter 'var_exp' must be an array.") - } - if (!is.array(aweights)) { - stop("Parameter 'aweights' must be an array.") + # memb_dim + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string indicating", + " the name of the member dimension.") } + # var_exp, aweights (2) if (is.null(names(dim(var_exp))) || is.null(names(dim(aweights)))) { - stop("Parameters 'var_exp' and 'aweights'", - " should have dimmension names.") + stop("Parameters 'var_exp' and 'aweights' should have dimension names.") } - if(!(time_dim_name %in% names(dim(var_exp)))) { + if (!(time_dim_name %in% names(dim(var_exp)))) { stop("Parameter 'var_exp' must have temporal dimension.") } - if(!(time_dim_name %in% names(dim(aweights)))) { + if (!(time_dim_name %in% names(dim(aweights)))) { stop("Parameter 'aweights' must have temporal dimension.") } - if(!('member' %in% names(dim(var_exp)))) { - stop("Parameter 'var_exp' must have temporal dimension.") + if (!(memb_dim %in% names(dim(var_exp)))) { + stop("Parameter 'var_exp' must have member dimension.") } - if(!('member' %in% names(dim(aweights)))) { - stop("Parameter 'aweights' must have temporal dimension.") + if (!(memb_dim %in% names(dim(aweights)))) { + stop("Parameter 'aweights' must have member dimension.") } if (dim(var_exp)[time_dim_name] != dim(aweights)[time_dim_name]) { - stop("Length of temporal dimensions ", - "of parameter 'var_exp' and 'aweights' must be equals.") + stop("Length of temporal dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") } - if (dim(var_exp)['member'] != dim(aweights)['member']) { - stop("Length of dimension 'member' ", + if (dim(var_exp)[memb_dim] != dim(aweights)[memb_dim]) { + stop("Length of member dimension ", "of parameter 'var_exp' and 'aweights' must be equals.") } res <- Apply(list(var_exp, aweights), - target_dims = list(c(time_dim_name,'member'), - c(time_dim_name,'member')), + target_dims = list(c(time_dim_name, memb_dim), + c(time_dim_name, memb_dim)), fun = .BEI_EMWeighting, time_dim_name)$output1 return(res) } @@ -265,9 +216,6 @@ BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time') { #'aweights <- c(0.28, 0.15, 0.69, 0.64, 0.42, 0.17) #'dim(aweights) <- c(time = 2, member = 3) #'res <- .BEI_EMWeighting(var_exp, aweights) -#'dim(res) -#'# time -#'# 2 #'@noRd .BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time') { @@ -299,6 +247,8 @@ BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time') { #' element is the upper tercile. #'@param time_dim_name A character string indicating the name of the #' temporal dimension, by default 'time'. +#'@param memb_dim A character string indicating the name of the +#' member dimension, by default 'member'. #' #'@return BEI_ProbsWeighting() returns an array with at least two or four #'dimensions depending if the variable is a spatially aggregated variable @@ -307,102 +257,114 @@ BEI_EMWeighting <- function(var_exp, aweights, time_dim_name = 'time') { #'terciles probabilities computing with weighted members. #'The first tercil is the lower tercile, the second is the normal tercile and #'the third is the upper tercile. -#' -#'@import multiApply #' #'@examples #'# Example 1 #'var_exp <- 1 : (2 * 4) #'dim(var_exp) <- c(time = 2, member = 4) -#'aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +#'aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) #'dim(aweights) <- c(time = 2, member = 4) #'terciles <- c(2.5,5) #'dim(terciles) <- c(tercil = 2) #'res <- BEI_ProbsWeighting(var_exp, aweights, terciles) -#'dim(res) -#'# time tercil -#'# 2 3 +#' #'# Example 2 #'var_exp <- rnorm(48, 50, 9) #'dim(var_exp) <- c(time = 2, member = 4, lat = 2, lon = 3) -#'aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +#'aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) #'dim(aweights) <- c(time = 2, member = 4) #'terciles <- rep(c(48,50), 2*3) #'dim(terciles) <- c(tercil = 2, lat = 2, lon = 3) #'res <- BEI_ProbsWeighting(var_exp, aweights, terciles) -#'dim(res) -#'# time tercil lat lon -#'# 2 3 2 3 -#'@noRd +#'@import multiApply +#'@export BEI_ProbsWeighting <- function(var_exp, aweights, terciles, - time_dim_name = 'time') { - - if (!is.character(time_dim_name)) { - stop("Parameter 'time_dim_name' must be a character string indicating", - " the name of the temporal dimension.") + time_dim_name = 'time', memb_dim = 'member') { + # var_exp + if (!is.array(var_exp)) { + stop("Parameter 'var_exp' must be an array.") } - if (length(time_dim_name) > 1) { - warning("Parameter 'time_dim_name' has length greater than 1 and ", - "only the first element will be used.") - time_dim_name <- time_dim_name[1] + # aweights + if (!is.array(aweights)) { + stop("Parameter 'aweights' must be an array.") } - if (is.null(terciles)){ - stop("Parameter 'terciles' is null") + # terciles + if (is.null(terciles)) { + stop("Parameter 'terciles' cannot be null.") } - if(!is.array(terciles)){ + if (!is.array(terciles)) { stop("Parameter 'terciles' must be an array.") } if (is.null(names(dim(terciles)))) { - stop("Parameters 'terciles' should have dimmension names.") + stop("Parameter 'terciles' should have dimension names.") } - if(!('tercil' %in% names(dim(terciles)))) { + if (!('tercil' %in% names(dim(terciles)))) { stop("Parameter 'terciles' must have dimension 'tercil'.") } if (dim(terciles)['tercil'] != 2) { stop("Length of dimension 'tercil' ", "of parameter 'terciles' must be equal to 2.") } - if(time_dim_name %in% names(dim(terciles))) { - stop("Parameter 'terciles' must not have temporal dimension.") + # time_dim_name + if (!is.character(time_dim_name)) { + stop("Parameter 'time_dim_name' must be a character string indicating", + " the name of the temporal dimension.") + } + if (length(time_dim_name) > 1) { + warning("Parameter 'time_dim_name' has length greater than 1 and ", + "only the first element will be used.") + time_dim_name <- time_dim_name[1] } - if('member' %in% names(dim(terciles))) { - stop("Parameter 'terciles' must not have dimension 'member'.") + # memb_dim + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string indicating", + " the name of the member dimension.") } - if (!is.array(var_exp)) { - stop("Parameter 'var_exp' must be an array.") + # var_exp, terciles, aweights (2) + if (time_dim_name %in% names(dim(terciles))) { + stop("Parameter 'terciles' must not have temporal dimension.") } - if (!is.array(aweights)) { - stop("Parameter 'aweights' must be an array.") + if (memb_dim %in% names(dim(terciles))) { + stop("Parameter 'terciles' must not have a member dimension.") } if (is.null(names(dim(var_exp))) || is.null(names(dim(aweights)))) { stop("Parameters 'var_exp' and 'aweights'", - " should have dimmension names.") + " should have dimension names.") } - if(!(time_dim_name %in% names(dim(var_exp)))) { + if (!(time_dim_name %in% names(dim(var_exp)))) { stop("Parameter 'var_exp' must have temporal dimension.") } - if(!(time_dim_name %in% names(dim(aweights)))) { + if (!(time_dim_name %in% names(dim(aweights)))) { stop("Parameter 'aweights' must have temporal dimension.") } - if(!('member' %in% names(dim(var_exp)))) { - stop("Parameter 'var_exp' must have dimension 'member'.") + if (!(memb_dim %in% names(dim(var_exp)))) { + stop("Parameter 'var_exp' must have member dimension.") } - if(!('member' %in% names(dim(aweights)))) { - stop("Parameter 'aweights' must have dimension 'member'.") + if (!(memb_dim %in% names(dim(aweights)))) { + stop("Parameter 'aweights' must have member dimension.") } if (dim(var_exp)[time_dim_name] != dim(aweights)[time_dim_name]) { - stop("Length of temporal dimensions ", - "of parameter 'var_exp' and 'aweights' must be equals.") + stop("Length of temporal dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") } - if (dim(var_exp)['member'] != dim(aweights)['member']) { - stop("Length of dimension 'member' ", - "of parameter 'var_exp' and 'aweights' must be equals.") + if (dim(var_exp)[memb_dim] != dim(aweights)[memb_dim]) { + stop("Length of member dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") + } + + names_exp <- sort(names(dim(var_exp))) + names_exp <- names_exp[-which(names_exp %in% c(time_dim_name, memb_dim))] + names_tercil <- sort(names(dim(terciles))) + names_tercil <- names_tercil[-which(names_tercil == 'tercil')] + + if (!all(dim(var_exp)[names_exp] == dim(terciles)[names_tercil])) { + stop("Length of common dimensions ", + "of parameter 'var_exp' and 'terciles' must be equal.") } - res <- Apply(list(var_exp, aweights, terciles), - target_dims = list(c(time_dim_name,'member'), - c(time_dim_name,'member'), + target_dims = list(c(time_dim_name, memb_dim), + c(time_dim_name, memb_dim), c('tercil')), fun = .BEI_ProbsWeighting, time_dim_name)$output1 return(res) @@ -419,6 +381,8 @@ BEI_ProbsWeighting <- function(var_exp, aweights, terciles, #' element is the upper tercile. #'@param time_dim_name A character string indicating the name of the #' temporal dimension, by default 'time'. +#'@param memb_dim A character string indicating the name of the +#' member dimension, by default 'member'. #' #'@return .BEI_ProbsWeighting returns an array of with a temporal dimension, #'as default 'time', and 'tercil' dimension, containing the probabilities @@ -434,16 +398,15 @@ BEI_ProbsWeighting <- function(var_exp, aweights, terciles, #'terciles <- quantile(1:8, probs = c(1/3, 2/3)) #'dim(terciles) <- c(tercil = 2) #'res <- .BEI_ProbsWeighting(var_exp, aweights, terciles, time_dim_name = 'stime') -#'dim(res) -#'# stime tercil -#'# 2 3 #'@noRd .BEI_ProbsWeighting <- function(var_exp, aweights, terciles, - time_dim_name = 'time') { - if(any(is.na(var_exp)) || any(is.na(aweights))){ + time_dim_name = 'time', memb_dim = 'member') { + if (any(is.na(var_exp)) || any(is.na(aweights))) { probTercile <- array(NA, dim = c(dim(var_exp)[time_dim_name], tercil = 3)) } else { - if(any(is.na(terciles))) stop("Terciles are NAs") + if (any(is.na(terciles))) { + stop("Terciles are NAs") + } terciles_exp <- list(lowerTercile = terciles[1], upperTercile = terciles[2]) @@ -451,17 +414,17 @@ BEI_ProbsWeighting <- function(var_exp, aweights, terciles, upperTercile <- terciles_exp$upperTercile # Probabilities - aTerciles <- Apply(list(var_exp), target_dims = list('member'), + aTerciles <- Apply(list(var_exp), target_dims = list(memb_dim), fun = Data2Tercil, lowerTercile, upperTercile)$output1 - pos <- match(names(dim(aTerciles)), c(time_dim_name,'member')) - aTerciles <- aperm(aTerciles,pos) - names(dim(aTerciles)) <- c(time_dim_name,'member') + pos <- match(names(dim(aTerciles)), c(time_dim_name, memb_dim)) + aTerciles <- aperm(aTerciles, pos) + names(dim(aTerciles)) <- c(time_dim_name, memb_dim) probTercile <- array(NA, dim = c(dim(var_exp)[time_dim_name], tercil = 3)) - for (idTercil in 1:3){ - probTercile[,idTercil] <- Apply(list(aTerciles, aweights), - target_dims = list('member','member'), + for (idTercil in 1:3) { + probTercile[ ,idTercil] <- Apply(list(aTerciles, aweights), + target_dims = list(memb_dim, memb_dim), fun = WeightTercil2Prob, idTercil)$output1 } } @@ -486,6 +449,8 @@ BEI_ProbsWeighting <- function(var_exp, aweights, terciles, #' (time, member), when 'time' is the temporal dimension as default. #'@param time_dim_name A character string indicating the name of the #' temporal dimension, by default 'time'. +#'@param memb_dim A character string indicating the name of the +#' member dimension, by default 'member'. #' #'@return BEI_TercilesWeighting() returns an array with at least one #'dimension depending if the variable is a spatially aggregated variable @@ -493,8 +458,6 @@ BEI_ProbsWeighting <- function(var_exp, aweights, terciles, #'precipitation or temperature)(tercil, lat, lon), containing the #'terciles computing with weighted members. #'The first tercil is the lower tercile, the second is the upper tercile. -#' -#'@import multiApply #' #'@examples #'# Example 1 @@ -503,21 +466,27 @@ BEI_ProbsWeighting <- function(var_exp, aweights, terciles, #'aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) #'dim(aweights) <- c(time = 2, member = 4) #'res <- BEI_TercilesWeighting(var_exp, aweights) -#'dim(res) -#'# tercil -#'# 2 +#' #'# Example 2 #'var_exp <- rnorm(48, 50, 9) #'dim(var_exp) <- c(time = 2, member = 4, lat = 2, lon = 3) #'aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) #'dim(aweights) <- c(time = 2, member = 4) #'res <- BEI_TercilesWeighting(var_exp, aweights) -#'dim(res) -#'# tercil lat lon -#'# 2 2 3 -#'@noRd -BEI_TercilesWeighting <- function(var_exp, aweights, time_dim_name = 'time') { +#'@import multiApply +#'@export +BEI_TercilesWeighting <- function(var_exp, aweights, time_dim_name = 'time', + memb_dim = 'member') { + # var_exp + if (!is.array(var_exp)) { + stop("Parameter 'var_exp' must be an array.") + } + # aweights + if (!is.array(aweights)) { + stop("Parameter 'aweights' must be an array.") + } + # time_dim_name if (!is.character(time_dim_name)) { stop("Parameter 'time_dim_name' must be a character string indicating", " the name of the temporal dimension.") @@ -527,39 +496,40 @@ BEI_TercilesWeighting <- function(var_exp, aweights, time_dim_name = 'time') { "only the first element will be used.") time_dim_name <- time_dim_name[1] } - if (!is.array(var_exp)) { - stop("Parameter 'var_exp' must be an array.") - } - if (!is.array(aweights)) { - stop("Parameter 'aweights' must be an array.") + # memb_dim + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string indicating", + " the name of the member dimension.") } + # var_exp, aweights (2) if (is.null(names(dim(var_exp))) || is.null(names(dim(aweights)))) { stop("Parameters 'var_exp' and 'aweights'", - " should have dimmension names.") + " should have dimension names.") } - if(!(time_dim_name %in% names(dim(var_exp)))) { + if (!(time_dim_name %in% names(dim(var_exp)))) { stop("Parameter 'var_exp' must have temporal dimension.") } - if(!(time_dim_name %in% names(dim(aweights)))) { + if (!(time_dim_name %in% names(dim(aweights)))) { stop("Parameter 'aweights' must have temporal dimension.") } - if(!('member' %in% names(dim(var_exp)))) { - stop("Parameter 'var_exp' must have temporal dimension.") + if (!(memb_dim %in% names(dim(var_exp)))) { + stop("Parameter 'var_exp' must have member dimension.") } - if(!('member' %in% names(dim(aweights)))) { - stop("Parameter 'aweights' must have temporal dimension.") + if (!(memb_dim %in% names(dim(aweights)))) { + stop("Parameter 'aweights' must have member dimension.") } if (dim(var_exp)[time_dim_name] != dim(aweights)[time_dim_name]) { - stop("Length of temporal dimensions ", - "of parameter 'var_exp' and 'aweights' must be equals.") + stop("Length of temporal dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") } - if (dim(var_exp)['member'] != dim(aweights)['member']) { - stop("Length of dimension 'member' ", - "of parameter 'var_exp' and 'aweights' must be equals.") + if (dim(var_exp)[memb_dim] != dim(aweights)[memb_dim]) { + stop("Length of member dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") } res <- Apply(list(var_exp, aweights), - target_dims = list(c(time_dim_name,'member'), c(time_dim_name,'member')), + target_dims = list(c(time_dim_name, memb_dim), + c(time_dim_name, memb_dim)), fun = .BEI_TercilesWeighting, time_dim_name)$output1 return(res) } @@ -584,12 +554,10 @@ BEI_TercilesWeighting <- function(var_exp, aweights, time_dim_name = 'time') { #'aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) #'dim(aweights) <- c(stime = 2, member = 4) #'res <- .BEI_TercilesWeighting(var_exp, aweights, time_dim_name = 'stime') -#'dim(res) -#'# tercil -#'# 2 #'@noRd .BEI_TercilesWeighting <- function(var_exp, aweights, time_dim_name = 'time') { - if(any(is.na(var_exp)) || any(is.na(aweights))){ + + if (any(is.na(var_exp)) || any(is.na(aweights))) { terciles_exp <- array(c(NA, NA), dim = c(tercil = 2)) } else { l_terciles_exp <- WeightTerciles(var_exp, aweights, time_dim_name) @@ -600,11 +568,11 @@ BEI_TercilesWeighting <- function(var_exp, aweights, time_dim_name = 'time') { } # Auxiliar function to compute in which tercile is a data value -Data2Tercil_old <- function(x,lt,ut) { - if(is.na(lt) || is.na(ut)){ +Data2Tercil_old <- function(x, lt, ut) { + if (is.na(lt) || is.na(ut)) { y <- rep(NA, length(x)) } else { - y <- rep(2,length(x)) + y <- rep(2, length(x)) y[x <= lt] <- 1 y[x >= ut] <- 3 if (lt == ut) { @@ -615,11 +583,11 @@ Data2Tercil_old <- function(x,lt,ut) { return (y) } # Auxiliar function to compute in which tercile is a data value -Data2Tercil <- function(x,lt,ut) { - if(is.na(lt) || is.na(ut)){ +Data2Tercil <- function(x, lt, ut) { + if (is.na(lt) || is.na(ut)) { y <- rep(NA, length(x)) } else { - y <- rep(2,length(x)) + y <- rep(2, length(x)) y[x <= lt] <- 1 y[x >= ut] <- 3 if (lt == ut) { @@ -654,27 +622,27 @@ WeightTerciles <- function(data, aweights, time_dim_name = 'time') { # is lower tercile and when 2/3 is reached, it is the upper tercile. sumWeights <- 0 ilowerTercile <- 0 - while ((sumWeights < 1/3) & (ilowerTercile < length(aweights))){ - ilowerTercile<- ilowerTercile +1 + while ((sumWeights < 1/3) & (ilowerTercile < length(aweights))) { + ilowerTercile <- ilowerTercile + 1 sumWeights <- sumWeights + vectorWeights[indSort[ilowerTercile]] } - if (ilowerTercile == 1){ + if (ilowerTercile == 1) { lowerTercile <- dataSort[ilowerTercile] } else { - lowerTercile <- (dataSort[ilowerTercile]+ - dataSort[ilowerTercile-1])/2 + lowerTercile <- (dataSort[ilowerTercile] + + dataSort[ilowerTercile - 1]) / 2 } sumWeights <- 0 iupperTercile <- 0 - while ((sumWeights < 2/3) & (iupperTercile < length(aweights))){ - iupperTercile<- iupperTercile +1 + while ((sumWeights < 2/3) & (iupperTercile < length(aweights))) { + iupperTercile <- iupperTercile + 1 sumWeights <- sumWeights + vectorWeights[indSort[iupperTercile]] } if (iupperTercile == 1) { upperTercile <- dataSort[iupperTercile] } else { upperTercile <- (dataSort[iupperTercile]+ - dataSort[iupperTercile-1])/2 + dataSort[iupperTercile - 1]) / 2 } return(list(lowerTercile = lowerTercile, upperTercile = upperTercile)) } diff --git a/R/CST_BiasCorrection.R b/R/CST_BiasCorrection.R index da368db00cffe396531ef55d449c3d04650ff7ea..ae5b61f98c2be98f1274875e640ecf00b30ba86d 100644 --- a/R/CST_BiasCorrection.R +++ b/R/CST_BiasCorrection.R @@ -49,8 +49,9 @@ #'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp <- list(data = mod1, lat = lat, lon = lon) -#'obs <- list(data = obs1, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'exp <- list(data = mod1, coords = coords) +#'obs <- list(data = obs1, coords = coords) #'attr(exp, 'class') <- 's2dv_cube' #'attr(obs, 'class') <- 's2dv_cube' #'a <- CST_BiasCorrection(exp = exp, obs = obs) @@ -59,6 +60,7 @@ CST_BiasCorrection <- function(exp, obs, exp_cor = NULL, na.rm = FALSE, memb_dim = 'member', sdate_dim = 'sdate', dat_dim = NULL, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -76,15 +78,15 @@ CST_BiasCorrection <- function(exp, obs, exp_cor = NULL, na.rm = FALSE, if (is.null(exp_cor)) { exp$data <- BiasCorrected - exp$Datasets <- c(exp$Datasets, obs$Datasets) - exp$source_files <- c(exp$source_files, obs$source_files) + exp$attrs$Datasets <- c(exp$attrs$Datasets, obs$attrs$Datasets) + exp$attrs$source_files <- c(exp$attrs$source_files, obs$attrs$source_files) return(exp) } else { exp_cor$data <- BiasCorrected - exp_cor$Datasets <- c(exp_cor$Datasets, exp$Datasets, obs$Datasets) - exp_cor$source_files <- c(exp_cor$source_files, exp$source_files, obs$source_files) + exp_cor$attrs$Datasets <- c(exp_cor$attrs$Datasets, exp$attrs$Datasets, obs$attrs$Datasets) + exp_cor$attrs$source_files <- c(exp_cor$attrs$source_files, exp$attrs$source_files, obs$attrs$source_files) return(exp_cor) } diff --git a/R/CST_Calibration.R b/R/CST_Calibration.R index d0b547d1af9b98e2a5d6cbfd4c282d4872ddb743..9b3c33fae831a5a457024305c7dc31d0aa1d7f70 100644 --- a/R/CST_Calibration.R +++ b/R/CST_Calibration.R @@ -116,8 +116,9 @@ #'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp <- list(data = mod1, lat = lat, lon = lon) -#'obs <- list(data = obs1, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'exp <- list(data = mod1, coords = coords) +#'obs <- list(data = obs1, coords = coords) #'attr(exp, 'class') <- 's2dv_cube' #'attr(obs, 'class') <- 's2dv_cube' #'a <- CST_Calibration(exp = exp, obs = obs, cal.method = "mse_min", eval.method = "in-sample") @@ -131,8 +132,9 @@ #'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp <- list(data = mod1, lat = lat, lon = lon) -#'obs <- list(data = obs1, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'exp <- list(data = mod1, coords = coords) +#'obs <- list(data = obs1, coords = coords) #'exp_cor <- list(data = mod2, lat = lat, lon = lon) #'attr(exp, 'class') <- 's2dv_cube' #'attr(obs, 'class') <- 's2dv_cube' @@ -147,7 +149,7 @@ CST_Calibration <- function(exp, obs, exp_cor = NULL, cal.method = "mse_min", eval.method = "leave-one-out", multi.model = FALSE, na.fill = TRUE, na.rm = TRUE, apply_to = NULL, alpha = NULL, memb_dim = 'member', sdate_dim = 'sdate', dat_dim = NULL, ncores = NULL) { - + # Check 's2dv_cube' if (!inherits(exp, "s2dv_cube") || !inherits(obs, "s2dv_cube")) { stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -175,15 +177,15 @@ CST_Calibration <- function(exp, obs, exp_cor = NULL, cal.method = "mse_min", if (is.null(exp_cor)) { exp$data <- Calibration - exp$Datasets <- c(exp$Datasets, obs$Datasets) - exp$source_files <- c(exp$source_files, obs$source_files) + exp$attrs$Datasets <- c(exp$attrs$Datasets, obs$attrs$Datasets) + exp$attrs$source_files <- c(exp$attrs$source_files, obs$attrs$source_files) return(exp) } else { exp_cor$data <- Calibration - exp_cor$Datasets <- c(exp_cor$Datasets, exp$Datasets, obs$Datasets) - exp_cor$source_files <- c(exp_cor$source_files, exp$source_files, obs$source_files) + exp_cor$attrs$Datasets <- c(exp_cor$attrs$Datasets, exp$attrs$Datasets, obs$attrs$Datasets) + exp_cor$attrs$source_files <- c(exp_cor$attrs$source_files, exp$attrs$source_files, obs$attrs$source_files) return(exp_cor) } diff --git a/R/CST_CategoricalEnsCombination.R b/R/CST_CategoricalEnsCombination.R index 55495c5ee713cd2848be66fef1e8a93ddd9c0dfa..86c40df1b4813dd653a8ea511ad1dd0582126bc0 100644 --- a/R/CST_CategoricalEnsCombination.R +++ b/R/CST_CategoricalEnsCombination.R @@ -75,26 +75,31 @@ #'@references Van Schaeybroeck, B., & Vannitsem, S. (2019). Postprocessing of #'Long-Range Forecasts. In Statistical Postprocessing of Ensemble Forecasts (pp. 267-290). #' -#'@importFrom s2dv InsertDim -#'@import abind #'@examples -#' #'mod1 <- 1 : (2 * 2* 4 * 5 * 2 * 2) #'dim(mod1) <- c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, lon = 2) #'mod1[2, 1, , , , ] <- NA -#'dimnames(mod1)[[1]] <- c("MF", "UKMO") +#'datasets <- c("MF", "UKMO") #'obs1 <- 1 : (1 * 1 * 4 * 5 * 2 * 2) #'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, lon = 2) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp <- list(data = mod1, lat = lat, lon = lon) -#'obs <- list(data = obs1, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'attrs <- list(Datasets = datasets) +#'exp <- list(data = mod1, coords = coords, attrs = attrs) +#'obs <- list(data = obs1, coords = coords) #'attr(exp, 'class') <- 's2dv_cube' #'attr(obs, 'class') <- 's2dv_cube' -#'a <- CST_CategoricalEnsCombination(exp = exp, obs = obs, amt.cat = 3, cat.method = "mmw") -#' +#'a <- CST_CategoricalEnsCombination(exp = exp, obs = obs, amt.cat = 3, +#' cat.method = "mmw") +#'@importFrom s2dv InsertDim +#'@import abind #'@export -CST_CategoricalEnsCombination <- function(exp, obs, cat.method = "pool", eval.method = "leave-one-out", amt.cat = 3, ...) { +CST_CategoricalEnsCombination <- function(exp, obs, cat.method = "pool", + eval.method = "leave-one-out", + amt.cat = 3, + ...) { + # Check 's2dv_cube' if (!inherits(exp, "s2dv_cube") || !inherits(exp, "s2dv_cube")) { stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -103,15 +108,19 @@ CST_CategoricalEnsCombination <- function(exp, obs, cat.method = "pool", eval.me stop("The length of the dimension 'member' in the component 'data' ", "of the parameter 'obs' must be equal to 1.") } + names.dim.tmp <- names(dim(exp$data)) - exp$data <- CategoricalEnsCombination(fc = exp$data, obs = obs$data, cat.method = cat.method, - eval.method = eval.method, amt.cat = amt.cat, ...) + exp$data <- CategoricalEnsCombination(fc = exp$data, obs = obs$data, + cat.method = cat.method, + eval.method = eval.method, + amt.cat = amt.cat, ...) + names.dim.tmp[which(names.dim.tmp == "member")] <- "category" names(dim(exp$data)) <- names.dim.tmp - exp$data <- suppressWarnings(InsertDim(exp$data, lendim = 1, posdim = 2)) - names(dim(exp$data))[2] <- "member" - exp$Datasets <- c(exp$Datasets, obs$Datasets) - exp$source_files <- c(exp$source_files, obs$source_files) + + exp$data <- InsertDim(exp$data, lendim = 1, posdim = 2, name = "member") + exp$attrs$Datasets <- c(exp$attrs$Datasets, obs$attrs$Datasets) + exp$attrs$source_files <- c(exp$attrs$source_files, obs$attrs$source_files) return(exp) } @@ -146,7 +155,7 @@ CST_CategoricalEnsCombination <- function(exp, obs, cat.method = "pool", eval.me #' into the different categories and therefore contains only 0 and 1 values. #'@param eval.method Is the sampling method used, can be either #' \code{"in-sample"} or \code{"leave-one-out"}. Default value is the -#' \code{"leave-one-out"} cross validation. +#' \code{"leave-one-out"} cross validation. #'@param ... Other parameters to be passed on to the calibration procedure. #' #'@return An array containing the categorical forecasts in the element called @@ -465,4 +474,4 @@ comb.dims <- function(arr.in, dims.to.combine){ freq.per.mdl[amt.coeff, , ] = 1 / amt.cat return(freq.per.mdl) -} +} \ No newline at end of file diff --git a/R/CST_DynBiasCorrection.R b/R/CST_DynBiasCorrection.R index db1685b6817f00c7d03c951ed2126dfe221f691c..3f715f9e1bd151ff5deaad0e576ff13c8ab40017 100644 --- a/R/CST_DynBiasCorrection.R +++ b/R/CST_DynBiasCorrection.R @@ -20,7 +20,7 @@ #'@references Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., #'and Yiou, P. (2019). The hammam effect or how a warm ocean enhances large #'scale atmospheric predictability.Nature Communications, 10(1), 1316. -#'DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " +#'DOI = \doi{10.1038/s41467-019-09305-8} " #'@references Faranda, D., Gabriele Messori and Pascal Yiou. (2017). #' Dynamical proxies of North Atlantic predictability and extremes. #' Scientific Reports, 7-41278, 2017. @@ -43,34 +43,35 @@ #'conditioned by local dimension 'dim' or inverse of persistence 'theta'. #' #'@examples -#'# example 1: simple data s2dvcube style -#' set.seed(1) -#' expL <- rnorm(1:2000) -#' dim (expL) <- c(time =100,lat = 4, lon = 5) -#' obsL <- c(rnorm(1:1980),expL[1,,]*1.2) -#' dim (obsL) <- c(time = 100,lat = 4, lon = 5) -#' time_obsL <- paste(rep("01", 100), rep("01", 100), 1920 : 2019, sep = "-") -#' time_expL <- paste(rep("01", 100), rep("01", 100), 1929 : 2019, sep = "-") -#' lon <- seq(-1,5,1.5) -#' lat <- seq(30,35,1.5) -#' # qm=0.98 # too high for this short dataset, it is possible that doesn't -#' # get the requirement, in that case it would be necessary select a lower qm -#' # for instance qm=0.60 -#' expL <- s2dv_cube(data = expL, lat = lat, lon = lon, -#' Dates = list(start = time_expL, end = time_expL)) -#' obsL <- s2dv_cube(data = obsL, lat = lat, lon = lon, -#' Dates = list(start = time_obsL, end = time_obsL)) -#' # to use DynBiasCorrection -#' dynbias1 <- DynBiasCorrection(exp = expL$data, obs = obsL$data, proxy= "dim", +#'expL <- rnorm(1:2000) +#'dim(expL) <- c(time = 100, lat = 4, lon = 5) +#'obsL <- c(rnorm(1:1980), expL[1, , ] * 1.2) +#'dim(obsL) <- c(time = 100, lat = 4, lon = 5) +#'time_obsL <- as.POSIXct(paste(rep("01", 100), rep("01", 100), 1920:2019, sep = "-"), +#' format = "%d-%m-%y") +#'time_expL <- as.POSIXct(paste(rep("01", 100), rep("01", 100), 1929:2019, sep = "-"), +#' format = "%d-%m-%y") +#'lon <- seq(-1, 5, 1.5) +#'lat <- seq(30, 35, 1.5) +#'# qm = 0.98 #'too high for this short dataset, it is possible that doesn't +#'# get the requirement, in that case it would be necessary select a lower qm +#'# for instance qm = 0.60 +#'expL <- s2dv_cube(data = expL, coords = list(lon = lon, lat = lat), +#' Dates = time_expL) +#'obsL <- s2dv_cube(data = obsL, coords = list(lon = lon, lat = lat), +#' Dates = time_obsL) +#'# to use DynBiasCorrection +#'dynbias1 <- DynBiasCorrection(exp = expL$data, obs = obsL$data, proxy= "dim", +#' quanti = 0.6) +#'# to use CST_DynBiasCorrection +#'dynbias2 <- CST_DynBiasCorrection(exp = expL, obs = obsL, proxy= "dim", #' quanti = 0.6) -#' # to use CST_DynBiasCorrection -#' dynbias2 <- CST_DynBiasCorrection(exp = expL, obs = obsL, proxy= "dim", -#' quanti = 0.6) #' #'@export CST_DynBiasCorrection<- function(exp, obs, method = 'QUANT', wetday=FALSE, proxy = "dim", quanti, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(obs, 's2dv_cube')) { stop("Parameter 'obs' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -80,7 +81,7 @@ CST_DynBiasCorrection<- function(exp, obs, method = 'QUANT', wetday=FALSE, "as output by CSTools::CST_Load.") } exp$data <- DynBiasCorrection(exp = exp$data, obs = obs$data, method = method, - wetday=wetday, + wetday = wetday, proxy = proxy, quanti = quanti, ncores = ncores) return(exp) } @@ -168,15 +169,15 @@ DynBiasCorrection<- function(exp, obs, method = 'QUANT',wetday=FALSE, predyn.exp <- Predictability(dim = attractor.exp$dim, theta = attractor.exp$theta) - if (!(any(names(dim(exp)) %in% 'time'))){ - if (any(names(dim(exp)) %in% 'sdate')) { - if (any(names(dim(exp)) %in% 'ftime')) { - exp <- MergeDims(exp, merge_dims = c('ftime', 'sdate'), - rename_dim = 'time') + if (!(any(names(dim(exp)) %in% 'time'))) { + if (any(names(dim(exp)) %in% 'sdate')) { + if (any(names(dim(exp)) %in% 'ftime')) { + exp <- MergeDims(exp, merge_dims = c('ftime', 'sdate'), + rename_dim = 'time') + } } - } } - if (!(any(names(dim(obs)) %in% 'time'))){ + if (!(any(names(dim(obs)) %in% 'time'))) { if (any(names(dim(obs)) %in% 'sdate')) { if (any(names(dim(obs)) %in% 'ftime')) { obs <- MergeDims(obs, merge_dims = c('ftime', 'sdate'), @@ -221,25 +222,25 @@ DynBiasCorrection<- function(exp, obs, method = 'QUANT',wetday=FALSE, stop ("Parameter 'proxy' must be set as 'dim' or 'theta'.") } - if(any(names(dim(adjusted)) %in% 'memberObs')){ - if(dim(adjusted)['memberObs'] == 1){ - adjusted <- Subset(adjusted,along='memberObs',indices=1,drop = 'selected') - }else{ - print('Dimension member in obs changed to memberObs') + if (any(names(dim(adjusted)) %in% 'memberObs')) { + if (dim(adjusted)['memberObs'] == 1) { + adjusted <- Subset(adjusted, along = 'memberObs', indices=1, drop = 'selected') + } else { + print('Dimension member in obs changed to memberObs') } } - if(any(names(dim(adjusted)) %in% 'datasetObs')){ - if(dim(adjusted)['datasetObs'] == 1){ - adjusted <- Subset(adjusted,along='datasetObs',indices=1,drop = 'selected') - }else{ + if (any(names(dim(adjusted)) %in% 'datasetObs')) { + if (dim(adjusted)['datasetObs'] == 1) { + adjusted <- Subset(adjusted, along = 'datasetObs', indices = 1, drop = 'selected') + } else { print('Dimension dataset in obs changed to datasetObs') } } return(adjusted) } -.dynbias <- function(exp, obs, method, wetday,predyn.exp, predyn.obs) { +.dynbias <- function(exp, obs, method, wetday, predyn.exp, predyn.obs) { result <- array(rep(NA, length(exp))) res <- lapply(1:3, function(x) { exp_sub <- exp[predyn.exp[[x]]] @@ -250,7 +251,7 @@ DynBiasCorrection<- function(exp, obs, method = 'QUANT',wetday=FALSE, }) return(result) } -.qbiascorrection <- function(expX, obsX, method,wetday) { +.qbiascorrection <- function(expX, obsX, method, wetday) { ## functions fitQmap and doQmap if (method == "PTF") { qm.fit <- fitQmap(obsX, expX, method = "PTF", transfun = "expasympt", diff --git a/R/CST_EnsClustering.R b/R/CST_EnsClustering.R index 52494032d1edf14e7056b1314422ed8d81c470c4..ebebc1fdaf7a65b3a47cfe9046c3abdecf8bb682 100644 --- a/R/CST_EnsClustering.R +++ b/R/CST_EnsClustering.R @@ -52,9 +52,10 @@ #'standard deviation for each cluster (i.e. how much the cluster is compact). #' #'@param exp An object of the class 's2dv_cube', containing the variables to be -#' analysed. Each data object in the list is expected to have an element named -#' \code{$data} with at least two spatial dimensions named "lon" and "lat", and -#' dimensions "dataset", "member", "ftime", "sdate". +#' analysed. The element 'data' in the 's2dv_cube' object must have, at +#' least, spatial and temporal dimensions. Latitudinal dimension accepted +#' names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. Longitudinal +#' dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 'nav_lon'. #'@param time_moment Decides the moment to be applied to the time dimension. Can #' be either 'mean' (time mean), 'sd' (standard deviation along time) or 'perc' #' (a selected percentile on time). If 'perc' the keyword 'time_percentile' is @@ -83,30 +84,55 @@ #'(selected longitudes of output fields), \code{$lat} (selected longitudes of #'output fields). #'@examples -#'exp <- lonlat_temp$exp -#'exp$data <- ClimProjDiags::Subset(exp$data, along = c('member', 'lat'), list(1:2, 1:7)) -#'exp$lat <- exp$lat[1:7] -#'# Example 1: Cluster on all start dates, members and models -#'res <- CST_EnsClustering(exp, numclus = 3, +#'dat_exp <- array(abs(rnorm(1152))*275, dim = c(dataset = 1, member = 4, +#' sdate = 6, ftime = 3, +#' lat = 4, lon = 4)) +#'lon <- seq(0, 3) +#'lat <- seq(48, 45) +#'coords <- list(lon = lon, lat = lat) +#'exp <- list(data = dat_exp, coords = coords) +#'attr(exp, 'class') <- 's2dv_cube' +#'res <- CST_EnsClustering(exp = exp, numclus = 3, #' cluster_dim = c("sdate")) #' #'@export CST_EnsClustering <- function(exp, time_moment = "mean", numclus = NULL, - lon_lim = NULL, lat_lim = NULL, - variance_explained = 80, numpcs = NULL, time_dim = NULL, - time_percentile = 90, cluster_dim = "member", - verbose = F) { + lon_lim = NULL, lat_lim = NULL, + variance_explained = 80, numpcs = NULL, + time_dim = NULL, time_percentile = 90, + cluster_dim = "member", verbose = F) { + + # Check 's2dv_cube' if (!inherits(exp, "s2dv_cube")) { stop("Parameter 'exp' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } + # Check 'exp' object structure + if (!all(c('data', 'coords') %in% names(exp))) { + stop("Parameter 'exp' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + # Check coordinates + if (!any(names(exp$coords) %in% .KnownLonNames()) | + !any(names(exp$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by ", + "the package. Latitudes accepted names: 'lat', 'lats', 'latitude',", + " 'y', 'j', 'nav_lat'. Longitudes accepted names: 'lon', 'lons',", + " 'longitude', 'x', 'i', 'nav_lon'.") + } + + lon_name <- names(exp$coords)[[which(names(exp$coords) %in% .KnownLonNames())]] + lat_name <- names(exp$coords)[[which(names(exp$coords) %in% .KnownLatNames())]] - result <- EnsClustering(exp$data, exp$lat, exp$lon, - time_moment = time_moment, numclus = numclus, - lon_lim = lon_lim, lat_lim = lat_lim, - variance_explained = variance_explained, numpcs = numpcs, - time_percentile = time_percentile, time_dim = time_dim, - cluster_dim = cluster_dim, verbose = verbose) + result <- EnsClustering(exp$data, + lat = as.vector(exp$coords[[lat_name]]), + lon = as.vector(exp$coords[[lon_name]]), + time_moment = time_moment, numclus = numclus, + lon_lim = lon_lim, lat_lim = lat_lim, + variance_explained = variance_explained, + numpcs = numpcs, time_percentile = time_percentile, + time_dim = time_dim, cluster_dim = cluster_dim, + verbose = verbose) return(result) } @@ -124,7 +150,9 @@ CST_EnsClustering <- function(exp, time_moment = "mean", numclus = NULL, #'them. The clustering is performed in a reduced EOF space. #' #'@param data A matrix of dimensions 'dataset member sdate ftime lat lon' -#' containing the variables to be analysed. +#' containing the variables to be analysed. Latitudinal dimension accepted +#' names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. Longitudinal +#' dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 'nav_lon'. #'@param lat Vector of latitudes. #'@param lon Vector of longitudes. #'@param time_moment Decides the moment to be applied to the time dimension. Can @@ -155,17 +183,29 @@ CST_EnsClustering <- function(exp, time_moment = "mean", numclus = NULL, #'(selected longitudes of output fields). #' #'@examples -#'exp <- lonlat_temp$exp -#'exp$data <- ClimProjDiags::Subset(exp$data, along = c('member', 'lat'), list(1:5, 1:10)) -#'exp$lat <- exp$lat[1:10] -#'res <- EnsClustering(exp$data, exp$lat, exp$lon, numclus = 2, +#'exp <- array(abs(rnorm(1152))*275, dim = c(dataset = 1, member = 4, +#' sdate = 6, ftime = 3, +#' lat = 4, lon = 4)) +#'lon <- seq(0, 3) +#'lat <- seq(48, 45) +#'res <- EnsClustering(exp, lat = lat, lon = lon, numclus = 2, #' cluster_dim = c("member", "dataset", "sdate")) #' #'@export EnsClustering <- function(data, lat, lon, time_moment = "mean", numclus = NULL, - lon_lim = NULL, lat_lim = NULL, variance_explained = 80, - numpcs = NULL, time_percentile = 90, time_dim = NULL, - cluster_dim = "member", verbose = T) { + lon_lim = NULL, lat_lim = NULL, variance_explained = 80, + numpcs = NULL, time_percentile = 90, time_dim = NULL, + cluster_dim = "member", verbose = T) { + + # Know spatial coordinates names + if (!any(names(dim(data)) %in% .KnownLonNames()) | + !any(names(dim(data)) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + } + + lon_name <- names(dim(data))[[which(names(dim(data)) %in% .KnownLonNames())]] + lat_name <- names(dim(data))[[which(names(dim(data)) %in% .KnownLatNames())]] # Check/detect time_dim if (is.null(time_dim)) { @@ -204,14 +244,14 @@ EnsClustering <- function(data, lat, lon, time_moment = "mean", numclus = NULL, } # Repeatedly apply .ensclus - result <- Apply(exp, target_dims = c(cluster_dim, "lat", "lon"), .ensclus, + result <- Apply(exp, target_dims = c(cluster_dim, lat_name, lon_name), .ensclus, lat, lon, numclus = numclus, lon_lim = lon_lim, lat_lim = lat_lim, variance_explained = variance_explained, numpcs = numpcs, verbose = verbose) # Expand result$closest_member into indices in cluster_dim dimensions - cm=result$closest_member + cm = result$closest_member cml <- vector(mode = "list", length = length(cluster_dim)) cum <- cm * 0 dim_cd <- dim(exp)[cluster_dim] @@ -223,7 +263,10 @@ EnsClustering <- function(data, lat, lon, time_moment = "mean", numclus = NULL, names(cml) <- cluster_dim result$closest_member <- cml - return(append(result, list(lat = lat, lon = lon))) + result[[lon_name]] <- lon + result[[lat_name]] <- lat + + return(result) } # Atomic ensclus function diff --git a/R/CST_MergeDims.R b/R/CST_MergeDims.R index 39814ecd4f8779485f34747e9686465e5cfb7742..a1ecbd156b4b72f6d72efbc64c8fa4bd2e389f3c 100644 --- a/R/CST_MergeDims.R +++ b/R/CST_MergeDims.R @@ -23,21 +23,19 @@ #' dataset = 5, var = 1) #'data[2,,,,,,] <- NA #'data[c(3,27)] <- NA -#'data <-list(data = data) +#'data <- list(data = data) #'class(data) <- 's2dv_cube' #'new_data <- CST_MergeDims(data, merge_dims = c('time', 'monthly')) -#'dim(new_data$data) #'new_data <- CST_MergeDims(data, merge_dims = c('lon', 'lat'), rename_dim = 'grid') -#'dim(new_data$data) #'new_data <- CST_MergeDims(data, merge_dims = c('time', 'monthly'), na.rm = TRUE) -#'dim(new_data$data) #'@export CST_MergeDims <- function(data, merge_dims = c('ftime', 'monthly'), rename_dim = NULL, na.rm = FALSE) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") - } + } data$data <- MergeDims(data$data, merge_dims = merge_dims, rename_dim = rename_dim, na.rm = na.rm) return(data) diff --git a/R/CST_MultiEOF.R b/R/CST_MultiEOF.R index a43b7bcfeef0ab1e4faedaa8a2d50489bd028423..bd218423f314806e36a796b34c5b7e2ff6850869 100644 --- a/R/CST_MultiEOF.R +++ b/R/CST_MultiEOF.R @@ -14,7 +14,10 @@ #'@param datalist A list of objects of the class 's2dv_cube', containing the #' variables to be analysed. Each data object in the list is expected to have #' an element named \code{$data} with at least two spatial dimensions named -#' "lon" and "lat", a dimension "ftime" and a dimension "sdate". +#' "lon" and "lat", a dimension "ftime" and a dimension "sdate". Latitudinal +#' dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. +#' Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', +#' 'nav_lon'. #'@param neof_composed Number of composed eofs to return in output. #'@param minvar Minimum variance fraction to be explained in first decomposition. #'@param neof_max Maximum number of single eofs considered in the first @@ -29,47 +32,81 @@ #'variable). #'@import abind #'@examples -#'exp <- lonlat_temp$exp -#'exp$data <- ClimProjDiags::Subset(exp$data, along = c('lat', 'lon'), list(1:4, 1:4)) -#'exp$lat <- exp$lat[1:4] -#'exp$lon <- exp$lon[1:4] -#' -#'# Create three datasets (from the members) -#'exp1 <- exp -#'exp2 <- exp -#' -#'exp1$data <- ClimProjDiags::Subset(exp$data, along = 2, indices = 1:5) -#'exp2$data <- ClimProjDiags::Subset(exp$data, along = 2, indices = 6:10) +#'seq <- 1 : (2 * 3 * 4 * 5 * 6 * 8) +#'mod1 <- sin( 0.7 + seq )^2 + cos( seq ^ 2 * 1.22 ) +#'dim(mod1) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, +#' lon = 8) +#'mod2 <- sin( seq * 2 ) ^ 3 + cos( seq ^ 2 ) +#'dim(mod2) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, +#' lon = 8) +#'lon <- seq(0, 35, 5) +#'lat <- seq(0, 25, 5) +#'exp1 <- list(data = mod1, coords = list(lat = lat, lon = lon)) +#'exp2 <- list(data = mod2, coords = list(lat = lat, lon = lon)) +#'attr(exp1, 'class') <- 's2dv_cube' +#'attr(exp2, 'class') <- 's2dv_cube' +#'d = as.POSIXct(c("2017/01/01", "2017/01/02", "2017/01/03", "2017/01/04", +#' "2017/01/05", "2018/01/01", "2018/01/02", "2018/01/03", +#' "2018/01/04", "2018/01/05", "2019/01/01", "2019/01/02", +#' "2019/01/03", "2019/01/04", "2019/01/05", "2020/01/01", +#' "2020/01/02", "2020/01/03", "2020/01/04", "2020/01/05")) +#'exp1$attrs$Dates = d +#'exp2$attrs$Dates = d #' -#'cal <- CST_MultiEOF(list(exp1, exp2) , minvar = 0.9) +#'cal <- CST_MultiEOF(datalist = list(exp1, exp2), neof_composed = 2) #'@export -CST_MultiEOF <- function(datalist, - neof_max = 40, neof_composed = 5, minvar = 0.6, - lon_lim = NULL, lat_lim = NULL) { - +CST_MultiEOF <- function(datalist, neof_max = 40, neof_composed = 5, + minvar = 0.6, lon_lim = NULL, lat_lim = NULL) { + # Check s2dv_cube if (!(all(sapply(datalist, inherits, 's2dv_cube')))) { stop("Elements of the list in parameter 'datalist' must be of the class ", "'s2dv_cube', as output by CSTools::CST_Load.") } # Check if all dims equal - adims=lapply(lapply(datalist, function(x) x$data), dim) - if( !all(apply(apply(abind(adims, along = 0), 2, duplicated), 2, sum) == - (length(adims)-1))) { + adims = lapply(lapply(datalist, function(x) x$data), dim) + if(!all(apply(apply(abind(adims, along = 0), 2, duplicated), 2, sum) == + (length(adims)-1))) { stop("Input data fields must all have the same dimensions.") } - #print("Pasting data...") exp <- abind(lapply(datalist, '[[', 'data'), along = 0) dim(exp) <- c(var = length(datalist), dim(datalist[[1]]$data)) - #print("...done") if (any(is.na(exp))) { stop("Input data contain NA values.") } - result <- MultiEOF(exp, datalist[[1]]$lon, datalist[[1]]$lat, - datalist[[1]]$Dates$start, minvar = minvar, + # Check coordinates + if (!all(c('data', 'coords', 'attrs') %in% names(datalist[[1]]))) { + stop("Parameter 'datalist' must have 'data', 'coords' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + } + if (!any(names(datalist[[1]]$coords) %in% .KnownLonNames()) | + !any(names(datalist[[1]]$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by the ", + "package. Latitudes accepted names: 'lat', 'lats', 'latitude', 'y', 'j', ", + "'nav_lat'. Longitudes accepted names: 'lon', 'lons', 'longitude', 'x',", + " 'i', 'nav_lon'.") + } + # Check dimensions + if (!any(names(dim(datalist[[1]]$data)) %in% .KnownLonNames()) | + !any(names(dim(datalist[[1]]$data)) %in% .KnownLatNames())) { + stop("Spatial dimension names do not match any of the names accepted by ", + "the package.") + } + + lon <- names(datalist[[1]]$coords)[[which(names(datalist[[1]]$coords) %in% .KnownLonNames())]] + lat <- names(datalist[[1]]$coords)[[which(names(datalist[[1]]$coords) %in% .KnownLatNames())]] + + lon_name <- names(dim(datalist[[1]]$data))[[which(names(dim(datalist[[1]]$data)) %in% .KnownLonNames())]] + lat_name <- names(dim(datalist[[1]]$data))[[which(names(dim(datalist[[1]]$data)) %in% .KnownLatNames())]] + + result <- MultiEOF(exp, + lon = as.vector(datalist[[1]]$coords[[lon]]), + lat = as.vector(datalist[[1]]$coords[[lat]]), + lon_dim = lon_name, lat_dim = lat_name, + time = datalist[[1]]$attrs$Dates, minvar = minvar, neof_max = neof_max, neof_composed = neof_composed, lon_lim = lon_lim, lat_lim = lat_lim) @@ -92,7 +129,10 @@ CST_MultiEOF <- function(datalist, #' #'@param data A multidimensional array with dimension \code{"var"}, containing #' the variables to be analysed. The other diemnsions follow the same structure -#' as the \code{"exp"} element of a 's2dv_cube' object. +#' as the \code{"exp"} element of a 's2dv_cube' object. Latitudinal +#' dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. +#' Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', +#' 'nav_lon'. #'@param lon Vector of longitudes. #'@param lat Vector of latitudes. #'@param time Vector or matrix of dates in POSIXct format. @@ -111,21 +151,30 @@ CST_MultiEOF <- function(datalist, #'\code{eof_pattern} (a matrix of EOF patterns obtained by regression for each #'variable). #'@examples -#'exp <- lonlat_temp$exp -#'exp$data <- ClimProjDiags::Subset(exp$data, c('member', 'lat', 'lon'), list(1:5, 1:4, 1:4)) -#'exp$lon <- exp$lon[1:4] -#'exp$lat <- exp$lat[1:4] -#'dim(exp$data) <- c(dim(exp$data), var = 1) -#'cal <- MultiEOF(data = exp$data, lon = exp$lon, lat = exp$lat, time = exp$Dates$start) +#'exp <- array(runif(1280)*280, dim = c(dataset = 2, member = 2, sdate = 3, +#' ftime = 3, lat = 4, lon = 4, var = 1)) +#'lon <- seq(0, 3) +#'lat <- seq(47, 44) +#'dates <- c("2000-11-01", "2000-12-01", "2001-01-01", "2001-11-01", +#' "2001-12-01", "2002-01-01", "2002-11-01", "2002-12-01", "2003-01-01") +#'Dates <- as.POSIXct(dates, format = "%Y-%m-%d") +#'dim(Dates) <- c(ftime = 3, sdate = 3) +#'cal <- MultiEOF(data = exp, lon = lon, lat = lat, time = Dates) #'@import multiApply #'@export MultiEOF <- function(data, lon, lat, time, lon_dim = "lon", lat_dim = "lat", neof_max = 40, neof_composed = 5, minvar = 0.6, lon_lim = NULL, lat_lim = NULL) { - # Check/detect time_dim - # reorder and group ftime and sdate together at the end in that order + # Know spatial coordinates names + if (!any(lon_dim %in% .KnownLonNames()) | + !any(lat_dim %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + } + + # Reorder and group ftime and sdate together at the end in that order cdim0 <- dim(data) imaskt <- names(cdim0) %in% "ftime" imasks <- names(cdim0) %in% "sdate" @@ -140,15 +189,16 @@ MultiEOF <- function(data, lon, lat, time, result <- Apply(data, c("var", lon_dim, lat_dim, "samples"), .multi.eofs, lon, lat, time, neof_max = neof_max, neof_composed = neof_composed, minvar = minvar, - xlim = lon_lim, ylim = lat_lim) - + xlim = lon_lim, ylim = lat_lim, + lon_dim = lon_dim, lat_dim = lat_dim) + # Expand back samples to compacted dims dim(result$coeff) <- c(cdim[-ind], dim(result$coeff)[-1]) # Recover first lon and first lat list - dd=dim(result$lon)[1]; m=matrix(1, nrow=dd, ncol=length(dim(result$lon))); - m[1:dd]=1:dd; result$lon = result$lon[m] - dd=dim(result$lat)[1]; m=matrix(1, nrow=dd, ncol=length(dim(result$lat))); - m[1:dd]=1:dd; result$lat = result$lat[m] + dd = dim(result[[lon_dim]])[1]; m = matrix(1, nrow = dd, ncol = length(dim(result[[lon_dim]]))); + m[1:dd] = 1:dd; result[[lon_dim]] = result[[lon_dim]][m] + dd = dim(result[[lat_dim]])[1]; m = matrix(1, nrow = dd, ncol = length(dim(result[[lat_dim]]))); + m[1:dd] = 1:dd; result[[lat_dim]] = result[[lat_dim]][m] return(result) } @@ -163,15 +213,18 @@ MultiEOF <- function(data, lon, lat, time, #' decomposition. #'@param xlim Vector with longitudinal range limits for the calculation. #'@param ylim Vector with latitudinal range limits for the calculation. +#'@param lon_dim String with dimension name of longitudinal coordinate. +#'@param lat_dim String with dimension name of latitudinal coordinate. +#' #'@return A list with elements \code{$coeff} (an array of time-varying principal #'component coefficients), \code{$variance} (a matrix of explained variances), #'\code{eof_pattern} (a matrix of EOF patterns obtained by regression for each #'variable). #'@noRd -.multi.eofs <- function(field_arr_raw, lon, lat, time, - neof_max = 40, neof_composed = 5, minvar = 0.6, - xlim = NULL, ylim = NULL) { +.multi.eofs <- function(field_arr_raw, lon, lat, time, neof_max = 40, + neof_composed = 5, minvar = 0.6, xlim = NULL, + ylim = NULL, lon_dim = "lon", lat_dim = "lat") { if (exists(".lm.fit")) { lin.fit <- .lm.fit @@ -180,25 +233,20 @@ MultiEOF <- function(data, lon, lat, time, } n_field <- dim(field_arr_raw)[1] - etime <- .power.date(time) - #print("Calculating anomalies...") + field_arr <- array(dim = dim(field_arr_raw)) for (k in seq(1, n_field, 1)) { - field_arr[k, , , ] <- .daily.anom.mean( - lon, lat, field_arr_raw[k, , , ], etime - ) + field_arr[k, , , ] <- .daily.anom.mean(lon, lat, field_arr_raw[k, , , ], etime) } # area weighting, based on the root of cosine - #print("Area Weighting...") ww <- .area.weight(lon, lat, root = T) for (k in seq(1, n_field, 1)) { field_orig <- field_arr[k, , , ] # calculate the area weight field <- sweep(field_orig, c(1, 2), ww, "*") - idx <- .selbox(lon, lat, xlim, ylim) slon <- lon[idx$ilon] slat <- lat[idx$ilat] @@ -215,10 +263,7 @@ MultiEOF <- function(data, lon, lat, time, pattern <- array(SVD$u, dim = c(dim(field)[1], dim(field)[2], neof_max)) coefficient <- SVD$v variance <- (SVD$d[1:neof_max]) ^ 2 / sum((SVD$d) ^ 2) - #print("Accumulated variance:") - #print(cumsum(variance)) reqPC <- which(cumsum(variance) > minvar)[1] - #print("Number of EOFs needed for var:") variance <- variance[1:reqPC] coefficient <- coefficient[, 1:reqPC] if (reqPC == 1) { @@ -228,16 +273,12 @@ MultiEOF <- function(data, lon, lat, time, regression <- array(NA, dim = c(length(lon), length(lat), neof_max)) for (i in 1:reqPC) { regression[, , i] <- apply(field_orig, c(1, 2), - function(x) lin.fit(as.matrix(coefficient[, i], - ncol = 1), x)$coefficients - ) + function(x) lin.fit(as.matrix(coefficient[, i], + ncol = 1), x)$coefficients) } - - assign( - paste0("pc", k), list(coeff = coefficient, variance = variance, - wcoeff = sweep(coefficient, c(2), variance, "*"), - regression = regression) - ) + assign(paste0("pc", k), list(coeff = coefficient, variance = variance, + wcoeff = sweep(coefficient, c(2), variance, "*"), + regression = regression)) } newpc <- NULL @@ -246,7 +287,6 @@ MultiEOF <- function(data, lon, lat, time, } newpc <- t(newpc) - #print("Calculating composed EOFs") SVD <- svd(newpc, nu = neof_composed, nv = neof_composed) # extracting EOFs, expansions coefficient and variance explained coefficient <- SVD$v @@ -257,30 +297,26 @@ MultiEOF <- function(data, lon, lat, time, regression <- array(dim = c(n_field, length(lon), length(lat), neof_composed)) for (k in seq(1, n_field, 1)) { - #print("Linear Regressions (it can take a while)... ") for (i in 1:neof_composed) { - regression[k, , , i] <- apply( - field_arr[k, , , ], c(1, 2), - function(x) lin.fit( - as.matrix(coefficient[, i], - ncol = 1), - x)$coefficients - ) + regression[k, , , i] <- apply(field_arr[k, , , ], c(1, 2), + function(x) lin.fit(as.matrix(coefficient[, i], + ncol = 1), x)$coefficients) } } - #print("Finalize...") names(dim(coefficient)) <- c("time", "eof") variance <- array(variance) names(dim(variance)) <- "eof" names(dim(regression)) <- c("var", "lon", "lat", "eof") - out <- list(coeff = coefficient, variance = variance, eof_pattern = regression, lon = slon, lat = slat) + out <- list(coeff = coefficient, variance = variance, eof_pattern = regression) + + out[[lon_dim]] <- slon + out[[lat_dim]] <- slat return(out) } - # new function to create simple list with date values - Oct-18 # it needs a date or PCICt object, and returns also the season subdivision .power.date <- function(datas, verbose = FALSE) { @@ -303,7 +339,6 @@ MultiEOF <- function(data, lon, lat, time, return(etime) } - # function for daily anomalies, use array predeclaration and rowMeans (40 times faster!) .daily.anom.mean <- function(ics, ipsilon, field, etime) { condition <- paste(etime$day, etime$month) diff --git a/R/CST_MultiMetric.R b/R/CST_MultiMetric.R index fc8767795e034e1ddbda76b68414f2f1c2455c86..2a7970e21a3726410c577667013309cbe230b320 100644 --- a/R/CST_MultiMetric.R +++ b/R/CST_MultiMetric.R @@ -43,14 +43,15 @@ #'@import stats #'@import multiApply #'@examples -#'mod <- rnorm(2 * 2 * 4 * 5 * 2 * 2) +#'mod <- rnorm(2*2*4*5*2*2) #'dim(mod) <- c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, lon = 2) -#'obs <- rnorm(1 * 1 * 4 * 5 * 2 * 2) +#'obs <- rnorm(1*1*4*5*2*2) #'dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, lon = 2) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp <- list(data = mod, lat = lat, lon = lon) -#'obs <- list(data = obs, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'exp <- list(data = mod, coords = coords) +#'obs <- list(data = obs, coords = coords) #'attr(exp, 'class') <- 's2dv_cube' #'attr(obs, 'class') <- 's2dv_cube' #'a <- CST_MultiMetric(exp = exp, obs = obs) @@ -58,6 +59,7 @@ CST_MultiMetric <- function(exp, obs, metric = "correlation", multimodel = TRUE, time_dim = 'ftime', memb_dim = 'member', sdate_dim = 'sdate') { + # Check 's2dv_cube' if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -65,6 +67,9 @@ CST_MultiMetric <- function(exp, obs, metric = "correlation", multimodel = TRUE, result <- MultiMetric(exp$data, obs$data, metric = metric, multimodel = multimodel, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim) exp$data <- result + exp$attrs$Datasets <- c(exp$attrs$Datasets, obs$attrs$Datasets) + exp$attrs$source_files <- c(exp$attrs$source_files, obs$attrs$source_files) + return(exp) } @@ -108,14 +113,18 @@ CST_MultiMetric <- function(exp, obs, metric = "correlation", multimodel = TRUE, #'@import stats #'@import multiApply #'@examples -#'exp <- array(rnorm(2 *2 * 4 * 5 * 2 * 2), -#' dim = c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, lon = 2)) -#'obs <- array(rnorm(1 * 1 * 4 * 5 * 2 * 2), -#' c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, lon = 2)) +#'exp <- array(rnorm(2*2*4*5*2*2), +#' dim = c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, +#' lon = 2)) +#'obs <- array(rnorm(1*1*4*5*2*2), +#' dim = c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, +#' lon = 2)) #'res <- MultiMetric(exp = exp, obs = obs) #'@export MultiMetric <- function(exp, obs, metric = "correlation", multimodel = TRUE, - time_dim = 'ftime', memb_dim = 'member', sdate_dim = 'sdate') { + time_dim = 'ftime', memb_dim = 'member', + sdate_dim = 'sdate') { + if (!is.null(names(dim(exp))) & !is.null(names(dim(obs)))) { if (all(names(dim(exp)) %in% names(dim(obs)))) { dimnames <- names(dim(exp)) @@ -125,7 +134,7 @@ MultiMetric <- function(exp, obs, metric = "correlation", multimodel = TRUE, } } else { stop("Element 'data' from parameters 'exp' and 'obs'", - " should have dimmension names.") + " should have dimension names.") } if (!is.logical(multimodel)) { stop("Parameter 'multimodel' must be a logical value.") diff --git a/R/CST_MultivarRMSE.R b/R/CST_MultivarRMSE.R index 6f8d9cad2e969d3a1e4ef496c9686f82c7b2107c..bfa9bc01ca7d7df192efce9c93c59bf2f743d3d3 100644 --- a/R/CST_MultivarRMSE.R +++ b/R/CST_MultivarRMSE.R @@ -15,6 +15,18 @@ #' element named \code{$data}. #'@param weight (optional) A vector of weight values to assign to each variable. #' If no weights are defined, a value of 1 is assigned to every variable. +#'@param memb_dim A character string indicating the name of the member +#' dimension. It must be one dimension in 'exp' and 'obs'. The default value is +#' 'member'. +#'@param dat_dim A character string indicating the name of the dataset +#' dimension. It must be one dimension in 'exp' and 'obs'. If there is no +#' dataset dimension, it can be NULL. The default value is 'dataset'. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. It must be one dimension in 'exp' and 'obs'. The default value is +#' 'sdate'. +#'@param ftime_dim A character string indicating the name of the forecast time +#' dimension. It must be one dimension in 'exp' and 'obs'. The default value is +#' 'ftime'. #' #'@return An object of class \code{s2dv_cube} containing the RMSE in the element #' \code{$data} which is an array with two datset dimensions equal to the @@ -23,107 +35,151 @@ #' RMSE value), number of lat, number of lon) #' #'@seealso \code{\link[s2dv]{RMS}} and \code{\link{CST_Load}} -#'@importFrom s2dv RMS MeanDims #'@examples -#'# Creation of sample s2dv objects. These are not complete s2dv objects -#'# though. The Load function returns complete objects. -#'# using package zeallot is optional: -#' library(zeallot) #'# Example with 2 variables -#'mod1 <- 1 : (1 * 3 * 4 * 5 * 6 * 7) -#'mod2 <- 1 : (1 * 3 * 4 * 5 * 6 * 7) +#'mod1 <- abs(rnorm(1 * 3 * 4 * 5 * 6 * 7)) +#'mod2 <- abs(rnorm(1 * 3 * 4 * 5 * 6 * 7)) #'dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) #'dim(mod2) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) -#'obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) -#'obs2 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) +#'obs1 <- abs(rnorm(1 * 1 * 4 * 5 * 6 * 7)) +#'obs2 <- abs(rnorm(1 * 1 * 4 * 5 * 6 * 7)) #'dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) #'dim(obs2) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) #'lon <- seq(0, 30, 5) #'lat <- seq(0, 25, 5) -#'exp1 <- list(data = mod1, lat = lat, lon = lon, Datasets = "EXP1", -#' source_files = "file1", Variable = list('pre')) +#'coords <- list(lat = lat, lon = lon) +#'exp1 <- list(data = mod1, coords = coords, +#' attrs = list(Datasets = "EXP1", source_files = "file1", +#' Variable = list(varName = 'pre'))) +#'exp2 <- list(data = mod2, coords = coords, +#' attrs = list(Datasets = "EXP2", source_files = "file2", +#' Variable = list(varName = 'tas'))) +#'obs1 <- list(data = obs1, coords = coords, +#' attrs = list(Datasets = "OBS1", source_files = "file1", +#' Variable = list(varName = 'pre'))) +#'obs2 <- list(data = obs2, coords = coords, +#' attrs = list(Datasets = "OBS2", source_files = "file2", +#' Variable = list(varName = 'tas'))) #'attr(exp1, 'class') <- 's2dv_cube' -#'exp2 <- list(data = mod2, lat = lat, lon = lon, Datasets = "EXP2", -#' source_files = "file2", Variable = list('tas')) #'attr(exp2, 'class') <- 's2dv_cube' -#'obs1 <- list(data = obs1, lat = lat, lon = lon, Datasets = "OBS1", -#' source_files = "file1", Variable = list('pre')) #'attr(obs1, 'class') <- 's2dv_cube' -#'obs2 <- list(data = obs2, lat = lat, lon = lon, Datasets = "OBS2", -#' source_files = "file2", Variable = list('tas')) #'attr(obs2, 'class') <- 's2dv_cube' -#' -#'c(ano_exp1, ano_obs1) %<-% CST_Anomaly(exp1, obs1, cross = TRUE, memb = TRUE) -#'c(ano_exp2, ano_obs2) %<-% CST_Anomaly(exp2, obs2, cross = TRUE, memb = TRUE) -#'ano_exp <- list(exp1, exp2) -#'ano_obs <- list(ano_obs1, ano_obs2) -#'weight <- c(1, 2) -#'a <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight = weight) -#'str(a) +#'anom1 <- CST_Anomaly(exp1, obs1, cross = TRUE, memb = TRUE) +#'anom2 <- CST_Anomaly(exp2, obs2, cross = TRUE, memb = TRUE) +#'ano_exp <- list(anom1$exp, anom2$exp) +#'ano_obs <- list(anom1$obs, anom2$obs) +#'a <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight = c(1, 2)) +#'@importFrom s2dv RMS MeanDims #'@export -CST_MultivarRMSE <- function(exp, obs, weight = NULL) { +CST_MultivarRMSE <- function(exp, obs, weight = NULL, memb_dim = 'member', + dat_dim = 'dataset', sdate_dim = 'sdate', + ftime_dim = 'ftime') { + + # s2dv_cube if (!is.list(exp) | !is.list(obs)) { stop("Parameters 'exp' and 'obs' must be lists of 's2dv_cube' objects") } - if (!(all(sapply(exp, inherits, 's2dv_cube')))) { stop("Elements of the list in parameter 'exp' must be of the class ", "'s2dv_cube', as output by CSTools::CST_Load.") } - if (!(all(sapply(obs, inherits, 's2dv_cube')))) { stop("Elements of the list in parameter 'obs' must be of the class ", "'s2dv_cube', as output by CSTools::CST_Load.") } - if (length(exp) != length(obs)) { stop("Parameters 'exp' and 'obs' must be of the same length.") } - + nvar <- length(exp) - if (nvar < 2) { stop("Parameters 'exp' and 'obs' must contain at least two", " s2dv objects for two different variables.") } - for (j in 1 : nvar) { if (!is.null(names(dim(exp[[j]]$data))) & !is.null(names(dim(obs[[j]]$data)))) { if (all(names(dim(exp[[j]]$data)) %in% names(dim(obs[[j]]$data)))) { dimnames <- names(dim(exp[[j]]$data)) } else { stop("Dimension names of element 'data' from parameters 'exp'", - " and 'obs' should have the same name dimmension.") + " and 'obs' should be equal.") } } else { stop("Element 'data' from parameters 'exp' and 'obs'", - " should have dimmension names.") + " should have dimmension names.") } } - + # weight if (is.null(weight)) { weight <- c(rep(1, nvar)) - } else if (length(weight) != nvar) { + } else if (!is.numeric(weight)) { + stop("Parameter 'weight' must be numeric.") + } else if (length(weight) != nvar){ stop("Parameter 'weight' must have a length equal to the number ", "of variables.") } - obs_var <- unlist(lapply(obs, function(x) { - x[[which(names(x) == 'Variable')]]})) + # memb_dim + if (!is.null(memb_dim)) { + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp[[1]]$data)) | !memb_dim %in% names(dim(obs[[1]]$data))) { + stop("Parameter 'memb_dim' is not found in 'exp' or in 'obs' dimension.") + } + } else { + stop("Parameter 'memb_dim' cannot be NULL.") + } + # dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim)) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!dat_dim %in% names(dim(exp[[1]]$data)) | !dat_dim %in% names(dim(obs[[1]]$data))) { + stop("Parameter 'dat_dim' is not found in 'exp' or in 'obs' dimension.") + } + } + # ftime_dim + if (!is.null(ftime_dim)) { + if (!is.character(ftime_dim)) { + stop("Parameter 'ftime_dim' must be a character string.") + } + if (!ftime_dim %in% names(dim(exp[[1]]$data)) | !ftime_dim %in% names(dim(obs[[1]]$data))) { + stop("Parameter 'ftime_dim' is not found in 'exp' or in 'obs' dimension.") + } + } else { + stop("Parameter 'ftime_dim' cannot be NULL.") + } + # sdate_dim + if (!is.null(sdate_dim)) { + if (!is.character(sdate_dim)) { + stop("Parameter 'sdate_dim' must be a character string.") + } + if (!sdate_dim %in% names(dim(exp[[1]]$data)) | !sdate_dim %in% names(dim(obs[[1]]$data))) { + stop("Parameter 'sdate_dim' is not found in 'exp' or in 'obs' dimension.") + } + } else { + stop("Parameter 'sdate_dim' cannot be NULL.") + } + # Variables + obs_var <- unlist(lapply(exp, function(x) { + x$attrs$Variable$varName})) exp_var <- unlist(lapply(exp, function(x) { - x[[which(names(x) == 'Variable')]]})) + x$attrs$Variable$varName})) if (all(exp_var != obs_var)) { stop("Variables in parameters 'exp' and 'obs' must be in the same order.") } + mvrmse <- 0 sumweights <- 0 + for (j in 1 : nvar) { # seasonal average of anomalies - AvgExp <- MeanDims(exp[[j]]$data, c('member', 'ftime'), na.rm = TRUE) - AvgObs <- MeanDims(obs[[j]]$data, c('member', 'ftime'), na.rm = TRUE) + AvgExp <- MeanDims(exp[[j]]$data, c(memb_dim, ftime_dim), na.rm = TRUE) + AvgObs <- MeanDims(obs[[j]]$data, c(memb_dim, ftime_dim), na.rm = TRUE) # multivariate RMSE (weighted) - rmse <- s2dv::RMS(AvgExp, AvgObs, dat_dim = 'dataset', time_dim = 'sdate', + rmse <- RMS(AvgExp, AvgObs, dat_dim = dat_dim, time_dim = sdate_dim, conf = FALSE)$rms stdev <- sd(AvgObs) mvrmse <- mvrmse + (rmse / stdev * as.numeric(weight[j])) @@ -131,20 +187,21 @@ CST_MultivarRMSE <- function(exp, obs, weight = NULL) { } mvrmse <- mvrmse / sumweights - # names(dim(mvrmse)) <- c(dimnames[1], dimnames[1], 'statistics', dimnames[5 : 6]) + # names(dim(mvrmse)) <- c(dimnames[1], dimnames[1], 'statistics', dimnames[5 : 6]) exp_Datasets <- unlist(lapply(exp, function(x) { - x[[which(names(x) == 'Datasets')]]})) + x$attrs[[which(names(x$attrs) == 'Datasets')]]})) exp_source_files <- unlist(lapply(exp, function(x) { - x[[which(names(x) == 'source_files')]]})) + x$attrs[[which(names(x$attrs) == 'source_files')]]})) obs_Datasets <- unlist(lapply(obs, function(x) { - x[[which(names(x) == 'Datasets')]]})) + x$attrs[[which(names(x$attrs) == 'Datasets')]]})) obs_source_files <- unlist(lapply(obs, function(x) { - x[[which(names(x) == 'source_files')]]})) + x$attrs[[which(names(x$attrs) == 'source_files')]]})) - exp <- exp[[1]] - exp$data <- mvrmse - exp$Datasets <- c(exp_Datasets, obs_Datasets) - exp$source_files <- c(exp_source_files, obs_source_files) - exp$Variable <- c(exp_var) - return(exp) + exp1 <- exp[[1]] + exp1$data <- mvrmse + exp1$attrs$Datasets <- c(exp_Datasets, obs_Datasets) + exp1$attrs$source_files <- c(exp_source_files, obs_source_files) + exp1$attrs$Variable$varName <- as.character(exp_var) + exp1$attrs$Variable$metadata <- c(exp1$attrs$Variable$metadata, exp[[2]]$attrs$Variable$metadata) + return(exp1) } diff --git a/R/CST_ProxiesAttractor.R b/R/CST_ProxiesAttractor.R index 1858b134ed04a938fdc445924023ff2982f721c5..e490efca1b38fd69811acaa79dbbc9e1705c89d5 100644 --- a/R/CST_ProxiesAttractor.R +++ b/R/CST_ProxiesAttractor.R @@ -13,12 +13,13 @@ #'dynamical scores to measure predictability and to compute bias correction #'conditioned by the dynamics with the function DynBiasCorrection Function #'based on the matlab code (davide.faranda@lsce.ipsl.fr) used in -#'@references Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and Yiou, P. (2019). -#' The hammam effect or how a warm ocean enhances large scale atmospheric predictability. -#' Nature Communications, 10(1), 1316. DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " +#'@references Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., +#'and Yiou, P. (2019). The hammam effect or how a warm ocean enhances large +#'scale atmospheric predictability. Nature Communications, 10(1), 1316. +#'DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " #'@references Faranda, D., Gabriele Messori and Pascal Yiou. (2017). -#' Dynamical proxies of North Atlantic predictability and extremes. -#' Scientific Reports, 7-41278, 2017. +#'Dynamical proxies of North Atlantic predictability and extremes. +#'Scientific Reports, 7-41278, 2017. #' #'@param data An s2dv_cube object with the data to create the attractor. Must be #' a matrix with the timesteps in nrow and the grids in ncol(dat(time,grids) @@ -32,21 +33,25 @@ #'dim(obs) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) #'lon <- seq(10, 13.5, 0.5) #'lat <- seq(40, 43.5, 0.5) -#'data <- list(data = obs, lon = lon, lat = lat) +#'coords <- list(lon = lon, lat = lat) +#'data <- list(data = obs, coords = coords) #'class(data) <- "s2dv_cube" #'attractor <- CST_ProxiesAttractor(data = data, quanti = 0.6) -#' +#'@import multiApply #'@export CST_ProxiesAttractor <- function(data, quanti, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } + # Check quanti if (is.null(quanti)) { stop("Parameter 'quanti' cannot be NULL.") } - data$data <- ProxiesAttractor(data = data$data, quanti = quanti, ncores = ncores) + data$data <- ProxiesAttractor(data = data$data, quanti = quanti, + ncores = ncores) return(data) } @@ -64,9 +69,10 @@ CST_ProxiesAttractor <- function(data, quanti, ncores = NULL) { #'scores to measure predictability and to compute bias correction conditioned by #'the dynamics with the function DynBiasCorrection. #'Funtion based on the matlab code (davide.faranda@lsce.ipsl.fr) used in: -#'@references Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and Yiou, P. (2019). -#' The hammam effect or how a warm ocean enhances large scale atmospheric predictability. -#' Nature Communications, 10(1), 1316. DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " +#'@references Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and +#'Yiou, P. (2019). The hammam effect or how a warm ocean enhances large scale +#'atmospheric predictability. Nature Communications, 10(1), 1316. +#'DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " #'@references Faranda, D., Gabriele Messori and Pascal Yiou. (2017). #' Dynamical proxies of North Atlantic predictability and extremes. #' Scientific Reports, 7-41278, 2017. @@ -88,7 +94,6 @@ CST_ProxiesAttractor <- function(data, quanti, ncores = NULL) { #'Attractor <- ProxiesAttractor(data = mat, quanti = qm) #'# to plot the result #'time = c(1:length(Attractor$theta)) -#'layout(matrix(c(1, 3, 2, 3), 2, 2)) #'plot(time, Attractor$dim, xlab = 'time', ylab = 'd', #' main = 'local dimension', type = 'l') #'@import multiApply @@ -103,7 +108,7 @@ ProxiesAttractor <- function(data, quanti, ncores = NULL){ if (any(names(dim(data)) %in% 'sdate')) { if (any(names(dim(data)) %in% 'ftime')) { data <- MergeDims(data, merge_dims = c('ftime', 'sdate'), - rename_dim = 'time') + rename_dim = 'time') } } if (!(any(names(dim(data)) %in% 'time'))){ diff --git a/R/CST_QuantileMapping.R b/R/CST_QuantileMapping.R index 612bd94e1c9668d6e395d977fbbf970c60366fe9..0ac443ba519c32dac843f588ab1bf20ae3900ee3 100644 --- a/R/CST_QuantileMapping.R +++ b/R/CST_QuantileMapping.R @@ -47,20 +47,6 @@ #'class(obs) <- 's2dv_cube' #'res <- CST_QuantileMapping(exp, obs) #' -#'exp <- lonlat_temp$exp -#'exp$data <- exp$data[, , 1:4, , 1:2, 1:3] -#'dim(exp$data) <- c(dataset = 1, member = 15, sdate = 4, ftime = 3, -#' lat = 2, lon = 3) -#'obs <- lonlat_temp$obs -#'obs$data <- obs$data[, , 1:4, , 1:2, 1:3] -#'dim(obs$data) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, -#' lat = 2, lon = 3) -#'exp_cor <- lonlat_temp$exp -#'exp_cor$data <- exp_cor$data[, 1, 5:6, , 1:2, 1:3] -#'dim(exp_cor$data) <- c(dataset = 1, member = 1, sdate = 2, ftime = 3, -#' lat = 2, lon = 3) -#'res <- CST_QuantileMapping(exp, obs, exp_cor, window_dim = 'ftime') -#' #'@import qmap #'@import multiApply #'@import s2dv @@ -69,36 +55,36 @@ CST_QuantileMapping <- function(exp, obs, exp_cor = NULL, sdate_dim = 'sdate', memb_dim = 'member', window_dim = NULL, method = 'QUANT', na.rm = FALSE, ncores = NULL, ...) { - if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { - stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } - if (!is.null(exp_cor)) { - if (!inherits(exp_cor, 's2dv_cube')) { - stop("Parameter 'exp_cor' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } + # Check 's2dv_cube' + if (!inherits(exp, 's2dv_cube') || !inherits(obs, 's2dv_cube')) { + stop("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + if (!is.null(exp_cor)) { + if (!inherits(exp_cor, 's2dv_cube')) { + stop("Parameter 'exp_cor' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") } + } - QMapped <- QuantileMapping(exp = exp$data, obs = obs$data, - exp_cor = exp_cor$data, - sdate_dim = sdate_dim, memb_dim = memb_dim, - window_dim = window_dim, method = method, - na.rm = na.rm, ncores = ncores, ...) - if (is.null(exp_cor)) { - exp$data <- QMapped - exp$Datasets <- c(exp$Datasets, obs$Datasets) - exp$source_files <- c(exp$source_files, obs$source_files) - return(exp) - - } else { - exp_cor$data <- QMapped - exp_cor$Datasets <- c(exp_cor$Datasets, exp$Datasets, obs$Datasets) - exp_cor$source_files <- c(exp_cor$source_files, exp$source_files, obs$source_files) - return(exp_cor) - } - - + QMapped <- QuantileMapping(exp = exp$data, obs = obs$data, + exp_cor = exp_cor$data, + sdate_dim = sdate_dim, memb_dim = memb_dim, + window_dim = window_dim, method = method, + na.rm = na.rm, ncores = ncores, ...) + if (is.null(exp_cor)) { + exp$data <- QMapped + exp$attrs$Datasets <- c(exp$attrs$Datasets, obs$attrs$Datasets) + exp$attrs$source_files <- c(exp$attrs$source_files, obs$attrs$source_files) + return(exp) + } else { + exp_cor$data <- QMapped + exp_cor$attrs$Datasets <- c(exp_cor$attrs$Datasets, exp$attrs$Datasets, + obs$attrs$Datasets) + exp_cor$attrs$source_files <- c(exp_cor$attrs$source_files, exp$attrs$source_files, + obs$attrs$source_files) + return(exp_cor) + } } #'Quantile Mapping for seasonal or decadal forecast data @@ -149,28 +135,14 @@ CST_QuantileMapping <- function(exp, obs, exp_cor = NULL, sdate_dim = 'sdate', #' lat = 3, lon = 2) #'res <- QuantileMapping(exp, obs) #' -#'# Use data in package -#'\donttest{ -#'exp <- lonlat_temp$exp$data[, , 1:4, , 1:2, 1:3] -#'dim(exp) <- c(dataset = 1, member = 15, sdate = 4, ftime = 3, -#' lat = 2, lon = 3) -#'obs <- lonlat_temp$obs$data[, , 1:4, , 1:2, 1:3] -#'dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, -#' lat = 2, lon = 3) -#'exp_cor <- lonlat_temp$exp$data[, 1, 5:6, , 1:2, 1:3] -#'dim(exp_cor) <- c(dataset = 1, member = 1, sdate = 2, ftime = 3, -#' lat = 2, lon = 3) -#'res <- QuantileMapping(exp, obs, exp_cor, window_dim = 'ftime') -#'} -#' #'@import qmap #'@import multiApply #'@import s2dv #'@export QuantileMapping <- function(exp, obs, exp_cor = NULL, sdate_dim = 'sdate', memb_dim = 'member', window_dim = NULL, - method = 'QUANT', - na.rm = FALSE, ncores = NULL, ...) { + method = 'QUANT', na.rm = FALSE, + ncores = NULL, ...) { # exp and obs obsdims <- names(dim(obs)) expdims <- names(dim(exp)) @@ -218,6 +190,23 @@ QuantileMapping <- function(exp, obs, exp_cor = NULL, sdate_dim = 'sdate', if (any(!memb_dim %in% expdims)) { stop("Parameter 'memb_dim' is not found in 'exp' dimensions.") } + + # if (is.null(memb_dim)) { + # remove_member <- TRUE + # exp <- InsertDim(exp, posdim = 1, lendim = 1, name = 'member') + # obs <- InsertDim(obs, posdim = 1, lendim = 1, name = 'member') + # memb_dim <- 'member' + # } else { + # remove_member <- FALSE + # if (!all(memb_dim %in% obsdims)) { + # obs <- InsertDim(obs, posdim = 1, lendim = 1, + # name = memb_dim[!(memb_dim %in% obsdims)]) + # } + # if (any(!memb_dim %in% expdims)) { + # stop("Parameter 'memb_dim' is not found in 'exp' dimensions.") + # } + # } + sample_dims <- c(memb_dim, sdate_dim) # window_dim if (!is.null(window_dim)) { @@ -254,7 +243,10 @@ QuantileMapping <- function(exp, obs, exp_cor = NULL, sdate_dim = 'sdate', fun = .qmapcor, exp_cor = NULL, method = method, sdate_dim = sdate_dim, na.rm = na.rm, ..., ncores = ncores)$output1 - } + } + # if (remove_member) { + # dim(qmaped) <- dim(qmaped)[-which(names(dim(qmaped)) == 'member')] + # } return(qmaped) } diff --git a/R/CST_RFSlope.R b/R/CST_RFSlope.R index 84b49d11b78404548a1f96b4a0a3a04b44088ba6..66647845883536a2de8ff7a0b1a53e063a46ec22 100644 --- a/R/CST_RFSlope.R +++ b/R/CST_RFSlope.R @@ -26,29 +26,39 @@ #' The returned array has the same dimensions as the \code{exp} element of the #' input object, minus the dimensions specified by \code{lon_dim}, #' \code{lat_dim} and \code{time_dim}. -#'@import rainfarmr #'@examples -#'#Example using CST_RFSlope for a CSTools object #'exp <- 1 : (2 * 3 * 4 * 8 * 8) #'dim(exp) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) #'lon <- seq(10, 13.5, 0.5) -#'dim(lon) <- c(lon = length(lon)) #'lat <- seq(40, 43.5, 0.5) -#'dim(lat) <- c(lat = length(lat)) -#'data <- list(data = exp, lon = lon, lat = lat) +#'coords <- list(lon = lon, lat = lat) +#'data <- list(data = exp, coords = coords) +#'class(data) <- 's2dv_cube' #'slopes <- CST_RFSlope(data) -#'dim(slopes) -#'# dataset member sdate -#'# 1 2 3 -#'slopes -#'# [,1] [,2] [,3] -#'#[1,] 1.893503 1.893503 1.893503 -#'#[2,] 1.893503 1.893503 1.893503 +#'@import multiApply +#'@import rainfarmr +#'@importFrom ClimProjDiags Subset #'@export -CST_RFSlope <- function(data, kmin = 1, time_dim = NULL, ncores = 1) { +CST_RFSlope <- function(data, kmin = 1, time_dim = NULL, ncores = NULL) { + + # Check 's2dv_cube' + if (!inherits(data, "s2dv_cube")) { + stop("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + + # Check dimensions + if (!any(names(dim(data$data)) %in% .KnownLonNames()) | + !any(names(dim(data$data)) %in% .KnownLatNames())) { + stop("Spatial dimension names do not match any of the names accepted by ", + "the package.") + } + + lon_name <- names(dim(data$data))[[which(names(dim(data$data)) %in% .KnownLonNames())]] + lat_name <- names(dim(data$data))[[which(names(dim(data$data)) %in% .KnownLatNames())]] slopes <- RFSlope(data$data, kmin, time_dim, - lon_dim = "lon", lat_dim = "lat") + lon_dim = lon_name, lat_dim = lat_name) return(slopes) } @@ -82,31 +92,26 @@ CST_RFSlope <- function(data, kmin = 1, time_dim = NULL, ncores = 1) { #'(the logarithmic slope of k*|A(k)|^2 where A(k) are the spectral amplitudes). #'The returned array has the same dimensions as the input array, #'minus the dimensions specified by \code{lon_dim}, \code{lat_dim} and \code{time_dim}. -#'@import multiApply -#'@import rainfarmr -#'@importFrom ClimProjDiags Subset #'@examples #'# Example for the 'reduced' RFSlope function #'# Create a test array with dimension 8x8 and 20 timesteps, #'# 3 starting dates and 20 ensemble members. #'pr <- 1:(4*3*8*8*20) #'dim(pr) <- c(ensemble = 4, sdate = 3, lon = 8, lat = 8, ftime = 20) -#' #'# Compute the spectral slopes ignoring the wavenumber #'# corresponding to the largest scale (the box) -#'slopes <- RFSlope(pr, kmin=2) -#'dim(slopes) -#'# ensemble sdate -#'# 4 3 -#'slopes -#'# [,1] [,2] [,3] -#'#[1,] 1.893503 1.893503 1.893503 -#'#[2,] 1.893503 1.893503 1.893503 -#'#[3,] 1.893503 1.893503 1.893503 -#'#[4,] 1.893503 1.893503 1.893503 +#'slopes <- RFSlope(pr, kmin = 2, time_dim = 'ftime') +#'@import multiApply +#'@import rainfarmr +#'@importFrom ClimProjDiags Subset #'@export RFSlope <- function(data, kmin = 1, time_dim = NULL, - lon_dim = "lon", lat_dim = "lat", ncores = 1) { + lon_dim = "lon", lat_dim = "lat", ncores = NULL) { + # Know spatial coordinates names + if (!all(c(lon_dim, lat_dim) %in% names(dim(data)))) { + stop("Spatial coordinate names do not match data dimension names.") + } + if (length(ncores) > 1) { ncores = ncores[1] warning("Parameter 'ncores' has length > 1 and only the first element will be used.") @@ -127,7 +132,7 @@ RFSlope <- function(data, kmin = 1, time_dim = NULL, data <- .subset(data, lat_dim, 1:nmin) data <- .subset(data, lon_dim, 1:nmin) warning(paste("The input data have been cut to a square of", - nmin, "pixels on each side.")) + nmin, "pixels on each side.")) } # Check/detect time_dim @@ -171,11 +176,10 @@ RFSlope <- function(data, kmin = 1, time_dim = NULL, #'@return .RFSlope returns a scalar spectral slope using the RainFARM convention #'(the logarithmic slope of k*|A(k)|^2 where A(k) is the spectral amplitude). #'@noRd - .RFSlope <- function(pr, kmin) { if (any(is.na(pr))) { posna <- unlist(lapply(1:dim(pr)['rainfarm_samples'], - function(x){!is.na(pr[1, 1, x])})) + function(x){!is.na(pr[1, 1, x])})) pr <- Subset(pr, 'rainfarm_samples', posna) } fxp <- fft2d(pr) diff --git a/R/CST_RFTemp.R b/R/CST_RFTemp.R index 85f293a7936043db765a4199faef93655ec72056..c0879c63960009549ddc3494484a040612089b38 100644 --- a/R/CST_RFTemp.R +++ b/R/CST_RFTemp.R @@ -48,28 +48,32 @@ #' of the large-scale grid. #'@return CST_RFTemp() returns a downscaled CSTools object (i.e., of the class #''s2dv_cube'). -#'@import multiApply #'@examples #'# Generate simple synthetic data and downscale by factor 4 #'t <- rnorm(7 * 6 * 2 * 3 * 4)*10 + 273.15 + 10 #'dim(t) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 6, lon = 7) #'lon <- seq(3, 9, 1) #'lat <- seq(42, 47, 1) -#'exp <- list(data = t, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'exp <- list(data = t, coords = coords) #'attr(exp, 'class') <- 's2dv_cube' #'o <- runif(29*29)*3000 -#'dim(o) <- c(lat = 29, lon = 29) +#'dim(o) <- c(lats = 29, lons = 29) #'lon <- seq(3, 10, 0.25) #'lat <- seq(41, 48, 0.25) -#'oro <- list(data = o, lat = lat, lon = lon) +#'coords <- list(lat = lat, lon = lon) +#'oro <- list(data = o, coords = coords) #'attr(oro, 'class') <- 's2dv_cube' -#'res <- CST_RFTemp(exp, oro, xlim=c(4,8), ylim=c(43, 46), lapse=6.5) +#'res <- CST_RFTemp(data = exp, oro = oro, xlim = c(4,8), ylim = c(43, 46), +#' lapse = 6.5, time_dim = 'ftime', +#' lon_dim = 'lon', lat_dim = 'lat') +#'@import multiApply #'@export CST_RFTemp <- function(data, oro, xlim = NULL, ylim = NULL, lapse = 6.5, lon_dim = "lon", lat_dim = "lat", time_dim = NULL, nolapse = FALSE, verbose = FALSE, compute_delta = FALSE, method = "bilinear", delta = NULL) { - + # Check 's2dv_cube' if (!inherits(data, "s2dv_cube")) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -79,21 +83,52 @@ CST_RFTemp <- function(data, oro, xlim = NULL, ylim = NULL, lapse = 6.5, "as output by CSTools::CST_Load.") } if (!is.null(delta)) { - if (!inherits(delta, "s2dv_cube")) { - stop("Parameter 'delta' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } + if (!inherits(delta, "s2dv_cube")) { + stop("Parameter 'delta' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + } + # Check 's2dv_cube' structure + if (!all(c('data', 'coords') %in% names(data))) { + stop("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + if (!all(c('data', 'coords') %in% names(oro))) { + stop("Parameter 'oro' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + # Check coordinates + if (!any(names(data$coords) %in% .KnownLonNames()) | + !any(names(data$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of 'data' do not match any of the names ", + "accepted by the package.") } + if (!any(names(oro$coords) %in% .KnownLonNames()) | + !any(names(oro$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of 'oro' do not match any of the names ", + "accepted by the package.") + } + + lon_data <- names(data$coords)[[which(names(data$coords) %in% .KnownLonNames())]] + lat_data <- names(data$coords)[[which(names(data$coords) %in% .KnownLatNames())]] - res <- RFTemp(data$data, data$lon, data$lat, - oro$data, oro$lon, oro$lat, xlim, ylim, lapse, + lon_oro <- names(oro$coords)[[which(names(oro$coords) %in% .KnownLonNames())]] + lat_oro <- names(oro$coords)[[which(names(oro$coords) %in% .KnownLatNames())]] + + res <- RFTemp(data = data$data, + lon = as.vector(data$coords[[lon_data]]), + lat = as.vector(data$coords[[lat_data]]), + oro = oro$data, + lonoro = as.vector(oro$coords[[lon_oro]]), + latoro = as.vector(oro$coords[[lat_oro]]), + xlim = xlim, ylim = ylim, lapse = lapse, lon_dim = lon_dim, lat_dim = lat_dim, time_dim = time_dim, nolapse = nolapse, verbose = verbose, method = method, compute_delta = compute_delta, delta = delta$data) data$data <- res$data - data$lon <- res$lon - data$lat <- res$lat + data$coords[[lon_data]] <- res$coords[[lon_dim]] + data$coords[[lat_data]] <- res$coords[[lat_dim]] return(data) } @@ -148,7 +183,6 @@ CST_RFTemp <- function(data, oro, xlim = NULL, ylim = NULL, lapse = 6.5, #'@return CST_RFTemp() returns a downscaled CSTools object. #'@return RFTemp() returns a list containing the fine-scale #'longitudes, latitudes and the downscaled fields. -#'@import multiApply #'@examples #'# Generate simple synthetic data and downscale by factor 4 #'t <- rnorm(7 * 6 * 4 * 3) * 10 + 273.15 + 10 @@ -160,13 +194,19 @@ CST_RFTemp <- function(data, oro, xlim = NULL, ylim = NULL, lapse = 6.5, #'lono <- seq(3, 10, 0.25) #'lato <- seq(41, 48, 0.25) #'res <- RFTemp(t, lon, lat, o, lono, lato, xlim = c(4, 8), ylim = c(43, 46), -#' lapse = 6.5) +#' lapse = 6.5, time_dim = 'ftime') +#'@import multiApply #'@export RFTemp <- function(data, lon, lat, oro, lonoro, latoro, xlim = NULL, ylim = NULL, lapse = 6.5, lon_dim = "lon", lat_dim = "lat", time_dim = NULL, nolapse = FALSE, verbose = FALSE, compute_delta = FALSE, method = "bilinear", delta = NULL) { + # Check 'lon_dim' and 'lat_dim' parameters + if (!all(c(lon_dim, lat_dim) %in% names(dim(data)))) { + stop("Parameters 'lon_dim' and 'lat_dim' do not match with 'data' ", + "dimension names.") + } # Check/detect time_dim if (is.null(time_dim)) { @@ -210,6 +250,9 @@ RFTemp <- function(data, lon, lat, oro, lonoro, latoro, result$lat <- array(result$lat[1:dim(result$lat)[1]]) names(dim(result$lon)) <- lon_dim names(dim(result$lat)) <- lat_dim + + names(result) <- c('data', lon_dim, lat_dim) + return(result) } diff --git a/R/CST_RFWeights.R b/R/CST_RFWeights.R index cd328b1aa8bc9fcdd1665153b165ffe61d8cf8a7..c14aafa87b1eaa8ad1c8e2a6184cf5b4748d907a 100644 --- a/R/CST_RFWeights.R +++ b/R/CST_RFWeights.R @@ -39,25 +39,25 @@ #' #'@return An object of class 's2dv_cube' containing in matrix \code{data} the #'weights with dimensions (lon, lat). +#'@examples +#'# Create weights to be used with the CST_RainFARM() or RainFARM() functions +#'# using an external random data in the form of 's2dv_cube'. +#'obs <- rnorm(2 * 3 * 4 * 8 * 8) +#'dim(obs) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) +#'lon <- seq(10, 13.5, 0.5) +#'lat <- seq(40, 43.5, 0.5) +#'coords <- list(lon = lon, lat = lat) +#'data <- list(data = obs, coords = coords) +#'class(data) <- "s2dv_cube" +#'res <- CST_RFWeights(climfile = data, nf = 3, lon, lat, lonname = 'lon', +#' latname = 'lat', fsmooth = TRUE) #'@import ncdf4 #'@import rainfarmr #'@import multiApply #'@importFrom utils tail #'@importFrom utils head -#'@examples -#'# Create weights to be used with the CST_RainFARM() or RainFARM() functions -#'# using an external fine-scale climatology file. -#' -#'\dontrun{ -#'# Specify lon and lat of the input -#'lon <- seq(10,13.5,0.5) -#'lat <- seq(40,43.5,0.5) -#'nf <- 8 -#'ww <- CST_RFWeights("./worldclim.nc", nf, lon, lat, fsmooth = TRUE) -#'} #'@export -CST_RFWeights <- function(climfile, nf, lon, lat, varname = NULL, - fsmooth = TRUE, +CST_RFWeights <- function(climfile, nf, lon, lat, varname = NULL, fsmooth = TRUE, lonname = 'lon', latname = 'lat', ncores = NULL) { if (!inherits(climfile, "s2dv_cube")) { if (!is.null(varname) & !is.character(varname)) { @@ -91,9 +91,23 @@ CST_RFWeights <- function(climfile, nf, lon, lat, varname = NULL, zclim <- ncvar_get(ncin, varname) nc_close(ncin) } else if (inherits(climfile, "s2dv_cube")) { + # Check object structure + if (!all(c('data', 'coords') %in% names(climfile))) { + stop("Parameter 'climfile' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + # Check coordinates + if (!any(names(climfile$coords) %in% .KnownLonNames()) | + !any(names(climfile$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + } + loncoordname <- names(climfile$coords)[[which(names(climfile$coords) %in% .KnownLonNames())]] + latcoordname <- names(climfile$coords)[[which(names(climfile$coords) %in% .KnownLatNames())]] + zclim <- climfile$data - latin <- climfile$lat - lonin <- climfile$lon + latin <- as.vector(climfile$coords[[latcoordname]]) + lonin <- as.vector(climfile$coords[[loncoordname]]) } else { stop("Parameter 'climfile' is expected to be a character string indicating", " the path to the files or an object of class 's2dv_cube'.") @@ -107,10 +121,13 @@ CST_RFWeights <- function(climfile, nf, lon, lat, varname = NULL, lonname = lonname, latname = latname, ncores = ncores) if (inherits(climfile, "s2dv_cube")) { climfile$data <- result$data - climfile$lon <- result$lon - climfile$lat <- result$lat - } else { - climfile <- s2dv_cube(data = result, lon = result$lon, lat = result$lat) + climfile$coords[[loncoordname]] <- result[[lonname]] + climfile$coords[[latcoordname]] <- result[[latname]] + } else { + climfile <- NULL + climfile$data <- result + climfile$coords[[lonname]] <- result[[lonname]] + climfile$coords[[latname]] <- result[[latname]] } return(climfile) } @@ -148,26 +165,32 @@ CST_RFWeights <- function(climfile, nf, lon, lat, varname = NULL, #' #'@return An object of class 's2dv_cube' containing in matrix \code{data} the #'weights with dimensions (lon, lat). +#'@examples +#'a <- array(1:2500, c(lat = 50, lon = 50)) +#'res <- RF_Weights(a, seq(0.1 ,5, 0.1), seq(0.1 ,5, 0.1), +#' nf = 5, lat = 1:5, lon = 1:5) #'@import ncdf4 #'@import rainfarmr #'@import multiApply #'@importFrom utils tail #'@importFrom utils head -#'@examples -#'a <- array(1:2500, c(lat = 50, lon = 50)) -#'res <- RF_Weights(a, seq(0.1 ,5, 0.1), seq(0.1 ,5, 0.1), -#' nf = 5, lat = 1:5, lon = 1:5) #'@export RF_Weights <- function(zclim, latin, lonin, nf, lat, lon, fsmooth = TRUE, lonname = 'lon', latname = 'lat', ncores = NULL) { x <- Apply(list(zclim), target_dims = c(lonname, latname), fun = rf_weights, latin = latin, lonin = lonin, nf = nf, lat = lat, lon = lon, + lonname = lonname, latname = latname, fsmooth = fsmooth, ncores = ncores)$output1 - grid <- lon_lat_fine(lon, lat, nf) - return(list(data = x, lon = grid$lon, lat = grid$lat)) + grid <- lon_lat_fine(lon, lat, nf) + res <- NULL + res$data <- x + res[[lonname]] <- grid$lon + res[[latname]] <- grid$lon + return(res) } -rf_weights <- function(zclim, latin, lonin, nf, lat, lon, fsmooth = TRUE) { +rf_weights <- function(zclim, latin, lonin, nf, lat, lon, lonname = 'lon', + latname = 'lat', fsmooth = TRUE) { # Check if lon and lat need to be reversed if (lat[1] > lat[2]) { lat <- rev(lat) @@ -213,6 +236,6 @@ rf_weights <- function(zclim, latin, lonin, nf, lat, lon, fsmooth = TRUE) { if (frev) { ww <- ww[, seq(dim(ww)[2], 1)] } - attributes(dim(ww))$names <- c("lon", "lat") + attributes(dim(ww))$names <- c(lonname, latname) return(ww) } diff --git a/R/CST_RainFARM.R b/R/CST_RainFARM.R index 7d16cffd7493fd8abf416cb9da0317fda78a0d0d..282298c33b63b8b4951ad51f8184f05286072fa7 100644 --- a/R/CST_RainFARM.R +++ b/R/CST_RainFARM.R @@ -67,38 +67,68 @@ #'dependency, a dimension name should match between these parameters and the #'input data in parameter 'data'. See example 2 below where weights and slope #'vary with 'sdate' dimension. -#'@import multiApply -#'@import rainfarmr #'@examples #'# Example 1: using CST_RainFARM for a CSTools object #'nf <- 8 # Choose a downscaling by factor 8 #'exp <- 1 : (2 * 3 * 4 * 8 * 8) #'dim(exp) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) #'lon <- seq(10, 13.5, 0.5) -#'dim(lon) <- c(lon = length(lon)) #'lat <- seq(40, 43.5, 0.5) -#'dim(lat) <- c(lat = length(lat)) -#'data <- list(data = exp, lon = lon, lat = lat) +#'coords <- list(lon = lon, lat = lat) +#'data <- list(data = exp, coords = coords) +#'class(data) <- 's2dv_cube' #'# Create a test array of weights #'ww <- array(1., dim = c(lon = 8 * nf, lat = 8 * nf)) -#'res <- CST_RainFARM(data, nf = nf, weights = ww, nens = 3) +#'res <- CST_RainFARM(data, nf = nf, weights = ww, nens = 3, time_dim = 'ftime') +#'@import multiApply +#'@import rainfarmr +#'@importFrom ClimProjDiags Subset +#'@importFrom abind abind #'@export CST_RainFARM <- function(data, weights = 1., slope = 0, nf, kmin = 1, nens = 1, fglob = FALSE, fsmooth = TRUE, nprocs = 1, time_dim = NULL, verbose = FALSE, drop_realization_dim = FALSE) { + # Check 's2dv_cube' + if (!inherits(data, "s2dv_cube")) { + stop("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + # Check 'exp' object structure + if (!all(c('data', 'coords') %in% names(data))) { + stop("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + # Check coordinates + if (!any(names(data$coords) %in% .KnownLonNames()) | + !any(names(data$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + } + # Check dimensions + if (!any(names(dim(data$data)) %in% .KnownLonNames()) | + !any(names(dim(data$data)) %in% .KnownLatNames())) { + stop("Spatial dimension names do not match any of the names accepted by ", + "the package.") + } + + lon <- names(data$coords)[[which(names(data$coords) %in% .KnownLonNames())]] + lat <- names(data$coords)[[which(names(data$coords) %in% .KnownLatNames())]] + + lon_name <- names(dim(data$data))[[which(names(dim(data$data)) %in% .KnownLonNames())]] + lat_name <- names(dim(data$data))[[which(names(dim(data$data)) %in% .KnownLatNames())]] - res <- RainFARM(data$data, data$lon, data$lat, - nf = nf, weights = weights, nens, slope, kmin, fglob, fsmooth, - nprocs, time_dim, lon_dim = "lon", lat_dim = "lat", + res <- RainFARM(data = data$data, + lon = as.vector(data$coords[[lon]]), + lat = as.vector(data$coords[[lat]]), + nf = nf, weights = weights, nens, slope, kmin, + fglob, fsmooth, nprocs, time_dim, + lon_dim = lon_name, lat_dim = lat_name, drop_realization_dim, verbose) - att_lon <- attributes(data$lon)[-1] - att_lat <- attributes(data$lat)[-1] + data$data <- res$data - data$lon <- res$lon - attributes(data$lon) <- att_lon - data$lat <- res$lat - attributes(data$lat) <- att_lat + data$coords[[lon]] <- res[[lon_name]] + data$coords[[lat]] <- res[[lat_name]] return(data) } @@ -126,7 +156,7 @@ CST_RainFARM <- function(data, weights = 1., slope = 0, nf, kmin = 1, #'@param weights Multi-dimensional array with climatological weights which can #' be obtained using the \code{CST_RFWeights} function. If \code{weights=1.} #' (default) no weights are used. The names of these dimensions must be at -#' least 'lon' and 'lat'. +#' least the same longitudinal and latitudinal dimension names as data. #'@param nf Refinement factor for downscaling (the output resolution is #' increased by this factor). #'@param slope Prescribed spectral slope. The default is \code{slope=0.} @@ -172,36 +202,44 @@ CST_RainFARM <- function(data, weights = 1., slope = 0, nf, kmin = 1, #'dependency, a dimension name should match between these parameters and the #'input data in parameter 'data'. See example 2 below where weights and slope #'vary with 'sdate' dimension. -#'@import multiApply -#'@importFrom ClimProjDiags Subset -#'@importFrom abind abind #'@examples #'# Example for the 'reduced' RainFARM function #'nf <- 8 # Choose a downscaling by factor 8 -#'nens <- 3 # Number of ensemble members -#'# create a test array with dimension 8x8 and 20 timesteps -#'# or provide your own read from a netcdf file -#'pr <- rnorm(8 * 8 * 20) -#'dim(pr) <- c(lon = 8, lat = 8, ftime = 20) -#'lon_mat <- seq(10, 13.5, 0.5) # could also be a 2d matrix -#'lat_mat <- seq(40, 43.5, 0.5) +#'exp <- 1 : (2 * 3 * 4 * 8 * 8) +#'dim(exp) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) +#'lon <- seq(10, 13.5, 0.5) +#'lat <- seq(40, 43.5, 0.5) #'# Create a test array of weights #'ww <- array(1., dim = c(lon = 8 * nf, lat = 8 * nf)) -#'# downscale using weights (ww=1. means do not use weights) -#'res <- RainFARM(pr, lon_mat, lat_mat, nf, -#' fsmooth = TRUE, fglob = FALSE, -#' weights = ww, nens = 2, verbose = TRUE) +#'res <- RainFARM(data = exp, lon = lon, lat = lat, nf = nf, +#' weights = ww, nens = 3, time_dim = 'ftime') +#'@import multiApply +#'@import rainfarmr +#'@importFrom ClimProjDiags Subset +#'@importFrom abind abind #'@export -RainFARM <- function(data, lon, lat, nf, weights = 1., nens = 1, - slope = 0, kmin = 1, fglob = FALSE, fsmooth = TRUE, - nprocs = 1, time_dim = NULL, lon_dim = "lon", lat_dim = "lat", +RainFARM <- function(data, lon, lat, nf, weights = 1., nens = 1, slope = 0, + kmin = 1, fglob = FALSE, fsmooth = TRUE, nprocs = 1, + time_dim = NULL, lon_dim = "lon", lat_dim = "lat", drop_realization_dim = FALSE, verbose = FALSE) { + # Check 'lon_dim' and 'lat_dim' parameters + if (!all(c(lon_dim, lat_dim) %in% names(dim(data)))) { + stop("Parameters 'lon_dim' and 'lat_dim' do not match with 'data' ", + "dimension names.") + } + if (length(dim(weights)) > 0) { + if (!all(c(lon_dim, lat_dim) %in% names(dim(weights)))) { + stop("Parameters 'lon_dim' and 'lat_dim' do not match with 'weights' ", + "dimension names.") + } + } + # Ensure input grid is square and with even dimensions if ( (dim(data)[lon_dim] != dim(data)[lat_dim]) | (dim(data)[lon_dim] %% 2 == 1)) { warning("Warning: input data are expected to be on a square grid", - " with an even number of pixels per side.") + " with an even number of pixels per side.") nmin <- min(dim(data)[lon_dim], dim(data)[lat_dim]) nmin <- floor(nmin / 2) * 2 data <- .subset(data, lat_dim, 1:nmin) @@ -215,19 +253,19 @@ RainFARM <- function(data, lon, lat, nf, weights = 1., nens = 1, } warning("The input data have been cut to the range.") warning(paste0("lon: [", lon[1], ", ", lon[length(lon)], "] ", - " lat: [", lat[1], ", ", lat[length(lat)], "]")) + " lat: [", lat[1], ", ", lat[length(lat)], "]")) } if (length(dim(weights)) > 0) { if (length(names(dim(weights))) == 0) { stop("Parameter 'weights' must have dimension names when it is not a scalar.") } else { - if (length(which(names(dim(weights)) == 'lon')) > 0 & - length(which(names(dim(weights)) == 'lat')) > 0) { - lonposw <- which(names(dim(weights)) == 'lon') - latposw <- which(names(dim(weights)) == 'lat') + if (length(which(names(dim(weights)) == lon_dim)) > 0 & + length(which(names(dim(weights)) == lat_dim)) > 0) { + lonposw <- which(names(dim(weights)) == lon_dim) + latposw <- which(names(dim(weights)) == lat_dim) } else { - stop("Parameter 'weights' must have dimension names 'lon' and 'lat' when", - " it is not a scalar.") + stop("Parameter 'weights' must have dimension names equal to latitudinal", + " and longitudinal dimension names as 'data' when it is not a scalar.") } } } @@ -267,8 +305,8 @@ RainFARM <- function(data, lon, lat, nf, weights = 1., nens = 1, # Perform common calls r <- lon_lat_fine(lon, lat, nf) - lon_f <- r$lon - lat_f <- r$lat + lon_f <- r[['lon']] + lat_f <- r[['lat']] # reorder and group time_dim together at the end cdim0 <- dim(data) @@ -334,7 +372,13 @@ RainFARM <- function(data, lon, lat, nf, weights = 1., nens = 1, names(dim(result))[ind] <- "member" } } - return(list(data = result, lon = lon_f, lat = lat_f)) + + res <- NULL + res[['data']] <- result + res[[lon_dim]] <- lon_f + res[[lat_dim]] <- lat_f + + return(res) } #'Atomic RainFARM diff --git a/R/CST_RegimesAssign.R b/R/CST_RegimesAssign.R index f3ae5ecd21b88114c80d5017b688ee85726a7db2..4621f867e9cd703a8a6b560c503a646843e51e48 100644 --- a/R/CST_RegimesAssign.R +++ b/R/CST_RegimesAssign.R @@ -7,7 +7,7 @@ #'@description This function performs the matching between a field of anomalies #'and a set of maps which will be used as a reference. The anomalies will be #'assigned to the reference map for which the minimum Eucledian distance -#'(method=’distance’) or highest spatial correlation (method = 'ACC') is +#'(method =’distance’) or highest spatial correlation (method = 'ACC') is #'obtained. #' #'@references Torralba, V. (2019) Seasonal climate prediction for the wind @@ -37,43 +37,52 @@ #'indicating the ref_maps to which each point is allocated.), \code{$frequency} #'(A vector of integers (from k=1,...k n reference maps) indicating the #'percentage of assignations corresponding to each map.). -#'@importFrom s2dv ACC MeanDims InsertDim -#'@import multiApply #'@examples -#'\dontrun{ -#'regimes <- CST_WeatherRegimes(data = lonlat_temp$obs, EOFs = FALSE, +#'data <- array(abs(rnorm(1280, 282.7, 6.4)), dim = c(dataset = 2, member = 2, +#' sdate = 3, ftime = 3, +#' lat = 4, lon = 4)) +#'coords <- list(lon = seq(0, 3), lat = seq(47, 44)) +#'exp <- list(data = data, coords = coords) +#'class(exp) <- 's2dv_cube' +#'regimes <- CST_WeatherRegimes(data = exp, EOFs = FALSE, #' ncenters = 4) -#'res1 <- CST_RegimesAssign(data = lonlat_temp$exp, ref_maps = regimes, +#'res1 <- CST_RegimesAssign(data = exp, ref_maps = regimes, #' composite = FALSE) -#'res2 <- CST_RegimesAssign(data = lonlat_temp$exp, ref_maps = regimes, -#' composite = TRUE) -#'} +#'@importFrom s2dv ACC MeanDims InsertDim +#'@import multiApply #'@export -CST_RegimesAssign <- function(data, ref_maps, +CST_RegimesAssign <- function(data, ref_maps, method = "distance", composite = FALSE, - memb = FALSE, ncores = NULL) { + memb = FALSE, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } - if (!inherits(ref_maps, 's2dv_cube')) { stop("Parameter 'ref_maps' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } - - if ('lat' %in% names(data)){ - lat <- data$lat + # Check 'exp' object structure + if (!all(c('data', 'coords') %in% names(data))) { + stop("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + # Check coordinates + if (!any(names(data$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted ", + "the package.") } else { - lat <- NULL + lat_name <- names(data$coords)[[which(names(data$coords) %in% .KnownLatNames())]] + lat <- as.vector(data$coords[[lat_name]]) } - result <- Apply(data = list(data = data$data, ref_maps = ref_maps$data), - lat = lat, fun = RegimesAssign, - target_dims = list(names(dim(data$data)), c('lat', 'lon', 'cluster')), - method = method, memb = memb, composite = composite, ncores = ncores) + + result <- RegimesAssign(data = data$data, ref_maps = ref_maps$data, lat = lat, + method = method, composite = composite, + memb = memb, ncores = ncores) - if (composite){ + if (composite) { data$data <- result$composite data$statistics <- result[-1] } else { @@ -128,58 +137,70 @@ CST_RegimesAssign <- function(data, ref_maps, #'reference maps) indicating the percentage of assignations corresponding to #'each map.), #' -#'@importFrom s2dv ACC MeanDims Eno InsertDim -#'@import multiApply #'@examples -#'\dontrun{ -#'regimes <- WeatherRegime(data = lonlat_temp$obs$data, lat = lonlat_temp$obs$lat, +#'data <- array(abs(rnorm(1280, 282.7, 6.4)), dim = c(dataset = 2, member = 2, +#' sdate = 3, ftime = 3, +#' lat = 4, lon = 4)) +#'regimes <- WeatherRegime(data = data, lat = seq(47, 44), #' EOFs = FALSE, ncenters = 4)$composite -#'res1 <- RegimesAssign(data = lonlat_temp$exp$data, ref_maps = drop(regimes), -#' lat = lonlat_temp$exp$lat, composite = FALSE) -#'} +#'res1 <- RegimesAssign(data = data, ref_maps = drop(regimes), +#' lat = seq(47, 44), composite = FALSE) +#'@importFrom s2dv ACC MeanDims Eno InsertDim +#'@import multiApply #'@export RegimesAssign <- function(data, ref_maps, lat, method = "distance", composite = FALSE, memb = FALSE, ncores = NULL) { - + ## Initial checks + # data if (is.null(names(dim(data)))) { stop("Parameter 'data' must be an array with named dimensions.") } + # ref_maps if (is.null(ref_maps)) { stop("Parameter 'ref_maps' must be specified.") } - - if (is.null(lat)) { - stop("Parameter 'lat' must be specified.") - } if (is.null(names(dim(ref_maps)))) { stop("Parameter 'ref_maps' must be an array with named dimensions.") } + # lat + if (is.null(lat)) { + stop("Parameter 'lat' must be specified.") + } + # memb if (!is.logical(memb)) { stop("Parameter 'memb' must be logical.") } + # composite if (!is.logical(composite)) { stop("Parameter 'memb' must be logical.") } dimData <- names(dim(data)) - - if (!all( c('lat', 'lon') %in% dimData)) { - stop("Parameter 'data' must contain the named dimensions 'lat' and 'lon'.") + # Know spatial coordinates names + if (!any(dimData %in% .KnownLonNames()) | + !any(dimData %in% .KnownLatNames())) { + stop("Spatial coordinate dimension names do not match any of the names ", + "accepted by the package.") } - + lon_name <- dimData[[which(dimData %in% .KnownLonNames())]] + lat_name <- dimData[[which(dimData %in% .KnownLatNames())]] dimRef <- names(dim(ref_maps)) - - if (!all( c('cluster', 'lat', 'lon') %in% dimRef)) { + if (!any(dimRef %in% .KnownLonNames()) | + !any(dimRef %in% .KnownLatNames())) { + stop("Spatial coordinate dimension names do not match any of the names ", + "accepted by the package.") + } + lon_name_ref <- dimRef[[which(dimRef %in% .KnownLonNames())]] + lat_name_ref <- dimRef[[which(dimRef %in% .KnownLatNames())]] + if (!all( c('cluster', lat_name_ref, lon_name_ref) %in% dimRef)) { stop("Parameter 'ref_maps' must contain the named dimensions - 'cluster','lat' and 'lon'.") + 'cluster', and the spatial coordinates accepted names.") } - - - if (length(lat) != dim(data)['lat'] | (length(lat) != dim(ref_maps)['lat']) ) { - stop(" Parameter 'lat' does not match with the dimension 'lat' in the - parameter 'data' or in the parameter 'ref_maps'.") + if (length(lat) != dim(data)[lat_name] | + (length(lat) != dim(ref_maps)[lat_name_ref])) { + stop("Parameter 'lat' does not match with the latitudinal dimension", + " in the parameter 'data' or in the parameter 'ref_maps'.") } - - + # Temporal dimensions if ('sdate' %in% dimData && 'ftime' %in% dimData) { nsdates <- dim(data)['sdate'] nftimes <- dim(data)['ftime'] @@ -195,9 +216,12 @@ RegimesAssign <- function(data, ref_maps, lat, method = "distance", composite = } ref_maps <- drop(ref_maps) index <- Apply(data = list(ref = ref_maps, target = data), - target_dims = list(c('lat', 'lon', 'cluster'), c('lat', 'lon')), + target_dims = list(c(lat_name_ref, lon_name_ref, 'cluster'), + c(lat_name, lon_name)), fun = .RegimesAssign, lat = lat, method = method, + lon_name = lon_name, lat_name = lat_name, + lon_name_ref = lon_name_ref, lat_name_ref = lat_name_ref, ncores = ncores)[[1]] nclust <- dim(ref_maps)['cluster'] @@ -207,8 +231,8 @@ RegimesAssign <- function(data, ref_maps, lat, method = "distance", composite = } if (composite) { - poslon <- which(names(dim(data)) == 'lon') - poslat <- which(names(dim(data)) == 'lat') + poslon <- which(names(dim(data)) == lon_name) + poslat <- which(names(dim(data)) == lat_name) postime <- which(names(dim(data)) == 'time') posdim <- setdiff(1:length(dim(data)), c(postime, poslat, poslon)) dataComp <- aperm(data, c(poslon, poslat, postime, posdim)) @@ -224,19 +248,16 @@ RegimesAssign <- function(data, ref_maps, lat, method = "distance", composite = dataComp <- MergeDims(dataComp, merge_dims = c('time', 'member'), rename_dim = 'time') index <- MergeDims(index, merge_dims = c('time', 'member'), rename_dim = 'time') } - recon <- - Apply(data = list(var = dataComp, occ = index), - target_dims = list(c('lon', 'lat', 'time'), c('time')), - fun = Composite, - K = dim(ref_maps)['cluster']) + recon <- Apply(data = list(var = dataComp, occ = index), + target_dims = list(c(lon_name, lat_name, 'time'), c('time')), + fun = Composite, + K = dim(ref_maps)['cluster']) } - output <- list(composite = recon$composite, pvalue = recon$pvalue, cluster = index, frequency = freqs) } else { - output <- list(cluster = index, frequency = freqs) } @@ -244,82 +265,77 @@ RegimesAssign <- function(data, ref_maps, lat, method = "distance", composite = return(output) } -.RegimesAssign <- function(ref, target, method = 'distance', lat, composite = FALSE) { +.RegimesAssign <- function(ref, target, method = 'distance', lat, + composite = FALSE, + lon_name = 'lon', lat_name = 'lat', + lon_name_ref = 'lon', lat_name_ref = 'lat') { - # ref: c('lat', 'lon', 'cluster') - # target: c('lat', 'lon') + # ref: [lat_name_ref, lon_name_ref, 'cluster'] + # target: [lat_name, lon_name] posdim <- which(names(dim(ref)) == 'cluster') - poslat <- which(names(dim(ref)) == 'lat') - poslon <- which(names(dim(ref)) == 'lon') + poslat <- which(names(dim(ref)) == lat_name_ref) + poslon <- which(names(dim(ref)) == lon_name_ref) nclust <- dim(ref)[posdim] if (all(dim(ref)[-posdim] != dim(target))) { - stop('The target should have the same dimensions [lat,lon] that - the reference ') + stop('The target should have the same dimensions [lat_name, lon_name] that', + 'the reference ') } - if (is.null(names(dim(ref))) | is.null(names(dim(target)))) { - stop( - 'The arrays should include dimensions names ref[cluster,lat,lon] - and target [lat,lon]' + stop('The arrays should include dimensions names ref[cluster, lat_name, ', + 'lon_name] and target [lat_name, lon_name]' ) } - - if (length(lat) != dim(ref)[poslat]) { stop('latitudes do not match with the maps') } - if (is.na(max(target))){ assign <- NA - - } else{ - - - # This dimensions are reorganized - ref <- aperm(ref, c(posdim, poslat, poslon)) - target <- aperm(target, - c(which(names(dim(target)) == 'lat'), - which(names(dim(target)) == 'lon'))) - - # weights are defined - latWeights <- InsertDim(sqrt(cos(lat * pi / 180)), 2, dim(ref)[3]) - - - rmsdiff <- function(x, y) { - dims <- dim(x) - ndims <- length(dims) - if (ndims != 2 | ndims != length(dim(y))) { - stop('x and y should be maps') - } - map_diff <- NA * x - for (i in 1:dims[1]) { - for (j in 1:dims[2]) { - map_diff[i, j] <- (x[i, j] - y[i, j]) ^ 2 + } else { + # This dimensions are reorganized + ref <- aperm(ref, c(posdim, poslat, poslon)) + target <- aperm(target, + c(which(names(dim(target)) == lat_name), + which(names(dim(target)) == lon_name))) + + # weights are defined + latWeights <- InsertDim(sqrt(cos(lat * pi / 180)), 2, dim(ref)[3]) + + rmsdiff <- function(x, y) { + dims <- dim(x) + ndims <- length(dims) + if (ndims != 2 | ndims != length(dim(y))) { + stop('x and y should be maps') + } + map_diff <- NA * x + for (i in 1:dims[1]) { + for (j in 1:dims[2]) { + map_diff[i, j] <- (x[i, j] - y[i, j]) ^ 2 + } } + rmsdiff <- sqrt(mean(map_diff)) + return(rmsdiff) } - rmsdiff <- sqrt(mean(map_diff)) - return(rmsdiff) - } - - if (method == 'ACC') { - corr <- rep(NA, nclust) - for (i in 1:nclust) { - #NOTE: s2dv::ACC returns centralized and weighted result. - corr[i] <- - ACC(ref[i, , ], target, lat = lat, dat_dim = NULL, avg_dim = NULL, memb_dim = NULL)$acc + + if (method == 'ACC') { + corr <- rep(NA, nclust) + for (i in 1:nclust) { + #NOTE: s2dv::ACC returns centralized and weighted result. + corr[i] <- + ACC(ref[i, , ], target, lat = lat, dat_dim = NULL, avg_dim = NULL, + memb_dim = NULL)$acc + } + assign <- which(corr == max(corr)) } - assign <- which(corr == max(corr)) - } - - if (method == 'distance') { - rms <- rep(NA, nclust) - for (i in 1:nclust) { - rms[i] <- rmsdiff(ref[i, , ] * latWeights, target * latWeights) + + if (method == 'distance') { + rms <- rep(NA, nclust) + for (i in 1:nclust) { + rms[i] <- rmsdiff(ref[i, , ] * latWeights, target * latWeights) + } + assign <- which(rms == min(rms)) } - assign <- which(rms == min(rms)) - } } return(assign) diff --git a/R/CST_SaveExp.R b/R/CST_SaveExp.R index 64b06fa50be6a8ff84ad8b50c7fb557b8b491b6c..2130aadde6838b61c040860be99af73f2e88d018 100644 --- a/R/CST_SaveExp.R +++ b/R/CST_SaveExp.R @@ -1,304 +1,847 @@ -#'Save CSTools objects of class 's2dv_cube' containing experiments or observed -#'data in NetCDF format +#'Save objects of class 's2dv_cube' to data in NetCDF format #' #'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es} #' #'@description This function allows to divide and save a object of class #''s2dv_cube' into a NetCDF file, allowing to reload the saved data using -#'\code{CST_Load} function. +#'\code{Start} function from StartR package. If the original 's2dv_cube' object +#'has been created from \code{CST_Load()}, then it can be reloaded with +#'\code{Load()}. #' #'@param data An object of class \code{s2dv_cube}. #'@param destination A character string containing the directory name in which #' to save the data. NetCDF file for each starting date are saved into the #' folder tree: \cr -#' destination/experiment/variable/. By default the function -#' creates and saves the data into the folder "CST_Data" in the working -#' directory. +#' destination/Dataset/variable/. By default the function +#' creates and saves the data into the working directory. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. By default, it is set to 'sdate'. It can be NULL if there is no +#' start date dimension. +#'@param ftime_dim A character string indicating the name of the forecast time +#' dimension. By default, it is set to 'time'. It can be NULL if there is no +#' forecast time dimension. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' By default, it is set to 'dataset'. It can be NULL if there is no dataset +#' dimension. +#'@param var_dim A character string indicating the name of variable dimension. +#' By default, it is set to 'var'. It can be NULL if there is no variable +#' dimension. +#'@param memb_dim A character string indicating the name of the member dimension. +#' By default, it is set to 'member'. It can be NULL if there is no member +#' dimension. +#'@param single_file A logical value indicating if all object is saved in a +#' single file (TRUE) or in multiple files (FALSE). When it is FALSE, +#' the array is separated for Datasets, variable and start date. It is FALSE +#' by default. #'@param extra_string A character string to be include as part of the file name, #' for instance, to identify member or realization. It would be added to the #' file name between underscore characters. #' -#'@seealso \code{\link{CST_Load}}, \code{\link{as.s2dv_cube}} and \code{\link{s2dv_cube}} -#' -#'@import ncdf4 -#'@importFrom s2dv Reorder InsertDim -#'@import multiApply +#'@return If single_file is TRUE only one file is created. If single_file is +#'FALSE multiple files are created. When multiple files are created, each file +#'contains the data subset for each start date, variable and dataset. Files +#'with different variables and Datasets are stored in separated directories. +#'The path will be created with the name of the variable and each start date. +#'NetCDF file for each starting date are saved into the +#' folder tree: \cr +#' destination/Dataset/variable/. +#' +#'@seealso \code{\link[startR]{Start}}, \code{\link{as.s2dv_cube}} and +#'\code{\link{s2dv_cube}} #' #'@examples #'\dontrun{ -#'library(CSTools) #'data <- lonlat_temp$exp -#'destination <- "./path2/" -#'CST_SaveExp(data = data, destination = destination) +#'destination <- "./" +#'CST_SaveExp(data = data, destination = destination, ftime_dim = 'ftime', +#' var_dim = NULL, ftime_dim = 'ftime', var_dim = NULL) #'} #' +#'@import ncdf4 +#'@importFrom s2dv Reorder +#'@importFrom ClimProjDiags Subset +#'@import multiApply #'@export -CST_SaveExp <- function(data, destination = "./CST_Data", extra_string = NULL) { - if (!is.character(destination) & length(destination) > 1) { - stop("Parameter 'destination' must be a character string of one element ", - "indicating the name of the file (including the folder if needed) ", - "where the data will be saved.") - } +CST_SaveExp <- function(data, destination = "./", sdate_dim = 'sdate', + ftime_dim = 'time', dat_dim = 'dataset', + var_dim = 'var', memb_dim = 'member', + single_file = FALSE, extra_string = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } - sdates <- lapply(1:length(data$Datasets), function(x) { - unique(data$Datasets[[x]]$InitializationDates)})[[1]] - if (!is.character(attributes(data$Variable)$units)) { - units <- attributes(data$Variable)$variable$units + # Check object structure + if (!all(c('data', 'attrs') %in% names(data))) { + stop("Parameter 'data' must have at least 'data' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + } + if (!inherits(data$attrs, 'list')) { + stop("Level 'attrs' must be a list with at least 'Dates' element.") + } + if (!all(c('coords') %in% names(data))) { + warning("Element 'coords' not found. No coordinates will be used.") + } + # metadata + if (is.null(data$attrs$Variable$metadata)) { + warning("No metadata found in element Variable from attrs.") } else { - units <- attributes(data$Variable)$units - } - cdo_grid_name = attr(data$lon, 'cdo_grid_name') - projection = attr(data$lon, 'projection') - var_name <- data$Variable$varName - time_values <- data$Dates$start - dim(time_values) <- c(time = length(time_values) / length(sdates), - sdate = length(sdates)) - SaveExp(data = data$data, lon = data$lon, lat = data$lat, - Dataset = names(data$Datasets), var_name = var_name, - units = units, cdo_grid_name = cdo_grid_name, projection = projection, - startdates = sdates, Dates = time_values, destination, - extra_string = extra_string) -} -#'Save an experiment in a format compatible with CST_Load -#'@description This function is created for compatibility with CST_Load/Load for -#'saving post-processed datasets such as those calibrated of downscaled with -#'CSTools functions + if (!inherits(data$attrs$Variable$metadata, 'list')) { + stop("Element metadata from Variable element in attrs must be a list.") + } + if (!any(names(data$attrs$Variable$metadata) %in% names(data$coords))) { + warning("Metadata is not found for any coordinate.") + } else if (!any(names(data$attrs$Variable$metadata) %in% + data$attrs$Variable$varName)) { + warning("Metadata is not found for any variable.") + } + } + # Dates + if (is.null(data$attrs$Dates)) { + stop("Element 'Dates' from 'attrs' level cannot be NULL.") + } + if (is.null(dim(data$attrs$Dates))) { + stop("Element 'Dates' from 'attrs' level must have time dimensions.") + } + # sdate_dim + if (!is.null(sdate_dim)) { + if (!is.character(sdate_dim)) { + stop("Parameter 'sdate_dim' must be a character string.") + } + if (length(sdate_dim) > 1) { + warning("Parameter 'sdate_dim' has length greater than 1 and ", + "only the first element will be used.") + sdate_dim <- sdate_dim[1] + } + } else { + if (length(dim(data$attrs$Dates)) == 1) { + sdate_dim <- 'sdate' + dim(data$data) <- c(sdate = 1, dim(data$data)) + data$dims <- dim(data$data) + dim(data$attrs$Dates) <- c(sdate = 1, dim(data$attrs$Dates)) + data$coords[[sdate_dim]] <- data$attrs$Dates[1] + } + } + + SaveExp(data = data$data, + destination = destination, + Dates = data$attrs$Dates, + coords = data$coords, + varname = data$attrs$Variable$varName, + metadata = data$attrs$Variable$metadata, + Datasets = data$attrs$Datasets, + startdates = data$coords[[sdate_dim]], + dat_dim = dat_dim, sdate_dim = sdate_dim, + ftime_dim = ftime_dim, var_dim = var_dim, + memb_dim = memb_dim, + extra_string = extra_string, + single_file = single_file) +} +#'Save a multidimensional array with metadata to data in NetCDF format +#'@description This function allows to save a data array with metadata into a +#'NetCDF file, allowing to reload the saved data using \code{Start} function +#'from StartR package. If the original 's2dv_cube' object has been created from +#'\code{CST_Load()}, then it can be reloaded with \code{Load()}. #' #'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es} #' -#'@param data An multi-dimensional array with named dimensions (longitude, -#' latitude, time, member, sdate). -#'@param lon Vector of logitud corresponding to the longitudinal dimension in -#' data. -#'@param lat Vector of latitud corresponding to the latitudinal dimension in -#' data. -#'@param Dataset A vector of character string indicating the names of the -#' datasets. -#'@param var_name A character string indicating the name of the variable to be +#'@param data A multi-dimensional array with named dimensions. +#'@param destination A character string indicating the path where to store the +#' NetCDF files. +#'@param Dates An named array of dates with the corresponding sdate and forecast +#' time dimension. +#'@param coords A named list with elements of the coordinates corresponding to +#' the dimensions of the data parameter. The names and length of each element +#' must correspond to the names of the dimensions. If any coordinate is not +#' provided, it is set as an index vector with the values from 1 to the length +#' of the corresponding dimension. +#'@param varname A character string indicating the name of the variable to be #' saved. -#'@param units A character string indicating the units of the variable. +#'@param metadata A named list where each element is a variable containing the +#' corresponding information. The information must be contained in a list of +#' lists for each variable. +#'@param Datasets A vector of character string indicating the names of the +#' datasets. #'@param startdates A vector of dates indicating the initialization date of each #' simulations. -#'@param Dates A matrix of dates with two dimension 'time' and 'sdate'. -#'@param cdo_grid_name A character string indicating the name of the grid e.g.: -#' 'r360x181' -#'@param projection A character string indicating the projection name. -#'@param destination A character string indicating the path where to store the -#' NetCDF files. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. By default, it is set to 'sdate'. It can be NULL if there is no +#' start date dimension. +#'@param ftime_dim A character string indicating the name of the forecast time +#' dimension. By default, it is set to 'time'. It can be NULL if there is no +#' forecast time dimension. +#'@param dat_dim A character string indicating the name of dataset dimension. +#' By default, it is set to 'dataset'. It can be NULL if there is no dataset +#' dimension. +#'@param var_dim A character string indicating the name of variable dimension. +#' By default, it is set to 'var'. It can be NULL if there is no variable +#' dimension. +#'@param memb_dim A character string indicating the name of the member dimension. +#' By default, it is set to 'member'. It can be NULL if there is no member +#' dimension. +#'@param single_file A logical value indicating if all object is saved in a +#' unique file (TRUE) or in separated directories (FALSE). When it is FALSE, +#' the array is separated for Datasets, variable and start date. It is FALSE +#' by default. #'@param extra_string A character string to be include as part of the file name, -#' for instance, to identify member or realization. +#' for instance, to identify member or realization. It would be added to the +#' file name between underscore characters. #' -#'@return The function creates as many files as sdates per dataset. Each file -#'could contain multiple members. It would be added to the file name between -#'underscore characters. The path will be created with the name of the variable -#'and each Datasets. +#'@return If single_file is TRUE only one file is created. If single_file is +#'FALSE multiple files are created. When multiple files are created, each file +#'contains the data subset for each start date, variable and dataset. Files +#'with different variables and Datasets are stored in separated directories. +#'The path will be created with the name of the variable and each start date. +#'NetCDF file for each starting date are saved into the +#' folder tree: \cr +#' destination/Dataset/variable/. #' -#'@import ncdf4 -#'@importFrom s2dv Reorder InsertDim -#'@import multiApply -#' #'@examples #'\dontrun{ #'data <- lonlat_temp$exp$data -#'lon <- lonlat_temp$exp$lon -#'lat <- lonlat_temp$exp$lat -#'Dataset <- 'XXX' -#'var_name <- 'tas' -#'units <- 'k' -#'startdates <- lapply(1:length(lonlat_temp$exp$Datasets), -#' function(x) { -#' lonlat_temp$exp$Datasets[[x]]$InitializationDates[[1]]})[[1]] -#'Dates <- lonlat_temp$exp$Dates$start -#'dim(Dates) <- c(time = length(Dates)/length(startdates), sdate = length(startdates)) -#'cdo_grid_name = attr(lonlat_temp$exp$lon, 'cdo_grid_name') -#'projection = attr(lonlat_temp$exp$lon, 'projection') -#'destination = './path/' -#'SaveExp(data, lon, lat, Dataset, var_name, units, startdates, Dates, -#' cdo_grid_name, projection, destination) +#'lon <- lonlat_temp$exp$coords$lon +#'lat <- lonlat_temp$exp$coords$lat +#'coords <- list(lon = lon, lat = lat) +#'Datasets <- lonlat_temp$exp$attrs$Datasets +#'varname <- 'tas' +#'Dates <- lonlat_temp$exp$attrs$Dates +#'destination = './' +#'metadata <- lonlat_temp$exp$attrs$Variable$metadata +#'SaveExp(data = data, destination = destination, coords = coords, +#' Datasets = Datasets, varname = varname, Dates = Dates, +#' metadata = metadata, single_file = TRUE, ftime_dim = 'ftime', +#' var_dim = NULL) #'} +#'@import ncdf4 +#'@importFrom s2dv Reorder +#'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export -SaveExp <- function(data, lon, lat, Dataset, var_name, units, startdates, Dates, - cdo_grid_name, projection, destination, - extra_string = NULL) { - dimname <- names(dim(data)) - if (any(dimname == "ftime")) { - dimname[which(dimname == "ftime")] <- "time" - names(dim(data))[which(dimname == "ftime")] <- "time" - } - if (any(dimname == "memb")) { - dimname[which(dimname == "memb")] <- "member" - names(dim(data))[which(dimname == "memb")] <- "member" - } - if (any(dimname == "ensemble")) { - dimname[which(dimname == "ensemble")] <- "member" - names(dim(data))[which(dimname == "ensemble")] <- "member" - } - if (any(dimname == "lon")) { - dimname[which(dimname == "lon")] <- "longitude" - names(dim(data))[which(dimname == "lon")] <- "longitude" - } - if (any(dimname == "lat")) { - dimname[which(dimname == "lat")] <- "latitude" - names(dim(data))[which(dimname == "lat")] <- "latitude" - } - names(dim(data)) <- dimname - if (is.null(dimname)) { - stop("Element 'data' in parameter 'data' must have named dimensions.") - } - sdate_pos <- which(dimname == "sdate") - - if (length(sdate_pos) == 0) { - stop("Element 'data' in parameter 'data' hasn't 'sdate' dimension.") - } else if (length(sdate_pos) > 1) { - stop("Element 'data' in parameter 'data' has more than one 'sdate'", - " dimension.") +SaveExp <- function(data, destination = "./", Dates = NULL, coords = NULL, + varname = NULL, metadata = NULL, Datasets = NULL, + startdates = NULL, dat_dim = 'dataset', sdate_dim = 'sdate', + ftime_dim = 'time', var_dim = 'var', memb_dim = 'member', + single_file = FALSE, extra_string = NULL) { + ## Initial checks + # data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + dimnames <- names(dim(data)) + if (is.null(dimnames)) { + stop("Parameter 'data' must be an array with named dimensions.") + } + # destination + if (!is.character(destination) | length(destination) > 1) { + stop("Parameter 'destination' must be a character string of one element ", + "indicating the name of the file (including the folder if needed) ", + "where the data will be saved.") + } + # Dates + if (!is.null(Dates)) { + if (!inherits(Dates, "POSIXct") & !inherits(Dates, "Date")) { + stop("Parameter 'Dates' must be of 'POSIXct' or 'Dates' class.") + } + if (is.null(dim(Dates))) { + stop("Parameter 'Dates' must have dimension names.") + } + } + # coords + if (!is.null(coords)) { + if (!all(names(coords) %in% dimnames)) { + coords <- coords[-which(!names(coords) %in% dimnames)] + } + for (i_coord in dimnames) { + if (i_coord %in% names(coords)) { + if (length(coords[[i_coord]]) != dim(data)[i_coord]) { + warning(paste0("Coordinate '", i_coord, "' has different lenght as ", + "its dimension and it will not be used.")) + coords[[i_coord]] <- 1:dim(data)[i_coord] + } + } else { + warning(paste0("Coordinate '", i_coord, "' is not provided ", + "and it will be set as index in element coords.")) + coords[[i_coord]] <- 1:dim(data)[i_coord] + } + } + } else { + coords <- sapply(dimnames, function(x) 1:dim(data)[x]) + } + # varname + if (is.null(varname)) { + warning("Parameter 'varname' is NULL. It will be assigned to 'X'.") + varname <- 'X' + } else if (length(varname) > 1) { + multiple_vars <- TRUE + } else { + multiple_vars <- FALSE + } + if (!all(sapply(varname, is.character))) { + stop("Parameter 'varname' must be a character string with the ", + "variable names.") + } + # metadata + if (is.null(metadata)) { + warning("Parameter 'metadata' is not provided so the metadata saved ", + "will be incomplete.") + } + # single_file + if (!inherits(single_file, 'logical')) { + warning("Parameter 'single_file' must be a logical value. It will be ", + "set as FALSE.") + single_file <- FALSE } + if (single_file) { + warning("Parameter 'single_file' is TRUE. Time values saved in the NetCDF ", + "file may not be consistent for all the start dates. ", + "Further development is needed, sorry for the inconvinience.") + } + # extra_string if (!is.null(extra_string)) { if (!is.character(extra_string)) { stop("Parameter 'extra_string' must be a character string.") } } - dataset_pos <- which(dimname == "dataset" | dimname == "dat") - dims <- dim(data) - if (length(dataset_pos) == 0) { - warning("Element 'data' in parameter 'data' hasn't 'dataset' dimension. ", - "All data is stored in the same 'dataset' folder.") - data$data <- InsertDim(data, posdim = 1, lendim = 1) - names(dim(data))[1] <- "dataset" - dimname <- c("dataset", dimname) - dataset_pos = 1 - } else if (length(dataset_pos) > 1) { - stop("Element 'data' in parameter 'data' has more than one 'dataset'", - " dimension.") - } - n_datasets <- dim(data)[dataset_pos] # number of folder by dataset - # dataset names: - datasets <- Dataset - if (n_datasets > length(datasets)) { - warning("Dimension 'dataset' in element 'data' from parameter 'data' ", - "is greater than those listed in element 'Datasets' and the ", - "first element is reused.") - datasets <- c(datasets, rep(datasets[1], n_datasets - length(datasets))) - } else if (n_datasets < length(datasets)) { - warning("Dimension 'dataset' in element 'data' from parameter 'data', ", - "is smaller than those listed in element 'Datasets' and only the", - " first element will be used.") - datasets <- datasets[1 : n_datasets] - } - # var names: - if ('var' %in% dimname) { - var_pos <- which(dimname == 'var') - if (dims[var_pos] == 1) { - data <- adrop(data, drop = var_pos) - dimname <- names(dim(data)) + + ## Dimensions checks + # Spatial coordinates + if (!any(dimnames %in% .KnownLonNames()) | + !any(dimnames %in% .KnownLatNames())) { + warning("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + lon_dim <- NULL + lat_dim <- NULL + } else { + lon_dim <- dimnames[which(dimnames %in% .KnownLonNames())] + lat_dim <- dimnames[which(dimnames %in% .KnownLatNames())] + if (length(lon_dim) > 1) { + warning("Found more than one longitudinal dimension. Only the first one ", + "will be used.") + lon_dim <- lon_dim[1] + } + if (length(lat_dim) > 1) { + warning("Found more than one latitudinal dimension. Only the first one ", + "will be used.") + lat_dim <- lat_dim[1] + } + } + # ftime_dim + if (!is.null(ftime_dim)) { + if (!is.character(ftime_dim)) { + stop("Parameter 'ftime_dim' must be a character string.") + } + if (!all(ftime_dim %in% dimnames)) { + stop("Parameter 'ftime_dim' is not found in 'data' dimension.") + } + if (length(ftime_dim) > 1) { + warning("Parameter 'ftime_dim' has length greater than 1 and ", + "only the first element will be used.") + ftime_dim <- ftime_dim[1] + } + } + # sdate_dim + if (!is.null(sdate_dim)) { + if (!is.character(sdate_dim)) { + stop("Parameter 'sdate_dim' must be a character string.") + } + if (length(sdate_dim) > 1) { + warning("Parameter 'sdate_dim' has length greater than 1 and ", + "only the first element will be used.") + sdate_dim <- sdate_dim[1] + } + if (!all(sdate_dim %in% dimnames)) { + stop("Parameter 'sdate_dim' is not found in 'data' dimension.") + } + } + # memb_dim + if (!is.null(memb_dim)) { + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!all(memb_dim %in% dimnames)) { + stop("Parameter 'memb_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no member dimension.") + } + } + # dat_dim + if (!is.null(dat_dim)) { + if (!is.character(dat_dim)) { + stop("Parameter 'dat_dim' must be a character string.") + } + if (!all(dat_dim %in% dimnames)) { + stop("Parameter 'dat_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no Datasets dimension.") + } + if (length(dat_dim) > 1) { + warning("Parameter 'dat_dim' has length greater than 1 and ", + "only the first element will be used.") + dat_dim <- dat_dim[1] + } + n_datasets <- dim(data)[dat_dim] + } else { + n_datasets <- 1 + } + # var_dim + if (!is.null(var_dim)) { + if (!is.character(var_dim)) { + stop("Parameter 'var_dim' must be a character string.") + } + if (!all(var_dim %in% dimnames)) { + stop("Parameter 'var_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no variable dimension.") + } + if (length(var_dim) > 1) { + warning("Parameter 'var_dim' has length greater than 1 and ", + "only the first element will be used.") + var_dim <- var_dim[1] + } + n_vars <- dim(data)[var_dim] + } else { + n_vars <- 1 + } + # minimum dimensions + if (all(dimnames %in% c(var_dim, dat_dim))) { + if (!single_file) { + warning("Parameter data has only ", + paste(c(var_dim, dat_dim), collapse = ' and '), " dimensions ", + "and it cannot be splitted in multiple files. All data will ", + "be saved in a single file.") + single_file <- TRUE + } + } + # Dates dimension check + if (!is.null(Dates)) { + if (all(names(dim(Dates)) == c(ftime_dim, sdate_dim)) | + all(names(dim(Dates)) == c(sdate_dim, ftime_dim))) { + if (is.null(startdates)) { + startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') + } else if ((!inherits(startdates, "POSIXct") & !inherits(startdates, "Date")) && + (!is.character(startdates) | (all(nchar(startdates) != 10) & + all(nchar(startdates) != 8) & all(nchar(startdates) != 6)))) { + warning("Parameter 'startdates' should be a character string containing ", + "the start dates in the format 'yyyy-mm-dd', 'yyyymmdd', 'yyyymm', ", + "'POSIXct' or 'Dates' class.") + startdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') } + } else { + stop("Parameter 'Dates' must have start date dimension and ", + "forecast time dimension.") + } + } + # startdates + if (is.null(startdates)) { + if (is.null(sdate_dim)) { + startdates <- 'XXX' + } else { + startdates <- rep('XXX', dim(data)[sdate_dim]) + } + } else { + if (is.null(sdate_dim)) { + if (length(startdates) != 1) { + warning("Parameter 'startdates' has length more than 1. Only first ", + "value will be used.") + startdates <- startdates[[1]] + } + } + } + # Datasets + if (is.null(Datasets)) { + if (!single_file) { + warning("Parameter 'Datasets' is NULL. Files will be saved with a ", + "directory name of 'XXX'.") + } + Datasets <- rep('XXX', n_datasets ) } - if (length(var_name) != 1) { - stop("One variable name must be included in element 'Variable$varName' ", - "of parameter 'data'.") + if (inherits(Datasets, 'list')) { + Datasets <- names(Datasets) } - if (!is.character(var_name)) { - stop("Element 'Variable$varName' of parameter 'data' ", - "must be a character string.") + if (n_datasets > length(Datasets)) { + warning("Dimension 'Datasets' in 'data' is greater than those listed in ", + "element 'Datasets' and the first element will be reused.") + Datasets <- c(Datasets, rep(Datasets[1], n_datasets - length(Datasets))) + } else if (n_datasets < length(Datasets)) { + warning("Dimension 'Datasets' in 'data' is smaller than those listed in ", + "element 'Datasets' and only the firsts elements will be used.") + Datasets <- Datasets[1:n_datasets] } - known_dim_names <- c("var", "lat", "latitude", "lon", "longitude", "time", - "ftime", "sdate", "dataset", "dat", "nlevel", "levels") - dims_var <- NULL - list_pos <- 1 + ## Unknown dimensions check + alldims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, memb_dim, ftime_dim) + if (!all(dimnames %in% alldims)) { + unknown_dims <- dimnames[which(!dimnames %in% alldims)] + warning("Detected unknown dimension: ", paste(unknown_dims, collapse = ', ')) + memb_dim <- c(memb_dim, unknown_dims) + alldims <- c(dat_dim, var_dim, sdate_dim, lon_dim, lat_dim, memb_dim, ftime_dim) + } + # Reorder + if (any(dimnames != alldims)) { + data <- Reorder(data, alldims) + dimnames <- names(dim(data)) + if (!is.null(attr(data, 'dimensions'))) { + attr(data, 'dimensions') <- dimnames + } + } - if (any(dimname == 'longitude') | any(dimname == 'lon')) { - dim_lon <- ncdim_def(name = 'lon', units = 'degrees', - vals = as.vector(lon), longname = 'longitude') - dims_var[[list_pos]] <- dim_lon - list_pos <- list_pos + 1 - } - if (any(dimname == 'latitude') | any(dimname == 'lat')) { - dim_lat <- ncdim_def(name = 'lat', units = 'degrees_north', - vals = as.vector(lat), longname = 'latitude') - dims_var[[list_pos]] <- dim_lat - list_pos <- list_pos + 1 - } - if (any(!(dimname %in% known_dim_names))) { - dims_member <- dimname[!(dimname %in% known_dim_names)] - if (length(dims_member) > 1) { - stop("Ask for saving realizations or further dimensions to the mantainer.") + ## NetCDF dimensions definition + defined_dims <- NULL + extra_info_dim <- NULL + if (is.null(Dates)) { + filedims <- dimnames[which(!dimnames %in% c(dat_dim, var_dim))] + } else { + filedims <- dimnames[which(!dimnames %in% c(dat_dim, var_dim, sdate_dim, ftime_dim))] + } + for (i_coord in filedims) { + dim_info <- list() + # vals + if (i_coord %in% names(coords)) { + if (is.numeric(coords[[i_coord]])) { + dim_info[['vals']] <- as.vector(coords[[i_coord]]) + } else { + dim_info[['vals']] <- 1:dim(data)[i_coord] + } } else { - dim_memb <- ncdim_def(name = 'ensemble', units = "adim", - vals = 1 : dim(data)[which(dimname == 'member')], - longname = 'ensemble', create_dimvar = TRUE) - dims_var[[list_pos]] <- dim_memb - list_pos <- list_pos + 1 + dim_info[['vals']] <- 1:dim(data)[i_coord] } + # name + dim_info[['name']] <- i_coord + # len + dim_info[['len']] <- as.numeric(dim(data)[i_coord]) + # unlim + dim_info[['unlim']] <- FALSE + # create_dimvar + dim_info[['create_dimvar']] <- TRUE + ## metadata + if (i_coord %in% names(metadata)) { + if ('variables' %in% names(attributes(metadata[[i_coord]]))) { + # from Start: 'lon' or 'lat' + attrs <- attributes(metadata[[i_coord]])[['variables']][[i_coord]] + i_coord_info <- attrs[!sapply(attrs, inherits, 'list')] + } else if (inherits(metadata[[i_coord]], 'list')) { + # from Start and Load: main var + i_coord_info <- metadata[[i_coord]] + } else if (!is.null(attributes(metadata[[i_coord]]))) { + # from Load + i_coord_info <- attributes(metadata[[i_coord]]) + } else { + stop("Metadata is not correct.") + } + # len + if ('size' %in% names(i_coord_info)) { + if (i_coord_info[['size']] != dim(data)[i_coord]) { + dim_info[['original_len']] <- i_coord_info[['size']] + i_coord_info[['size']] <- NULL + } + } + # units + if (!('units' %in% names(i_coord_info))) { + dim_info[['units']] <- '' + } else { + dim_info[['units']] <- i_coord_info[['units']] + i_coord_info[['units']] <- NULL + } + # calendar + if (!('calendar' %in% names(i_coord_info))) { + dim_info[['calendar']] <- NA + } else { + dim_info[['calendar']] <- i_coord_info[['calendar']] + i_coord_info[['calendar']] <- NULL + } + # longname + if ('long_name' %in% names(i_coord_info)) { + dim_info[['longname']] <- i_coord_info[['long_name']] + i_coord_info[['long_name']] <- NULL + } else if ('longname' %in% names(i_coord_info)) { + dim_info[['longname']] <- i_coord_info[['longname']] + i_coord_info[['longname']] <- NULL + } else { + if (i_coord %in% .KnownLonNames()) { + dim_info[['longname']] <- 'longitude' + } else if (i_coord %in% .KnownLatNames()) { + dim_info[['longname']] <- 'latitude' + } + } + # extra information + if (!is.null(names(i_coord_info))) { + extra_info_dim[[i_coord]] <- i_coord_info + } + } else { + # units + dim_info[['units']] <- "adim" + # longname + dim_info[['longname']] <- i_coord + # calendar + dim_info[['calendar']] <- NA + } + new_dim <- list(ncdim_def(name = dim_info[['name']], units = dim_info[['units']], + vals = dim_info[['vals']], unlim = dim_info[['unlim']], + create_dimvar = dim_info[['create_dimvar']], + calendar = dim_info[['calendar']], + longname = dim_info[['longname']])) + names(new_dim) <- i_coord + defined_dims <- c(defined_dims, new_dim) } + defined_vars <- list() + if (!single_file) { + for (i in 1:n_datasets) { + path <- file.path(destination, Datasets[i], varname) + for (j in 1:n_vars) { + dir.create(path[j], recursive = TRUE) + startdates <- gsub("-", "", startdates) + dim(startdates) <- c(length(startdates)) + names(dim(startdates)) <- sdate_dim + if (is.null(dat_dim) & is.null(var_dim)) { + data_subset <- data + } else if (is.null(dat_dim)) { + data_subset <- Subset(data, c(var_dim), list(j), drop = 'selected') + } else if (is.null(var_dim)) { + data_subset <- Subset(data, along = c(dat_dim), list(i), drop = 'selected') + } else { + data_subset <- Subset(data, c(dat_dim, var_dim), list(i, j), drop = 'selected') + } + if (is.null(Dates)) { + input_data <- list(data_subset, startdates) + target_dims <- list(c(lon_dim, lat_dim, memb_dim, ftime_dim), NULL) + } else { + input_data <- list(data_subset, startdates, Dates) + target_dims = list(c(lon_dim, lat_dim, memb_dim, ftime_dim), NULL, ftime_dim) + } + Apply(data = input_data, + target_dims = target_dims, + fun = .saveExp, + destination = path[j], + defined_dims = defined_dims, + ftime_dim = ftime_dim, + varname = varname[j], + metadata_var = metadata[[varname[j]]], + extra_info_dim = extra_info_dim, + extra_string = extra_string) + } + } + } else { + # Datasets definition + # From here + if (!is.null(dat_dim)) { + new_dim <- list(ncdim_def(name = dat_dim, units = "adim", + vals = 1 : dim(data)[dat_dim], + longname = 'Datasets', create_dimvar = TRUE)) + names(new_dim) <- dat_dim + defined_dims <- c(new_dim, defined_dims) + extra_info_dim[[dat_dim]] <- list(Datasets = paste(Datasets, collapse = ', ')) + } + if (!is.null(Dates)) { + # sdate definition + sdates <- Subset(Dates, along = ftime_dim, 1, drop = 'selected') + differ <- as.numeric((sdates - sdates[1])/3600) + new_dim <- list(ncdim_def(name = sdate_dim, units = paste('hours since', sdates[1]), + vals = differ, + longname = sdate_dim, create_dimvar = TRUE)) + names(new_dim) <- sdate_dim + defined_dims <- c(defined_dims, new_dim) + extra_info_dim[[sdate_dim]] <- list(sdates = paste(sdates, collapse = ', ')) + # ftime definition + ftime_dates <- Subset(Dates, along = sdate_dim, 1, drop = 'selected') + differ <- as.numeric((ftime_dates - ftime_dates[1])/3600) + # DOUBT HERE: which values we take? # FIX Dates[1] for single_file = TRUE + dim_time <- list(ncdim_def(name = ftime_dim, units = paste('hours since', paste(sdates, collapse = ', ')), + vals = differ, calendar = 'proleptic_gregorian', + longname = ftime_dim, unlim = TRUE)) + names(dim_time) <- ftime_dim + defined_dims <- c(defined_dims, dim_time) + } + + # var definition + defined_vars <- list() + extra_info_var <- NULL + for (j in 1:n_vars) { + var_info <- list() + i_var_info <- metadata[[varname[j]]][!sapply(metadata[[varname[j]]], inherits, 'list')] + ## Define metadata + # name + var_info[['name']] <- varname[j] + # units + if ('units' %in% names(i_var_info)) { + var_info[['units']] <- i_var_info[['units']] + i_var_info[['units']] <- NULL + } else { + var_info[['units']] <- '' + } + # dim + var_info[['dim']] <- defined_dims + # missval + if ('missval' %in% names(i_var_info)) { + var_info[['missval']] <- i_var_info[['missval']] + i_var_info[['missval']] <- NULL + } else { + var_info[['missval']] <- NULL + } + # longname + if (any(c('longname', 'long_name') %in% names(i_var_info))) { + longname <- names(i_var_info)[which(names(i_var_info) %in% c('longname', 'long_name'))] + var_info[['longname']] <- i_var_info[[longname]] + i_var_info[[longname]] <- NULL + } else { + var_info[['longname']] <- varname[j] + } + # prec + if ('prec' %in% names(i_var_info)) { + var_info[['prec']] <- i_var_info[['prec']] + i_var_info[['prec']] <- NULL + } else { + prec <- typeof(data) + if (prec == 'character') { + var_info[['prec']] <- 'char' + } + if (any(prec %in% c('short', 'float', 'double', 'integer', 'char', 'byte'))) { + var_info[['prec']] <- prec + } else { + var_info[['prec']] <- 'double' + } + } + # extra information + if (!is.null(names(i_var_info))) { + extra_info_var[[varname[j]]] <- i_var_info + } + new_var <- list(ncvar_def(name = var_info[['name']], + units = var_info[['units']], + dim = var_info[['dim']], + missval = var_info[['missval']], + longname = var_info[['longname']], + prec = var_info[['prec']])) + + names(new_var) <- varname[j] + defined_vars <- c(defined_vars, new_var) + } + if (is.null(extra_string)) { + file_name <- paste0(paste(c(varname), collapse = '_'), ".nc") + } else { + file_name <- paste0(paste(c(varname), collapse = '_'), "_", extra_string, ".nc") + } + full_filename <- file.path(destination, file_name) + file_nc <- nc_create(full_filename, defined_vars) + if (is.null(var_dim)) { + ncvar_put(file_nc, varname, vals = data) + } else { + for (j in 1:n_vars) { + ncvar_put(file_nc, defined_vars[[j]]$name, + vals = Subset(data, var_dim, j, drop = 'selected')) + } + } + # Additional dimension attributes + for (dim in names(defined_dims)) { + if (dim %in% names(extra_info_dim)) { + for (info_dim in names(extra_info_dim[[dim]])) { + ncatt_put(file_nc, dim, info_dim, as.character(extra_info_dim[[dim]][[info_dim]])) + } + } + } + # Additional dimension attributes + for (var in names(defined_vars)) { + if (var %in% names(extra_info_var)) { + for (info_var in names(extra_info_var[[var]])) { + ncatt_put(file_nc, var, info_var, as.character(extra_info_var[[var]][[info_var]])) + } + } + } + nc_close(file_nc) + } +} - if (any(dimname == 'level')) { - stop("Ask for saving 3Dim fields to the mantainer.") +.saveExp <- function(data, startdates = NULL, dates = NULL, destination = "./", + defined_dims, ftime_dim = 'time', varname = 'var', + metadata_var = NULL, extra_info_dim = NULL, + extra_string = NULL) { + # ftime_dim + if (!is.null(dates)) { + differ <- as.numeric((dates - dates[1])/3600) + dim_time <- list(ncdim_def(name = ftime_dim, units = paste('hours since', dates[1]), + vals = differ, calendar = 'proleptic_gregorian', + longname = ftime_dim, unlim = TRUE)) + names(dim_time) <- ftime_dim + defined_dims <- c(defined_dims, dim_time) } - for (i in 1 : n_datasets) { - path <- file.path(destination, datasets[i], var_name) - dir.create(path, recursive = TRUE) - startdate <- gsub("-", "", startdates) + ## Define var metadata + var_info <- NULL + extra_info_var <- NULL + i_var_info <- metadata_var[!sapply(metadata_var, inherits, 'list')] - dim(startdate) <- c(sdate = length(startdate)) - Apply(list(data, startdate, Dates), - target_dims = list(c('member', 'time', 'latitude', 'longitude'), - NULL, 'time'), - fun = .saveExp, var_name = var_name, units = units, - dims_var = dims_var, cdo_grid_name = cdo_grid_name, projection = projection, - destination = path, extra_string = extra_string) + # name + var_info[['name']] <- varname + # units + if ('units' %in% names(i_var_info)) { + var_info[['units']] <- i_var_info[['units']] + i_var_info[['units']] <- NULL + } else { + var_info[['units']] <- '' } -} + # dim + var_info[['dim']] <- defined_dims + # missval + if ('missval' %in% names(i_var_info)) { + var_info[['missval']] <- i_var_info[['missval']] + i_var_info[['missval']] <- NULL + } else { + var_info[['missval']] <- NULL + } + # longname + if (any(c('longname', 'long_name') %in% names(i_var_info))) { + longname <- names(i_var_info)[which(names(i_var_info) %in% c('longname', 'long_name'))] + var_info[['longname']] <- i_var_info[[longname]] + i_var_info[[longname]] <- NULL + } else { + var_info[['longname']] <- varname + } + # prec + if ('prec' %in% names(i_var_info)) { + var_info[['prec']] <- i_var_info[['prec']] + i_var_info[['prec']] <- NULL + } else { + prec <- typeof(data) + if (prec == 'character') { + var_info[['prec']] <- 'char' + } + if (any(prec %in% c('short', 'float', 'double', 'integer', 'char', 'byte'))) { + var_info[['prec']] <- prec + } else { + var_info[['prec']] <- 'double' + } + } + # extra information + if (!is.null(names(i_var_info))) { + extra_info_var <- i_var_info + } + + datanc <- ncvar_def(name = var_info[['name']], + units = var_info[['units']], + dim = var_info[['dim']], + missval = var_info[['missval']], + longname = var_info[['longname']], + prec = var_info[['prec']]) -# data is an array with dimensions: member, time, lat, lon: -# Dates is a vector of the dates for the time dimension -# dims_var is a list with the ncdim_def of common variables in dataset: member, lat and lon: -# data <- 1:(3 * 4 * 5 * 6) -# dim(data) <- c(longitude = 3, latitude = 4, time = 5, member = 6) -# var_name <- 'tas' -# units <- 'K' -# lon <- 1:3 -# lat <- 1:4 -# sdate = '19001101' -# destination = '/esarchive/scratch/nperez/git/Flor/cstools/' -# dims_var = list(ncdim_def(name = 'lon', units = 'degrees', -# vals = as.vector(lon), longname = 'longitude'), -# ncdim_def(name = 'lat', units = 'degrees_north', -# vals = as.vector(lat), longname = 'latitude'), -# ncdim_def(name = 'ensemble', units = "adim", -# vals = 1 : 6, -# longname = 'ensemble', create_dimvar = TRUE)) -#Dates <- as.Date(c("1900-11-01", "1900-12-01", "1901-01-01", "1901-02-01", "1901-03-01")) -#.saveExp(data, sdate, Dates, var_name, units, dims_var, cdo_grid_name = 'r360x181', projection = 'none', destination) -.saveExp <- function(data, sdate, Dates, var_name, units, dims_var, - cdo_grid_name, projection, destination, extra_string) { - dim_names <- names(dim(data)) - if (any(dim_names != c('longitude', 'latitude', 'member', 'time'))) { - data <- Reorder(data, c('longitude', 'latitude', 'member', 'time')) - } - differ <- as.numeric((Dates - Dates[1])/3600) - dim_time <- ncdim_def(name = 'time', units = paste('hours since', Dates[1]), - vals = differ, calendar = 'proleptic_gregorian', - longname = 'time', unlim = TRUE) - list_pos = length(dims_var) + 1 - dims_var[[list_pos]] <- dim_time - datanc <- ncvar_def(name = var_name, - units = units, - dim = dims_var, missval = -99999) if (is.null(extra_string)) { - file_name <- paste0(var_name, "_", sdate, ".nc") + file_name <- paste0(varname, "_", startdates, ".nc") } else { - file_name <- paste0(var_name, "_", extra_string, "_", sdate, ".nc") + file_name <- paste0(varname, "_", extra_string, "_", startdates, ".nc") } full_filename <- file.path(destination, file_name) file_nc <- nc_create(full_filename, datanc) ncvar_put(file_nc, datanc, data) - ncatt_put(file_nc, datanc, 'coordinates', cdo_grid_name) - ncatt_put(file_nc, datanc, 'projection', projection) + + # Additional attributes + for (dim in names(defined_dims)) { + if (dim %in% names(extra_info_dim)) { + for (info_dim in names(extra_info_dim[[dim]])) { + ncatt_put(file_nc, dim, info_dim, as.character(extra_info_dim[[dim]][[info_dim]])) + } + } + } + # Additional dimension attributes + if (!is.null(extra_info_var)) { + for (info_var in names(extra_info_var)) { + ncatt_put(file_nc, varname, info_var, as.character(extra_info_var[[info_var]])) + } + } + nc_close(file_nc) } diff --git a/R/CST_SplitDim.R b/R/CST_SplitDim.R index 03d580cb76888328a2200ed221321f71f5a8c3c6..25d610da8ffb14fae278e7bc2ba559c12464b299 100644 --- a/R/CST_SplitDim.R +++ b/R/CST_SplitDim.R @@ -5,7 +5,8 @@ #'@description This function split a dimension in two. The user can select the #'dimension to split and provide indices indicating how to split that dimension #'or dates and the frequency expected (monthly or by day, month and year). The -#'user can also provide a numeric frequency indicating the length of each division. +#'user can also provide a numeric frequency indicating the length of each +#'division. #' #'@param data A 's2dv_cube' object #'@param split_dim A character string indicating the name of the dimension to @@ -16,7 +17,8 @@ #' 'year' or 'monthly' (by default). 'month' identifies months between 1 and 12 #' independently of the year they belong to, while 'monthly' differenciates #' months from different years. -#'@param new_dim_name A character string indicating the name of the new dimension. +#'@param new_dim_name A character string indicating the name of the new +#' dimension. #'@param insert_ftime An integer indicating the number of time steps to add at #' the begining of the time series. #' @@ -31,10 +33,7 @@ #''time' will be length 31. For November, the position 1 and 31 will be NAs, #'while from positon 2 to 30 will be filled with the data provided. This allows #'to select correctly days trhough time dimension. -#'@import abind -#'@importFrom ClimProjDiags Subset #'@examples -#' #'data <- 1 : 20 #'dim(data) <- c(time = 10, lat = 2) #'data <-list(data = data) @@ -47,16 +46,16 @@ #'data <- list(data = data$data, Dates = time) #'class(data) <- 's2dv_cube' #'new_data <- CST_SplitDim(data, indices = time) -#'dim(new_data$data) #'new_data <- CST_SplitDim(data, indices = time, freq = 'day') -#'dim(new_data$data) #'new_data <- CST_SplitDim(data, indices = time, freq = 'month') -#'dim(new_data$data) #'new_data <- CST_SplitDim(data, indices = time, freq = 'year') -#'dim(new_data$data) +#'@import abind +#'@importFrom ClimProjDiags Subset #'@export CST_SplitDim <- function(data, split_dim = 'time', indices = NULL, - freq = 'monthly', new_dim_name = NULL, insert_ftime = NULL) { + freq = 'monthly', new_dim_name = NULL, + insert_ftime = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") @@ -78,17 +77,17 @@ CST_SplitDim <- function(data, split_dim = 'time', indices = NULL, data$data <- abind(empty_array, data$data, along = ftimedim) names(dim(data$data)) <- names(dims) # adding dates to Dates for the new NAs introduced - if ((data$Dates[[1]][2] - data$Dates[[1]][1]) == 1) { + if ((data$attrs$Dates[2] - data$attrs$Dates[1]) == 1) { timefreq <- 'days' } else { timefreq <- 'months' warning("Time frequency of forecast time is considered monthly.") } - start <- data$Dates[[1]] + start <- data$attrs$Dates dim(start) <- c(ftime = length(start)/dims['sdate'], sdate = dims['sdate']) # new <- array(NA, prod(dim(data$data)[c('ftime', 'sdate')])) # Pending fix transform to UTC when concatenaiting - data$Dates$start <- do.call(c, lapply(1:dim(start)[2], function(x) { + data$attrs$Dates <- do.call(c, lapply(1:dim(start)[2], function(x) { seq(start[1,x] - as.difftime(insert_ftime, units = timefreq), start[dim(start)[1],x], by = timefreq, tz = "UTC")})) @@ -96,11 +95,7 @@ CST_SplitDim <- function(data, split_dim = 'time', indices = NULL, } if (is.null(indices)) { if (any(split_dim %in% c('ftime', 'time', 'sdate'))) { - if (is.list(data$Dates)) { - indices <- data$Dates[[1]] - } else { - indices <- data$Dates - } + indices <- data$attrs$Dates if (any(names(dim(data$data)) %in% 'sdate')) { if (!any(names(dim(data$data)) %in% split_dim)) { stop("Parameter 'split_dims' must be one of the dimension ", @@ -134,8 +129,6 @@ CST_SplitDim <- function(data, split_dim = 'time', indices = NULL, #' the length in which to subset the dimension. #'@param new_dim_name A character string indicating the name of the new #' dimension. -#'@import abind -#'@importFrom ClimProjDiags Subset #'@examples #'data <- 1 : 20 #'dim(data) <- c(time = 10, lat = 2) @@ -148,6 +141,8 @@ CST_SplitDim <- function(data, split_dim = 'time', indices = NULL, #'new_data <- SplitDim(data, indices = time, freq = 'day') #'new_data <- SplitDim(data, indices = time, freq = 'month') #'new_data <- SplitDim(data, indices = time, freq = 'year') +#'@import abind +#'@importFrom ClimProjDiags Subset #'@export SplitDim <- function(data, split_dim = 'time', indices, freq = 'monthly', new_dim_name = NULL) { diff --git a/R/CST_WeatherRegimes.R b/R/CST_WeatherRegimes.R index abc1fabab52073e247d2356be4abed11eee6238e..7268e8ec51ef879962954f3c2f8a848875bd9a0f 100644 --- a/R/CST_WeatherRegimes.R +++ b/R/CST_WeatherRegimes.R @@ -17,7 +17,7 @@ #'energy sector: methods and tools for the development of a climate service. #'Thesis. Available online: \url{https://eprints.ucm.es/56841/}. #' -#'@param data An 's2dv_cube' object +#'@param data An 's2dv_cube' object. #'@param ncenters Number of clusters to be calculated with the clustering #' function. #'@param EOFs Whether to compute the EOFs (default = 'TRUE') or not (FALSE) to @@ -49,13 +49,19 @@ #'method=’kmeans’ has been selected.)), \code{frequency} (Percentage of days in #'a month/season belonging to each cluster (only if method=’kmeans’ has been #'selected).), +#'@examples +#'data <- array(abs(rnorm(1280, 283.7, 6)), dim = c(dataset = 2, member = 2, +#' sdate = 3, ftime = 3, +#' lat = 4, lon = 4)) +#'coords <- list(lon = seq(0, 3), lat = seq(47, 44)) +#'obs <- list(data = data, coords = coords) +#'class(obs) <- 's2dv_cube' +#' +#'res1 <- CST_WeatherRegimes(data = obs, EOFs = FALSE, ncenters = 4) +#'res2 <- CST_WeatherRegimes(data = obs, EOFs = TRUE, ncenters = 3) +#' #'@importFrom s2dv EOF #'@import multiApply -#'@examples -#'\dontrun{ -#'res1 <- CST_WeatherRegimes(data = lonlat_temp$obs, EOFs = FALSE, ncenters = 4) -#'res2 <- CST_WeatherRegimes(data = lonlat_temp$obs, EOFs = TRUE, ncenters = 3) -#'} #'@export CST_WeatherRegimes <- function(data, ncenters = NULL, EOFs = TRUE, neofs = 30, @@ -63,20 +69,33 @@ CST_WeatherRegimes <- function(data, ncenters = NULL, method = "kmeans", iter.max = 100, nstart = 30, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") } - if ('lon' %in% names(data)){ - lon <- data$lon - }else { - lon <- NULL + # Check 'exp' object structure + if (!all(c('data', 'coords') %in% names(data))) { + stop("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + } + # Check coordinates + if (!any(names(data$coords) %in% .KnownLonNames()) | + !any(names(data$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted ", + "the package.") + } else { + lon_name <- names(data$coords)[[which(names(data$coords) %in% .KnownLonNames())]] + lat_name <- names(data$coords)[[which(names(data$coords) %in% .KnownLatNames())]] + lon <- as.vector(data$coords[[lon_name]]) + lat <- as.vector(data$coords[[lat_name]]) } - result <- WeatherRegime(data$data,ncenters = ncenters, + + result <- WeatherRegime(data$data, ncenters = ncenters, EOFs = EOFs, neofs = neofs, varThreshold = varThreshold, lon = lon, - lat = data$lat, method = method, - iter.max=iter.max, nstart = nstart, + lat = lat, method = method, + iter.max = iter.max, nstart = nstart, ncores = ncores) data$data <- result$composite data$statistics <- result[-1] @@ -138,31 +157,35 @@ CST_WeatherRegimes <- function(data, ncenters = NULL, #'replaced for a new one (only if method=’kmeans’ has been selected.)), #'\code{frequency} (Percentage of days in a month/season belonging to each #'cluster (only if method=’kmeans’ has been selected).), +#'@examples +#'data <- array(abs(rnorm(1280, 283.7, 6)), dim = c(dataset = 2, member = 2, +#' sdate = 3, ftime = 3, +#' lat = 4, lon = 4)) +#'lat <- seq(47, 44) +#'res <- WeatherRegime(data = data, lat = lat, +#' EOFs = FALSE, ncenters = 4) #'@importFrom s2dv EOF #'@import multiApply -#'@examples -#'\dontrun{ -#'res <- WeatherRegime(data = lonlat_temp$obs$data, lat = lonlat_temp$obs$lat, -#' EOFs = FALSE, ncenters = 4) -#'} #'@export WeatherRegime <- function(data, ncenters = NULL, - EOFs = TRUE,neofs = 30, + EOFs = TRUE, neofs = 30, varThreshold = NULL, lon = NULL, lat = NULL, method = "kmeans", - iter.max=100, nstart = 30, + iter.max = 100, nstart = 30, ncores = NULL) { - + ## Check inputs + # data if (is.null(names(dim(data)))) { stop("Parameter 'data' must be an array with named dimensions.") } - + if (EOFs == TRUE && is.null(lon)) { + stop("Parameter 'lon' must be specified.") + } if (is.null(lat)) { stop("Parameter 'lat' must be specified.") } - dimData <- names(dim(data)) - + # temporal dimensions if ('sdate' %in% dimData && 'ftime' %in% dimData) { nsdates <- dim(data)['sdate'] nftimes <- dim(data)['ftime'] @@ -176,17 +199,35 @@ WeatherRegime <- function(data, ncenters = NULL, stop("Parameter 'data' must have temporal dimensions.") } } - + # spatial dimensions + if (!any(names(dim(data)) %in% .KnownLonNames()) | + !any(names(dim(data)) %in% .KnownLatNames())) { + stop("Spatial coordinate names do not match any of the names accepted ", + "by the package.") + } + + lon_name <- names(dim(data))[[which(names(dim(data)) %in% .KnownLonNames())]] + lat_name <- names(dim(data))[[which(names(dim(data)) %in% .KnownLatNames())]] + + if (!is.null(lat) && dim(data)[lat_name] != length(lat)) { + stop("The length of the paramter 'lat' does not match with the ['lat'] dimension of + the parameter 'data'.") + } + # ncenters + if (is.null(ncenters)) { + stop("Parameter 'ncenters' must be specified.") + } output <- Apply(data = list(data), - target_dims = c('time','lat','lon'), + target_dims = c('time', lat_name, lon_name), fun = .WeatherRegime, EOFs = EOFs, neofs = neofs, varThreshold = varThreshold, lon = lon, lat = lat, ncenters = ncenters, method = method, - ncores = ncores) + ncores = ncores, + lon_name = lon_name, lat_name = lat_name) if (method == 'kmeans' && 'sdate' %in% dimData && 'ftime' %in% dimData) { @@ -214,31 +255,15 @@ WeatherRegime <- function(data, ncenters = NULL, .WeatherRegime <- function(data, ncenters = NULL, EOFs = TRUE, neofs = 30, varThreshold = NULL, lon = NULL, lat = NULL, method = "kmeans", - iter.max=100, nstart = 30) { + iter.max = 100, nstart = 30, lon_name = 'lon', + lat_name = 'lat') { - if (is.null(names(dim(data)))) { - stop("Parameter 'data' must be an array with 'time', 'lat' and 'lon' dimensions.") - } - - if (!is.null(lat) && dim(data)['lat'] != length(lat)) { - stop("The length of the paramter 'lat' does not match with the ['lat'] dimension of - the parameter 'data'.") - } - if (is.null(ncenters)) { - stop("Parameter 'ncenters' must be specified.") - } - if (EOFs == TRUE && is.null(lon)) { - stop("Parameter 'lon' must be specified.") - } - if (is.null(lat)) { - stop("Parameter 'lat' must be specified.") - } - - nlon <- dim(data)['lat'] - nlat <- dim(data)['lon'] + + nlon <- dim(data)[lat_name] + nlat <- dim(data)[lon_name] if (any(is.na(data))){ - nas_test <- MergeDims(data, merge_dims = c('lat','lon'), + nas_test <- MergeDims(data, merge_dims = c(lat_name,lon_name), rename_dim = 'space', na.rm = TRUE) if (dim(nas_test)['space']== c(nlat*nlon)){ stop("Parameter 'data' contains NAs in the 'time' dimensions.") @@ -268,12 +293,12 @@ WeatherRegime <- function(data, ncenters = NULL, } } else { - dataW <- aperm(Apply(data, target_dims = 'lat', + dataW <- aperm(Apply(data, target_dims = lat_name, function (x, la) { x * cos(la * pi / 180)}, la = lat)[[1]], c(2, 1, 3)) - cluster_input <- MergeDims(dataW, merge_dims = c('lat','lon'), + cluster_input <- MergeDims(dataW, merge_dims = c(lat_name, lon_name), rename_dim = 'space',na.rm = TRUE) } @@ -298,7 +323,7 @@ WeatherRegime <- function(data, ncenters = NULL, } result <- lapply(1:length(result), function (n) { - names(dim(result[[n]])) <- c("lat", "lon", "cluster") + names(dim(result[[n]])) <- c(lat_name, lon_name, "cluster") return (result[[n]]) }) diff --git a/R/PlotForecastPDF.R b/R/PlotForecastPDF.R index 248e43ef1fac8ed6fd3a5ddc1cfc656257ef745c..7143294472db2653fff3ca08d4cbc08a07b0a8a5 100644 --- a/R/PlotForecastPDF.R +++ b/R/PlotForecastPDF.R @@ -44,7 +44,9 @@ #' dimension. #' #'@return A ggplot object containing the plot. -#' +#'@examples +#'fcsts <- data.frame(fcst1 = rnorm(10), fcst2 = rnorm(10, 0.5, 1.2)) +#'PlotForecastPDF(fcsts,c(-1,1)) #'@importFrom data.table data.table #'@importFrom data.table CJ #'@importFrom data.table setkey @@ -53,9 +55,6 @@ #'@importFrom plyr . #'@importFrom plyr dlply #'@importFrom s2dv InsertDim -#'@examples -#'fcsts <- data.frame(fcst1 = rnorm(10), fcst2 = rnorm(10, 0.5, 1.2)) -#'PlotForecastPDF(fcsts,c(-1,1)) #'@export PlotForecastPDF <- function(fcst, tercile.limits, extreme.limits = NULL, obs = NULL, plotfile = NULL, title = "Set a title", var.name = "Varname (units)", diff --git a/R/PlotMostLikelyQuantileMap.R b/R/PlotMostLikelyQuantileMap.R index 3a146b92b533eb5854088bd5df6da95873b9b5b8..18e4a8bad36bf193441d55cdd15fb392ca216cfe 100644 --- a/R/PlotMostLikelyQuantileMap.R +++ b/R/PlotMostLikelyQuantileMap.R @@ -41,10 +41,6 @@ #'@param ... Additional parameters to be sent to \code{PlotCombinedMap} and #' \code{PlotEquiMap}. #'@seealso \code{PlotCombinedMap} and \code{PlotEquiMap} -#' -#'@importFrom maps map -#'@importFrom graphics box image layout mtext par plot.new -#'@importFrom grDevices adjustcolor bmp colorRampPalette dev.cur dev.new dev.off hcl jpeg pdf png postscript svg tiff #'@examples #'# Simple example #'x <- array(1:(20 * 10), dim = c(lat = 10, lon = 20)) / 200 @@ -132,7 +128,9 @@ #' mask = 1 - (w1 + w2 / max(c(w1, w2))), #' brks = 20, width = 10, height = 8) #'} -#' +#'@importFrom maps map +#'@importFrom graphics box image layout mtext par plot.new +#'@importFrom grDevices adjustcolor bmp colorRampPalette dev.cur dev.new dev.off hcl jpeg pdf png postscript svg tiff #'@export PlotMostLikelyQuantileMap <- function(probs, lon, lat, cat_dim = 'bin', bar_titles = NULL, diff --git a/R/PlotPDFsOLE.R b/R/PlotPDFsOLE.R index 58e0bf969a9c6615929259c29700585e1ff05a07..bf95abb76c745410447d0cdf59c22f34b2509231 100644 --- a/R/PlotPDFsOLE.R +++ b/R/PlotPDFsOLE.R @@ -31,8 +31,6 @@ #' #'@return PlotPDFsOLE() returns a ggplot object containing the plot. #' -#'@import ggplot2 -#' #'@examples #'# Example 1 #'pdf_1 <- c(1.1,0.6) @@ -43,6 +41,7 @@ #'dim(pdf_2) <- c(statistic = 2) #' #'PlotPDFsOLE(pdf_1, pdf_2) +#'@import ggplot2 #'@export PlotPDFsOLE <- function(pdf_1, pdf_2, nsigma = 3, legendPos = 'bottom', legendSize = 1.0, plotfile = NULL, width = 30, diff --git a/R/Predictability.R b/R/Predictability.R index ae063651256842e202eef124548fc2a61d8f6fed..2416067431b72758c520c5598ff5ca01438dcd62 100644 --- a/R/Predictability.R +++ b/R/Predictability.R @@ -58,15 +58,8 @@ #' attractor <- ProxiesAttractor(dat = m, quanti = 0.60) #' predyn <- Predictability(dim = attractor$dim, theta = attractor$theta) #'@export -Predictability<- function(dim, theta, ncores = NULL) { - # if (!inherits(dim, 's2dv_cube')) { - # stop("Parameter 'dim' must be of the class 's2dv_cube', ", - # "as output by CSTools::CST_Load.") - # } - # if (!inherits(theta, 's2dv_cube')) { - # stop("Parameter 'theta' must be of the class 's2dv_cube', ", - # "as output by CSTools::CST_Load.") - # } +Predictability <- function(dim, theta, ncores = NULL) { + if (any(names(dim(dim)) %in% 'sdate')) { if (any(names(dim(dim)) %in% 'ftime')) { dim <- MergeDims(dim, merge_dims = c('ftime', 'sdate'), diff --git a/R/as.s2dv_cube.R b/R/as.s2dv_cube.R index 5f31ad31f6242fcfaa5bbe48e22ac27700b419c1..453f51dc2a4b0ed4f34f35814b48132a4cff6aee 100644 --- a/R/as.s2dv_cube.R +++ b/R/as.s2dv_cube.R @@ -1,183 +1,348 @@ #'Conversion of 'startR_array' or 'list' objects to 's2dv_cube' #' -#'This function converts data loaded using startR package or s2dv Load function into a 's2dv_cube' object. +#'This function converts data loaded using Start function from startR package or +#'Load from s2dv into an 's2dv_cube' object. #' #'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es} #'@author Nicolau Manubens, \email{nicolau.manubens@bsc.es} #' -#'@param object an object of class 'startR_array' generated from function \code{Start} from startR package (version 0.1.3 from earth.bsc.es/gitlab/es/startR) or a list output from function \code{Load} from s2dv package. -#' -#'@return The function returns a 's2dv_cube' object to be easily used with functions \code{CST} from CSTools package. +#'@param object An object of class 'startR_array' generated from function +#' \code{Start} from startR package or a list output from function \code{Load} +#' from s2dv package. Any other object class will not be accepted. +#'@param remove_attrs_coords A logical value indicating whether to remove the +#' attributes of the coordinates (TRUE) or not (FALSE). The default value is +#' FALSE. +#'@param remove_null Optional. A logical value indicating whether to remove the +#' elements that are NULL (TRUE) or not (FALSE) of the output object. It is +#' only used when the object is an output from function \code{Load}. The +#' default value is FALSE. +#' +#'@return The function returns an 's2dv_cube' object to be easily used with +#'functions with the prefix \code{CST} from CSTools and CSIndicators packages. +#'The object is mainly a list with the following elements:\cr +#'\itemize{ +#' \item{'data', array with named dimensions.} +#' \item{'dims', named vector of the data dimensions.} +#' \item{'coords', named list with elements of the coordinates corresponding to +#' the dimensions of the data parameter. If any coordinate is not provided, it +#' is set as an index vector with the values from 1 to the length of the +#' corresponding dimension. The attribute 'indices' indicates wether the +#' coordinate is an index vector (TRUE) or not (FALSE).} +#' \item{'attrs', named list with elements: +#' \itemize{ +#' \item{'Dates', array with named temporal dimensions of class 'POSIXct' +#' from time values in the data.} +#' \item{'Variable', has the following components: +#' \itemize{ +#' \item{'varName', character vector of the short variable name. It is +#' usually specified in the parameter 'var' from the functions +#' Start and Load.} +#' \item{'metadata', named list of elements with variable metadata. +#' They can be from coordinates variables (e.g. longitude) or +#' main variables (e.g. 'var').} +#' } +#' } +#' \item{'Datasets', character strings indicating the names of the +#' datasets.} +#' \item{'source_files', a vector of character strings with complete paths +#' to all the found files involved in loading the data.} +#' \item{'when', a time stamp of the date issued by the Start() or Load() +#' call to obtain the data.} +#' \item{'load_parameters', it contains the components used in the +#' arguments to load the data from Start() or Load() functions.} +#' } +#' } +#'} #' -#'@seealso \code{\link{s2dv_cube}}, \code{\link[s2dv]{Load}}, \code{\link[startR]{Start}} and \code{\link{CST_Load}} +#'@seealso \code{\link{s2dv_cube}}, \code{\link[s2dv]{Load}}, +#'\code{\link[startR]{Start}} and \code{\link{CST_Load}} #'@examples #'\dontrun{ +#'# Example 1: convert an object from startR::Start function to 's2dv_cube' #'library(startR) #'repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' #'data <- Start(dat = repos, #' var = 'tas', #' sdate = c('20170101', '20180101'), -#' ensemble = indices(1:20), +#' ensemble = indices(1:5), #' time = 'all', -#' latitude = 'all', -#' longitude = indices(1:40), +#' latitude = indices(1:5), +#' longitude = indices(1:5), #' return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'), #' retrieve = TRUE) #'data <- as.s2dv_cube(data) -#'class(data) +#'# Example 2: convert an object from s2dv::Load function to 's2dv_cube' #'startDates <- c('20001101', '20011101', '20021101', -#' '20031101', '20041101', '20051101') +#' '20031101', '20041101', '20051101') #'data <- Load(var = 'tas', exp = 'system5c3s', -#' nmember = 15, sdates = startDates, -#' leadtimemax = 3, latmin = 27, latmax = 48, -#' lonmin = -12, lonmax = 40, output = 'lonlat') +#' nmember = 2, sdates = startDates, +#' leadtimemax = 3, latmin = 10, latmax = 30, +#' lonmin = -10, lonmax = 10, output = 'lonlat') #'data <- as.s2dv_cube(data) -#'class(data) #'} #'@export -as.s2dv_cube <- function(object) { - if (is.list(object)) { +as.s2dv_cube <- function(object, remove_attrs_coords = FALSE, + remove_null = FALSE) { + + if (is.list(object) & length(object) == 11) { if (is.null(object) || (is.null(object$mod) && is.null(object$obs))) { stop("The s2dv::Load call did not return any data.") } obs <- object obs$mod <- NULL object$obs <- NULL - names(object)[[1]] <- 'data' - names(obs)[[1]] <- 'data' - remove_matches <- function(v, patterns) { - if (length(v) > 0) { - matches <- c() - for (pattern in patterns) { - matches <- c(matches, which(grepl(pattern, v))) - } - if (length(matches) > 0) { - v <- v[-matches] - } - } - v - } - - harmonize_patterns <- function(v) { - matches <- grepl('.*\\.nc$', v) - if (sum(!matches) > 0) { - match_indices <- which(!matches) - v[match_indices] <- sapply(v[match_indices], function(x) paste0(x, '*')) - } - v <- glob2rx(v) - v <- gsub('\\$.*\\$', '*', v) - v - } - + names(object)[[1]] <- 'data' # exp + names(obs)[[1]] <- 'data' # obs + # obs if (!is.null(obs$data)) { + obs_exist <- TRUE obs$Datasets$exp <- NULL obs$Datasets <- obs$Datasets$obs - obs_path_patterns <- sapply(obs$Datasets, function(x) attr(x, 'source')) - obs_path_patterns <- harmonize_patterns(obs_path_patterns) + } else { + obs_exist <- FALSE } - + # object if (!is.null(object$data)) { + exp_exist <- TRUE object$Datasets$obs <- NULL object$Datasets <- object$Datasets$exp - exp_path_patterns <- sapply(object$Datasets, function(x) attr(x, 'source')) - exp_path_patterns <- harmonize_patterns(exp_path_patterns) + } else { + exp_exist <- FALSE } - - if (!is.null(obs$data) && !is.null(object$data)) { - obs$source_files <- remove_matches(obs$source_files, - exp_path_patterns) - obs$not_found_files <- remove_matches(obs$not_found_files, - exp_path_patterns) - - object$source_files <- remove_matches(object$source_files, - obs_path_patterns) - object$not_found_files <- remove_matches(object$not_found_files, - obs_path_patterns) - } - result <- list() - if (!is.null(object$data)) { - class(object) <- 's2dv_cube' - result$exp <- object - } - if (!is.null(obs$data)) { - class(obs) <- 's2dv_cube' - result$obs <- obs + # obs and exp + if (obs_exist & exp_exist) { + obs_exp = list(exp = object, obs = obs) + } else if (obs_exist & !exp_exist) { + obs_exp = list(obs = obs) + } else { + obs_exp = list(exp = object) } - if (is.list(result)) { - if (is.null(result$exp)) { - result <- result$obs - } else if (is.null(result$obs)) { - result <- result$exp + i <- 0 + for (obj_i in obs_exp) { + i <- i + 1 + # attrs + obj_i$attrs <- within(obj_i, rm(list = c('data'))) + obj_i <- within(obj_i, rm(list = names(obj_i$attrs))) + dates <- obj_i$attrs$Dates$start + attr(dates, 'end') <- obj_i$attrs$Dates$end + if (!is.null(dates)) { + dim(dates) <- dim(obj_i$data)[c('ftime', 'sdate')] + obj_i$attrs$Dates <- dates + } + # Variable + varname <- obj_i$attrs$Variable$varName + varmetadata <- NULL + varmetadata[[varname]] <- attributes(obj_i$attrs$Variable)[-1] + obj_i$attrs$Variable <- list(varName = varname, metadata = varmetadata) + # dims + obj_i$dims <- dim(obj_i$data) + # coords + obj_i$coords <- sapply(names(dim(obj_i$data)), function(x) NULL) + # sdate + obj_i$coords$sdate <- obj_i$attrs$load_parameters$sdates + if (!remove_attrs_coords) attr(obj_i$coords$sdate, 'indices') <- FALSE + # lon + if (!is.null(obj_i$attrs$lon)) { + if (remove_attrs_coords) { + obj_i$coords$lon <- as.vector(obj_i$attrs$lon) } else { - warning("The output is a list of two 's2dv_cube' objects", - " corresponding to 'exp' and 'obs'.") + obj_i$coords$lon <- obj_i$attrs$lon + attr(obj_i$coords$lon, 'indices') <- FALSE } + obj_i$attrs$Variable$metadata$lon <- obj_i$attrs$lon + obj_i$attrs <- within(obj_i$attrs, rm(list = 'lon')) + } + # lat + if (!is.null(obj_i$attrs$lat)) { + if (remove_attrs_coords) { + obj_i$coords$lat <- as.vector(obj_i$attrs$lat) + } else { + obj_i$coords$lat <- obj_i$attrs$lat + attr(obj_i$coords$lat, 'indices') <- FALSE + } + obj_i$attrs$Variable$metadata$lat <- obj_i$attrs$lat + obj_i$attrs <- within(obj_i$attrs, rm(list = 'lat')) + } + # member + obj_i$coords$member <- 1:obj_i$dims['member'] + if (!remove_attrs_coords) attr(obj_i$coords$member, 'indices') <- TRUE + # dataset + obj_i$coords$dataset <- 1:obj_i$dims['dataset'] + if (!remove_attrs_coords) attr(obj_i$coords$dataset, 'indices') <- TRUE + # ftime + obj_i$coords$ftime <- 1:obj_i$dims['ftime'] + if (!remove_attrs_coords) attr(obj_i$coords$ftime, 'indices') <- TRUE + # remove NULL values + if (isTRUE(remove_null)) { + obj_i$attrs$load_parameters <- .rmNullObs(obj_i$attrs$load_parameters) + } + obj_i <- obj_i[c('data','dims','coords','attrs')] + class(obj_i) <- 's2dv_cube' + if (names(obs_exp)[[i]] == 'exp') { + result$exp <- obj_i + } else { + result$obs <- obj_i + } + } + if (is.list(result)) { + if (is.null(result$exp)) { + result <- result$obs + } else if (is.null(result$obs)) { + result <- result$exp + } else { + warning("The output is a list of two 's2dv_cube' objects", + " corresponding to 'exp' and 'obs'.") + } } - + } else if (inherits(object, 'startR_array')) { + # From Start: result <- list() result$data <- as.vector(object) - dim(result$data) <- dim(object) - - dat_attr_names <- names(attributes(object)$Variables$dat1) - common_attr_names <- names(attributes(object)$Variables$common) - # $lon - known_lon_names <- utils::getFromNamespace(".KnownLonNames", "s2dv")() - if (!is.null(dat_attr_names[which(dat_attr_names %in% known_lon_names)]) & - !identical(dat_attr_names[which(dat_attr_names %in% known_lon_names)], character(0))) { - result$lon <- attributes(object)$Variables$dat1[[dat_attr_names[which(dat_attr_names %in% known_lon_names)]]] - } else if (!is.null(common_attr_names[which(common_attr_names %in% known_lon_names)]) & - !identical(common_attr_names[which(common_attr_names %in% known_lon_names)], character(0))) { - result$lon <- attributes(object)$Variables$common[[common_attr_names[which(common_attr_names %in% known_lon_names)]]] - } else { - warning("'lon' is not found in this object.") - result$lon <- NULL - } - # $lat - known_lat_names <- utils::getFromNamespace(".KnownLatNames", "s2dv")() - if (!is.null(dat_attr_names[which(dat_attr_names %in% known_lat_names)]) & - !identical(dat_attr_names[which(dat_attr_names %in% known_lat_names)], character(0))) { - result$lat <- attributes(object)$Variables$dat1[[dat_attr_names[which(dat_attr_names %in% known_lat_names)]]] - } else if (!is.null(common_attr_names[which(common_attr_names %in% known_lat_names)]) & - !identical(common_attr_names[which(common_attr_names %in% known_lat_names)], character(0))) { - result$lat <- attributes(object)$Variables$common[[common_attr_names[which(common_attr_names %in% known_lat_names)]]] - } else { - warning("'lat' is not found in this object.") - result$lat <- NULL + ## dims + dims <- dim(object) + dim(result$data) <- dims + result$dims <- dims + ## coords + result$coords <- sapply(names(dims), function(x) NULL) + # Find coordinates + FileSelector <- attributes(object)$FileSelectors + VariablesCommon <- names(attributes(object)$Variables$common) + dat <- names(FileSelector)[1] + VariablesDat <- names(attributes(object)$Variables[[dat]]) + varName <- NULL + for (i_coord in names(dims)) { + if (i_coord %in% names(FileSelector[[dat]])) { # coords in FileSelector + coord_in_fileselector <- FileSelector[[dat]][which(i_coord == names(FileSelector[[dat]]))] + if (length(coord_in_fileselector) == 1) { + if (length(coord_in_fileselector[[i_coord]][[1]]) == dims[i_coord]) { + if (i_coord %in% c('var', 'vars')) { + varName <- as.vector(coord_in_fileselector[[i_coord]][[1]]) + } + if (remove_attrs_coords) { + result$coords[[i_coord]] <- as.vector(coord_in_fileselector[[i_coord]][[1]]) + } else { + result$coords[[i_coord]] <- coord_in_fileselector[[i_coord]][[1]] + } + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- FALSE + } else { + result$coords[[i_coord]] <- 1:dims[i_coord] + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- TRUE + } + } + } else if (i_coord %in% VariablesCommon) { # coords in common + coord_in_common <- attributes(object)$Variables$common[[which(i_coord == VariablesCommon)]] + if (inherits(coord_in_common, "POSIXct")) { + result$attrs$Dates <- coord_in_common + } + if (length(coord_in_common) == dims[i_coord]) { + if (remove_attrs_coords) { + if (inherits(coord_in_common, "POSIXct")) { + result$coords[[i_coord]] <- coord_in_common + } else { + result$coords[[i_coord]] <- as.vector(coord_in_common) + } + } else { + result$coords[[i_coord]] <- coord_in_common + } + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- FALSE + } else { + result$coords[[i_coord]] <- 1:dims[i_coord] + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- TRUE + } + } else if (!is.null(VariablesDat)) { # coords in dat + if (i_coord %in% VariablesDat) { + coord_in_dat <- attributes(object)$Variables[[dat]][[which(i_coord == VariablesDat)]] + if (inherits(coord_in_dat, "POSIXct")) { + result$attrs$Dates <- coord_in_dat + } + if (length(coord_in_dat) == dims[i_coord]) { + if (remove_attrs_coords) { + if (inherits(coord_in_dat, "POSIXct")) { + result$coords[[i_coord]] <- coord_in_dat + } else { + result$coords[[i_coord]] <- as.vector(coord_in_dat) + } + } else { + result$coords[[i_coord]] <- coord_in_dat + } + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- FALSE + } else { + result$coords[[i_coord]] <- 1:dims[i_coord] + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- TRUE + } + } else { + result$coords[[i_coord]] <- 1:dims[i_coord] + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- TRUE + } + } else { # missing other dims + result$coords[[i_coord]] <- 1:dims[i_coord] + if (!remove_attrs_coords) attr(result$coords[[i_coord]], 'indices') <- TRUE + } + # if (any('variables' %in% names(attributes(result$coord[[i_coord]])))) { + # vars_attributes <- attributes(result$coord[[i_coord]])$variables[[1]] + # for (k in 1:length(vars_attributes)) { + # attr(result$coord[[i_coord]], names(vars_attributes)[k]) <- vars_attributes[[k]] + # } + # } } - vars <- which(!common_attr_names %in% c("time", known_lon_names, known_lat_names)) - - if (length(vars) > 1) { - warning("More than one variable has been provided and ", - "only the first one '", common_attr_names[vars[1]],"' will be used.") - vars <- vars[1] + # attrs + ## varName + if (!is.null(varName)) { + result$attrs$Variable$varName <- varName } - - Variable <- list() - Variable$varName <- names(attributes(object)$Variables$common)[vars] - attr(Variable, 'variable') <- attributes(object)$Variables$common[[vars]] - result$Variable <- Variable - dims <- dim(object) - if (any(c('sdate', 'sdates') %in% names(dims))) { - n_sdates <- dims[which(names(dims) == 'sdate' | names(dims) == 'sdates')] - sdates <- attributes(object)$Variables$common$time[1 : n_sdates] + ## Variables + for (var_type in names(attributes(object)$Variables)) { + if (!is.null(attributes(object)$Variables[[var_type]])) { + for (var in names(attributes(object)$Variables[[var_type]])) { + attr_variable <- attributes(object)$Variables[[var_type]][[var]] + if (is.null(result$attrs$Dates)) { + if (inherits(attr_variable, "POSIXct")) { + result$attrs$Dates <- attr_variable + } + } + result$attrs$Variable$metadata[[var]] <- attr_variable + } + } + } + ## Datasets + if (length(names(FileSelector)) > 1) { + # lon name + known_lon_names <- .KnownLonNames() + lon_name_dat <- names(dims)[which(names(dims) %in% known_lon_names)] + # lat name + known_lat_names <- .KnownLatNames() + lat_name_dat <- names(dims)[which(names(dims) %in% known_lat_names)] + result$attrs$Datasets <- names(FileSelector) + for (i in 2:length(names(FileSelector))) { + if (!is.null(lon_name_dat)) { + if (any(result$coords[[lon_name_dat]] != as.vector(attributes(object)$Variables[[names(FileSelector)[i]]][[lon_name_dat]]))) { + warning("'lon' values are different for different datasets. ", + "Only values from the first will be used.") + } + } + if (!is.null(lat_name_dat)) { + if (any(result$coords[[lat_name_dat]] != as.vector(attributes(object)$Variables[[names(FileSelector)[i]]][[lat_name_dat]]))) { + warning("'lat' values are different for different datasets. ", + "Only values from the first will be used.") + } + } + } } else { - sdates <- attributes(object)$Variables$common$time[1] + result$attrs$Datasets <- names(FileSelector) } - Dataset <- list(list(InitializationDates = list(Member_1 = sdates))) - names(Dataset) <- list(deparse(substitute(object))) - result$Datasets <- Dataset - result$Dates$start <- attributes(object)$Variables$common$time - result$when <- Sys.time() - result$source_files <- as.vector(attributes(object)$Files) - result$load_parameters <- attributes(object)$FileSelectors + ## when + result$attrs$when <- Sys.time() + ## source_files + result$attrs$source_files <- attributes(object)$Files + ## load_parameters + result$attrs$load_parameters <- attributes(object)$FileSelectors class(result) <- 's2dv_cube' } else { stop("The class of parameter 'object' is not implemented", " to be converted into 's2dv_cube' class yet.") } - result - -} + return(result) +} \ No newline at end of file diff --git a/R/s2dv_cube.R b/R/s2dv_cube.R index 9cd83480944a15e3ee1fd4f06ee9801f259c8a9a..5f9c465b8490dda0c6635ba43cbd2a65b7f7d33c 100644 --- a/R/s2dv_cube.R +++ b/R/s2dv_cube.R @@ -1,44 +1,71 @@ #'Creation of a 's2dv_cube' object #' -#'@description This function allows to create a 's2dv_cube' object by passing +#'@description This function allows to create an 's2dv_cube' object by passing #'information through its parameters. This function will be needed if the data #'hasn't been loaded using CST_Load or has been transformed with other methods. -#'A 's2dv_cube' object has many different components including metadata. This +#'An 's2dv_cube' object has many different components including metadata. This #'function will allow to create 's2dv_cube' objects even if not all elements #'are defined and for each expected missed parameter a warning message will be #'returned. #' #'@author Perez-Zanon Nuria, \email{nuria.perez@bsc.es} #' -#'@param data an array with any number of named dimensions, typically an object -#' output from CST_Load, with the following dimensions: dataset, member, sdate, -#'ftime, lat and lon. -#'@param lon an array with one dimension containing the longitudes and -#'attributes: dim, cdo_grid_name, data_across_gw, array_across_gw, first_lon, -#'last_lon and projection. -#'@param lat an array with one dimension containing the latitudes and -#'attributes: dim, cdo_grid_name, first_lat, last_lat and projection. -#'@param Variable a list of two elements: \code{varName} a character string -#'indicating the abbreviation of a variable name and \code{level} a character -#'string indicating the level (e.g., "2m"), if it is not required it could be -#' set as NULL. -#'@param Datasets a named list with the dataset model with two elements: -#'\code{InitiatlizationDates}, containing a list of the start dates for each -#'member named with the names of each member, and \code{Members} containing a -#'vector with the member names (e.g., "Member_1") -#'@param Dates a named list of one to two elements: The first element, -#'\code{start}, is an array of dimensions (sdate, time) with the POSIX initial -#'date of each forecast time of each starting date. The second element, -#'\code{end} (optional), is an array of dimensions (sdate, time) with the POSIX -# final date of each forecast time of each starting date. -#'@param time_dims a vector of strings containing the names of the temporal -#'dimensions found in \code{data}. -#'@param when a time stamp of the date issued by the Load() call to obtain the -#'data. -#'@param source_files a vector of character strings with complete paths to all -#'the found files involved in the Load() call. +#'@param data A multidimensional array with named dimensions, typically with +#' dimensions: dataset, member, sdate, ftime, lat and lon. +#'@param coords A named list with elements of the coordinates corresponding to +#' the dimensions of the data parameter. The names and length of each element +#' must correspond to the names of the dimensions. If any coordinate is not +#' provided, it is set as an index vector with the values from 1 to the length +#' of the corresponding dimension. +#'@param varName A character string indicating the abbreviation of the variable +#' name. +#'@param metadata A named list where each element is a variable containing the +#' corresponding information. The information can be contained in a list of +#' lists for each variable. +#'@param Datasets Character strings indicating the names of the dataset. It +#' there are multiple datasets it can be a vector of its names or a list of +#' lists with additional information. +#'@param Dates A POSIXct array of time dimensions containing the Dates. +#'@param when A time stamp of the date when the data has been loaded. This +#' parameter is also found in Load() and Start() functions output. +#'@param source_files A vector of character strings with complete paths to all +#' the found files involved in loading the data. +#'@param \dots Additional elements to be added in the object. They will be +#' stored in the end of 'attrs' element. Multiple elements are accepted. #' -#'@return The function returns an object of class 's2dv_cube'. +#'@return The function returns an object of class 's2dv_cube' with the following +#' elements in the structure:\cr +#'\itemize{ +#' \item{'data', array with named dimensions.} +#' \item{'dims', named vector of the data dimensions.} +#' \item{'coords', named list with elements of the coordinates corresponding to +#' the dimensions of the data parameter. If any coordinate is not provided, it +#' is set as an index vector with the values from 1 to the length of the +#' corresponding dimension. The attribute 'indices' indicates wether the +#' coordinate is an index vector (TRUE) or not (FALSE).} +#' \item{'attrs', named list with elements: +#' \itemize{ +#' \item{'Dates', array with named temporal dimensions of class 'POSIXct' from +#' time values in the data.} +#' \item{'Variable', has the following components: +#' \itemize{ +#' \item{'varName', with the short name of the loaded variable as specified +#' in the parameter 'var'.} +#' \item{''metadata', named list of elements with variable metadata. +#' They can be from coordinates variables (e.g. longitude) or +#' main variables (e.g. 'var').} +#' } +#' } +#' \item{'Datasets', character strings indicating the names of the dataset.} +#' \item{'source_files', a vector of character strings with complete paths to +#' all the found files involved in loading the data.} +#' \item{'when', a time stamp of the date issued by the Start() or Load() call to +#' obtain the data.} +#' \item{'load_parameters', it contains the components used in the arguments to +#' load the data from Start() or Load() functions.} +#' } +#' } +#'} #' #'@seealso \code{\link[s2dv]{Load}} and \code{\link{CST_Load}} #'@examples @@ -46,219 +73,154 @@ #'dim(exp_original) <- c(lat = 2, time = 10, lon = 5) #'exp1 <- s2dv_cube(data = exp_original) #'class(exp1) -#'exp2 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50)) +#'coords <- list(lon = seq(-10, 10, 5), lat = c(45, 50)) +#'exp2 <- s2dv_cube(data = exp_original, coords = coords) #'class(exp2) -#'exp3 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), -#' Variable = list(varName = 'tas', level = '2m')) +#'metadata <- list(tas = list(level = '2m')) +#'exp3 <- s2dv_cube(data = exp_original, coords = coords, +#' varName = 'tas', metadata = metadata) #'class(exp3) -#'exp4 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), -#' Variable = list(varName = 'tas', level = '2m'), -#' Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), -#' end = paste0(rep("31", 10), rep("01", 10), 1990:1999))) +#'Dates = as.POSIXct(paste0(rep("01", 10), rep("01", 10), 1990:1999), format = "%d%m%Y") +#'dim(Dates) <- c(time = 10) +#'exp4 <- s2dv_cube(data = exp_original, coords = coords, +#' varName = 'tas', metadata = metadata, +#' Dates = Dates) #'class(exp4) -#'exp5 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), -#' Variable = list(varName = 'tas', level = '2m'), -#' Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), -#' end = paste0(rep("31", 10), rep("01", 10), 1990:1999)), -#' when = "2019-10-23 19:15:29 CET") +#'exp5 <- s2dv_cube(data = exp_original, coords = coords, +#' varName = 'tas', metadata = metadata, +#' Dates = Dates, when = "2019-10-23 19:15:29 CET") #'class(exp5) -#'exp6 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), -#' Variable = list(varName = 'tas', level = '2m'), -#' Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), -#' end = paste0(rep("31", 10), rep("01", 10), 1990:1999)), +#'exp6 <- s2dv_cube(data = exp_original, coords = coords, +#' varName = 'tas', metadata = metadata, +#' Dates = Dates, #' when = "2019-10-23 19:15:29 CET", -#' source_files = c("/path/to/file1.nc", "/path/to/file2.nc")) +#' source_files = c("/path/to/file1.nc", "/path/to/file2.nc")) #'class(exp6) -#'exp7 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), -#' Variable = list(varName = 'tas', level = '2m'), -#' Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), -#' end = paste0(rep("31", 10), rep("01", 10), 1990:1999)), +#'exp7 <- s2dv_cube(data = exp_original, coords = coords, +#' varName = 'tas', metadata = metadata, +#' Dates = Dates, #' when = "2019-10-23 19:15:29 CET", #' source_files = c("/path/to/file1.nc", "/path/to/file2.nc"), #' Datasets = list( #' exp1 = list(InitializationsDates = list(Member_1 = "01011990", #' Members = "Member_1")))) #'class(exp7) -#'dim(exp_original) <- c(dataset = 1, member = 1, sdate = 2, ftime = 5, lat = 2, lon = 5) -#'exp8 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), -#' Variable = list(varName = 'tas', level = '2m'), -#' Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), -#' end = paste0(rep("31", 10), rep("01", 10), 1990:1999))) +#'dim(exp_original) <- c(dataset = 1, member = 1, time = 10, lat = 2, lon = 5) +#'exp8 <- s2dv_cube(data = exp_original, coords = coords, +#' varName = 'tas', metadata = metadata, +#' Dates = Dates, original_dates = Dates) #'class(exp8) #'@export -s2dv_cube <- function(data, lon = NULL, lat = NULL, Variable = NULL, Datasets = NULL, - Dates = NULL, time_dims = NULL, when = NULL, source_files = NULL) { - +s2dv_cube <- function(data, coords = NULL, varName = NULL, metadata = NULL, + Datasets = NULL, Dates = NULL, when = NULL, + source_files = NULL, ...) { + + # data if (is.null(data) | !is.array(data) | is.null(names(dim(data)))) { stop("Parameter 'data' must be an array with named dimensions.") } + # dims dims <- dim(data) - if (is.null(lon)) { - if (any(c('lon', 'longitude') %in% names(dims))) { - warning("Parameter 'lon' is not provided but data contains a ", - "longitudinal dimension.") - } else { - warning("Parameter 'lon' is not provided so the data is from an ", - "unknown location.") + + ## coords + if (!is.null(coords)) { + if (!all(names(coords) %in% names(dims))) { + coords <- coords[-which(!names(coords) %in% names(dims))] } - } - if (is.null(lat)) { - if (any(c('lat', 'latitude') %in% names(dims))) { - warning("Parameter 'lat' is not provided but data contains a ", - "latitudinal dimension.") - } else { - warning("Parameter 'lat' is not provided so the data is from an ", - "unknown location.") + for (i_coord in names(dims)) { + if (i_coord %in% names(coords)) { + if (length(coords[[i_coord]]) != dims[i_coord]) { + warning(paste0("Coordinate '", i_coord, "' has different lenght as ", + "its dimension and it will not be used.")) + coords[[i_coord]] <- 1:dims[i_coord] + attr(coords[[i_coord]], 'indices') <- TRUE + } else { + attr(coords[[i_coord]], 'indices') <- FALSE + } + } else { + warning(paste0("Coordinate '", i_coord, "' is not provided ", + "and it will be set as index in element coords.")) + coords[[i_coord]] <- 1:dims[i_coord] + attr(coords[[i_coord]], 'indices') <- TRUE + } + } + } else { + coords <- sapply(names(dims), function(x) 1:dims[x]) + for (i in 1:length(coords)) { + attr(coords[[i]], "indices") <- TRUE } } - if (is.null(Variable)) { - warning("Parameter 'Variable' is not provided so the metadata ", - "of 's2dv_cube' object will be incomplete.") - } - if (is.null(Datasets)) { - warning("Parameter 'Datasets' is not provided so the metadata ", - "of 's2dv_cube' object will be incomplete.") - } + + ## attrs + attrs <- list() + # Dates if (is.null(Dates)) { - if (!is.null(time_dims)) { - if (any(time_dims %in% names(dims))) { - warning("Parameter 'Dates' is not provided but data contains a ", - "temporal dimension.") + warning("Parameter 'Dates' is not provided so the metadata ", + "of 's2dv_cube' object will be incomplete.") + attrs$Dates <- NULL + } else if (length(Dates) == 1 & inherits(Dates[1], "POSIXct")) { + attrs$Dates <- Dates + } else { + if (!is.array(Dates)) { + warning("Parameter 'Dates' must be an array with named time dimensions.") + } else { + if (is.null(names(dim(Dates)))) { + warning("Parameter 'Dates' must have dimension names.") + } else if (!all(names(dim(Dates)) %in% names(dims))) { + warning("Parameter 'Dates' must have the corresponding time dimension names in 'data'.") } else { - warning("Data does not contain any of the temporal dimensions ", - "in 'time_dims'.") + if (inherits(Dates[1], "POSIXct")) { + attrs$Dates <- Dates + } else { + warning("Parameter 'Dates' must be of class 'POSIXct'.") + } } - } else if (any(c('time', 'ftime', 'sdate') %in% names(dims))) { - warning("Parameter 'Dates' is not provided but data contains a ", - "temporal dimension.") - } else { - warning("Parameter 'Dates' is not provided so the data is from an ", - "unknown time period.") } } - if (is.null(when)) { - warning("Parameter 'when' is not provided so the metadata ", + # Variable + if (is.null(varName)) { + warning("Parameter 'varName' is not provided so the metadata ", "of 's2dv_cube' object will be incomplete.") + attrs$Variable$varName <- NULL + } else { + if (!is.character(varName)) { + warning("Parameter 'varName' must be a character.") + } else { + attrs$Variable$varName <- varName + } } - if (is.null(source_files)) { - warning("Parameter 'source_files' is not provided so the metadata ", + if (is.null(metadata)) { + warning("Parameter 'metadata' is not provided so the metadata ", "of 's2dv_cube' object will be incomplete.") - } - if (!is.null(Variable)) { - if (!is.list(Variable)) { - Variable <- list(Variable) - } - if (names(Variable)[1] != 'varName' | names(Variable)[2] != 'level') { - warning("The name of the first element of parameter 'Variable' is ", - "expected to be 'varName' and the second 'level'.") - } - if (!is.character(Variable[[1]])) { - warning("The element 'Varname' of parameter 'Variable' must be ", - "a character.") + attrs$Variable$metadata <- NULL + } else { + if (!is.list(metadata)) { + metadata <- list(metadata) } + attrs$Variable$metadata <- metadata } - # Dimensions comparison - ## lon - if (!is.null(lon)) { - if (any(names(dims) %in% c('lon', 'longitude'))) { - name_lon <- names(dims[names(dims) %in% c('lon', 'longitude')]) - if (dims[name_lon] != length(lon) & dims[name_lon] != 1) { - stop("Length of parameter 'lon' doesn't match the length of ", - "longitudinal dimension in parameter 'data'.") - } - if (!is.null(names(dim(lon))) && !identical(name_lon, names(dim(lon)))) { - stop("The dimension name of parameter 'lon' is not consistent ", - "with data dimension name for longitude.") - } else { - dim(lon) <- length(lon) - names(dim(lon)) <- name_lon - } - } else if (!is.null(names(dim(lon))) && names(dim(lon)) %in% names(dims)) { - name_lon <- names(dims[names(dim(lon))]) - if (length(lon) != dims[name_lon]) { - stop("The length of the longitudinal dimension doesn't match ", - "with the length of 'lon' parameter.") - } else { - warning(paste0("Detected the longitude dimension name to be ", names(dim(lon)), - ", which is not the expected names ('lon' or 'longitude') by s2dv_cube.")) - } - } else { - stop("Parameter 'lon' is provided but data doesn't contain a ", - "longitudinal dimension.") - } + # Datasets + if (!is.null(Datasets)) { + attrs$Datasets <- Datasets } - - ## lat - if (!is.null(lat)) { - if (any(names(dims) %in% c('lat', 'latitude'))) { - name_lat <- names(dims[names(dims) %in% c('lat', 'latitude')]) - if (dims[name_lat] != length(lat) & dims[name_lat] != 1) { - stop("Length of parameter 'lat' doesn't match the length of ", - "longitudinal dimension in parameter 'data'.") - } - if (!is.null(names(dim(lat))) && !identical(name_lat, names(dim(lat)))) { - stop("The dimension name of parameter 'lat' is not consistent ", - "with data dimension name for latitude.") - } else { - dim(lat) <- length(lat) - names(dim(lat)) <- name_lat - } - } else if (!is.null(names(dim(lat))) && names(dim(lat)) %in% names(dims)) { - name_lat <- names(dims[names(dim(lat))]) - if (length(lat) != dims[name_lat]) { - stop("The length of the latgitudinal dimension doesn't match ", - "with the length of 'lat' parameter.") - } else { - warning(paste0("Detected the latitude dimension name to be ", names(dim(lat)), - ", which is not the expected names ('lat' or 'latitude') by s2dv_cube.")) - } - } else { - stop("Parameter 'lat' is provided but data doesn't contain a ", - "latitudinal dimension.") - } + # when + if (!is.null(when)) { + attrs$when <- when } - - ## Dates - if (!is.null(Dates)) { - if (!is.list(Dates)) { - stop("Parameter 'Dates' must be a list.") - } else { - if (length(Dates) > 2) { - warning("Parameter 'Dates' is a list with more than 2 ", - "elements and only the first two will be used.") - Dates <- Dates[1 : 2] - } - if (names(Dates)[1] != 'start') { - warning("The name of the first element of parameter 'Dates' ", - "is expected to be 'start'.") - } - if (length(Dates) == 2) { - if (names(Dates)[2] != 'end') { - warning("The name of the second element of parameter 'Dates' ", - "is expected to be 'end'.") - } - if (length(Dates[[1]]) != length(Dates[[2]])) { - stop("The length of the elements in parameter 'Dates' must ", - "be equal.") - } - } - if (!is.null(time_dims)) { - time_dims <- dims[names(dims) %in% time_dims] - } else { - warning("Parameter 'time_dims' is not provided, assigning 'sdate', ", - "'time' and 'ftime' as default time dimension names.") - time_dims <- dims[names(dims) %in% c('sdate', 'time', 'ftime')] - } - if (prod(time_dims) != length(Dates[[1]])) { - stop("The length of the temporal dimension doesn't match ", - "the length of elements in parameter 'Dates'.") - } + # source_files + if (!is.null(source_files)) { + attrs$source_files <- source_files + } + # dots + dots <- list(...) + if (length(dots) != 0) { + for (i_arg in 1:length(dots)) { + attrs[[names(dots)[[i_arg]]]] <- dots[[i_arg]] } } - object <- list(data = data, lon = lon, lat = lat, Variable = Variable, - Datasets = Datasets, Dates = Dates, time_dims = time_dims, - when = when, source_files = source_files) + ## object + object <- list(data = data, dims = dims, coords = coords, attrs = attrs) class(object) <- 's2dv_cube' return(object) } diff --git a/R/zzz.R b/R/zzz.R index 2910875b990a48e4c5188b2ba3e9606db62975b1..18cddaff018075b204d0b4855410fb5037a70440 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -164,13 +164,32 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE } .KnownLonNames <- function() { - known_lon_names <- c('lon', 'longitude', 'x', 'i', 'nav_lon') + known_lon_names <- c('lon', 'lons', 'longitude', 'x', 'i', 'nav_lon') } .KnownLatNames <- function() { - known_lat_names <- c('lat', 'latitude', 'y', 'j', 'nav_lat') + known_lat_names <- c('lat', 'lats', 'latitude', 'y', 'j', 'nav_lat') } .KnownTimeNames <- function() { known_time_names <- c('time', 'ftime', 'sdate', 'sdates', 'syear', 'sweek', 'sday', 'leadtimes') } + +.KnownForecastTimeNames <- function() { + known_time_names <- c('time', 'ftime', 'ltime', 'leadtimes') +} + +.KnownStartDateNames <- function() { + known_time_names <- c('sdate', 'sdates', 'syear', 'sweek', 'sday') +} + +.KnownMemberNames <- function() { + known_time_names <- c('memb', 'member', 'members', 'ensemble', 'ensembles') +} + +.isNullOb <- function(x) is.null(x) | all(sapply(x, is.null)) + +.rmNullObs <- function(x) { + x <- base::Filter(Negate(.isNullOb), x) + lapply(x, function(x) if (is.list(x)) .rmNullObs(x) else x) +} diff --git a/data/lonlat_prec.rda b/data/lonlat_prec.rda index 4c566a4af69dd006258e6e9901aa24f6b8d162dc..9104952dbacd441d3c7ac5b9cf4e921fd6b47f5f 100644 Binary files a/data/lonlat_prec.rda and b/data/lonlat_prec.rda differ diff --git a/data/lonlat_temp.rda b/data/lonlat_temp.rda index 92005f1df553dbaa6a1e27fb2eb6b0cab4fac925..f6fe7e7c126f4fa0d445c78228a46b2be58f0143 100644 Binary files a/data/lonlat_temp.rda and b/data/lonlat_temp.rda differ diff --git a/man/AdamontQQCorr.Rd b/man/AdamontQQCorr.Rd index 52f78e1c43b802a49a0bd7742f011efc95d56aa5..4495527a51317fff6f7749790b2c4cec2e6ad68c 100644 --- a/man/AdamontQQCorr.Rd +++ b/man/AdamontQQCorr.Rd @@ -60,15 +60,19 @@ for experiment data (typically a hindcast) onto reference \code{obs}, typically provided by reanalysis data. } \examples{ -\dontrun{ -wt_exp <- sample(1:3, 15*6*3, replace=T) -dim(wt_exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3) -wt_obs <- sample(1:3, 6*3, replace = T) -dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3) -exp_corr <- AdamontQQCorr(exp = lonlat_temp$exp$data, wt_exp = wt_exp, - obs = lonlat_temp$obs$data, wt_obs = wt_obs, - corrdims = c('dataset','member','sdate','ftime')) -} +wt_exp <- c(1,1,2,3,3,2,2,1,1,2,2,3) +dim(wt_exp) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +wt_obs <- c(3,3,1,2,2,2,2,1,3,1,1,2) +dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +exp <- 1 : c(1 * 1 * 4 * 3 * 4 * 4) +dim(exp) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, + lat = 4, lon = 4) +obs <- 101 : c(100 + 1 * 1 * 4 * 3 * 4 * 4) +dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, + lat = 4, lon = 4) +exp_corr <- AdamontQQCorr(exp = exp, wt_exp = wt_exp, + obs = obs, wt_obs = wt_obs, + corrdims = c('dataset', 'member', 'sdate', 'ftime')) } \author{ Paola Marson, \email{paola.marson@meteo.fr} for PROSNOW version diff --git a/man/Analogs.Rd b/man/Analogs.Rd index b335a929f7cd0078ad490bc31dd32180cfc8b983..6cf62ad42b64d1e6f29ea5320f27bda32e0dd38f 100644 --- a/man/Analogs.Rd +++ b/man/Analogs.Rd @@ -29,7 +29,10 @@ on the large scale for which the analog is aimed. This field is used to in all the criterias. If parameter 'expVar' is not provided, the function will return the expL analog. The element 'data' in the 's2dv_cube' object must have, at least, latitudinal and longitudinal dimensions. The object is -expect to be already subset for the desired large scale region.} +expect to be already subset for the desired large scale region. Latitudinal +dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. +Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', +'nav_lon'.} \item{obsL}{An array of N named dimensions containing the observational field on the large scale. The element 'data' in the 's2dv_cube' object must have @@ -154,23 +157,7 @@ dim(obs.pr) <- dim(obsSLP) downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, obsVar = obs.pr, time_obsL = time_obsSLP, time_expL = "01-01-1994") -# Example 3: List of best Analogs using criteria 'Large_dist' and a single -obsSLP <- c(rnorm(1:1980), expSLP * 1.5) -dim(obsSLP) <- c(lat = 4, lon = 5, time = 100) -time_obsSLP <- paste(rep("01", 100), rep("01", 100), 1920 : 2019, sep = "-") -downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, time_obsSLP, - nAnalogs = 5, time_expL = "01-01-2003", - AnalogsInfo = TRUE, excludeTime = "01-01-2003") - -# Example 4: List of best Analogs using criteria 'Large_dist' and 2 variables: -obsSLP <- c(rnorm(1:180), expSLP * 2) -dim(obsSLP) <- c(lat = 4, lon = 5, time = 10) -time_obsSLP <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-") -downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, obsVar = obs.pr, - time_obsL = time_obsSLP, nAnalogs = 5, - time_expL = "01-10-2003", AnalogsInfo = TRUE) - -# Example 5: Downscaling using criteria 'Local_dist' and 2 variables: +# Example 3: Downscaling using criteria 'Local_dist' and 2 variables: # analogs of local scale using criteria 2 region = c(lonmin = -1 ,lonmax = 2, latmin = 30, latmax = 33) Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, @@ -179,21 +166,7 @@ Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, region = region,time_expL = "01-10-2000", nAnalogs = 10, AnalogsInfo = TRUE) -# Example 6: list of best analogs using criteria 'Local_dist' and 2 -Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, - criteria = "Local_dist", lonL = seq(-1, 5, 1.5), - latL = seq(30, 35, 1.5), region = region, - time_expL = "01-10-2000", nAnalogs = 5, - AnalogsInfo = TRUE) - -# Example 7: Downscaling using Local_dist criteria -Local_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, - criteria = "Local_dist", lonL = seq(-1, 5, 1.5), - latL = seq(30, 35, 1.5), region = region, - time_expL = "01-10-2000", - nAnalogs = 10, AnalogsInfo = FALSE) - -# Example 8: Downscaling using criteria 'Local_cor' and 2 variables: +# Example 4: Downscaling using criteria 'Local_cor' and 2 variables: exp.pr <- c(rnorm(1:20) * 0.001) dim(exp.pr) <- dim(expSLP) Local_scalecor <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, @@ -202,15 +175,8 @@ Local_scalecor <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, time_expL = "01-10-2000", latL = seq(30, 35, 1.5), lonVar = seq(-1, 5, 1.5), latVar = seq(30, 35, 1.5), nAnalogs = 8, region = region, AnalogsInfo = FALSE) -# same but without imposing nAnalogs, so nAnalogs will be set by default as 10 -Local_scalecor <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, - obsVar = obs.pr, expVar = exp.pr, - lonVar = seq(-1, 5, 1.5), latVar = seq(30, 35, 1.5), - criteria = "Local_cor", lonL = seq(-1,5,1.5), - time_expL = "01-10-2000", latL = seq(30, 35, 1.5), - region = region, AnalogsInfo = TRUE) -#'Example 9: List of best analogs in the three criterias Large_dist, +# Example 5: List of best analogs in the three criterias Large_dist, Large_scale <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, criteria = "Large_dist", time_expL = "01-10-2000", nAnalogs = 7, AnalogsInfo = TRUE) @@ -225,19 +191,6 @@ Local_scalecor <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP, lonVar = seq(-1, 5, 1.5), latVar = seq(30, 35, 1.5), nAnalogs = 7, region = region, AnalogsInfo = TRUE) -#Example 10: Downscaling using criteria 'Large_dist' and a single variable, -# more than 1 sdate: -expSLP <- rnorm(1:40) -dim(expSLP) <- c(sdate = 2, lat = 4, lon = 5) -obsSLP <- c(rnorm(1:180), expSLP * 1.2) -dim(obsSLP) <- c(time = 11, lat = 4, lon = 5) -time_obsSLP <- paste(rep("01", 11), rep("01", 11), 1993 : 2003, sep = "-") -time_expSLP <- paste(rep("01", 2), rep("01", 2), 1994 : 1995, sep = "-") -excludeTime <- c("01-01-2003", "01-01-2003") -dim(excludeTime) <- c(sdate = 2) -downscale_field_exclude <- Analogs(expL = expSLP, obsL = obsSLP, - time_obsL = time_obsSLP, time_expL = time_expSLP, - excludeTime = excludeTime, AnalogsInfo = TRUE) } \references{ Yiou, P., T. Salameh, P. Drobinski, L. Menut, R. Vautard, diff --git a/man/BEI_EMWeighting.Rd b/man/BEI_EMWeighting.Rd new file mode 100644 index 0000000000000000000000000000000000000000..cd47ff0142b15116edadbfc98806743148608f05 --- /dev/null +++ b/man/BEI_EMWeighting.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CST_BEI_Weighting.R +\name{BEI_EMWeighting} +\alias{BEI_EMWeighting} +\title{Computing the weighted ensemble means for SFSs.} +\usage{ +BEI_EMWeighting(var_exp, aweights, time_dim_name = "time", memb_dim = "member") +} +\arguments{ +\item{var_exp}{Variable (e.g. precipitation, temperature, NAO index) +array from a SFS with at least dimensions (time, member) for a spatially +aggregated variable or dimensions (time, member, lat, lon) for a spatial +variable, as 'time' the spatial dimension by default.} + +\item{aweights}{Normalized weights array with at least dimensions +(time, member), when 'time' is the temporal dimension as default.} + +\item{time_dim_name}{A character string indicating the name of the +temporal dimension, by default 'time'.} + +\item{memb_dim}{A character string indicating the name of the +member dimension, by default 'member'.} +} +\value{ +BEI_EMWeighting() returns an array with at least one or three +dimensions depending if the variable is spatially aggregated variable +(as e.g. NAO index)(time) or it is spatial variable (as e.g. precipitation +or temperature) (time, lat, lon), containing the ensemble means computing +with weighted members. +} +\description{ +This function implements the computation to obtain the weighted +ensemble means for SFSs using a normalized weights array, +} +\examples{ +# Example 1 +var_exp <- 1 : (2 * 3 * 4) +dim(var_exp) <- c(time = 2, dataset = 3, member = 4) +aweights <- runif(24, min = 0.001, max = 0.999) +dim(aweights) <- c(time = 2, dataset = 3, member = 4) +res <- BEI_EMWeighting(var_exp, aweights) + +# Example 2 +var_exp <- 1 : (2 * 4 * 2 * 3) +dim(var_exp) <- c(time = 2, member = 4, lat = 2, lon = 3) +aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +dim(aweights) <- c(time = 2, member = 4) +res <- BEI_EMWeighting(var_exp, aweights) + +} +\references{ +Regionally improved seasonal forecast of precipitation through Best +estimation of winter NAO, Sanchez-Garcia, E. et al., +Adv. Sci. Res., 16, 165174, 2019, https://doi.org/10.5194/asr-16-165-2019 +} +\author{ +Eroteida Sanchez-Garcia - AEMET, \email{esanchezg@aemet.es} +} diff --git a/man/BEI_PDFBest.Rd b/man/BEI_PDFBest.Rd index 7beba37206c36ed6d145a5b464e680d8d222a28a..5edaf07b4c759e65f1dddb24056f0165d176a15d 100644 --- a/man/BEI_PDFBest.Rd +++ b/man/BEI_PDFBest.Rd @@ -102,10 +102,7 @@ index_fcst2 <- rnorm(18, mean = -0.5, sd = 4) dim(index_fcst2) <- c(time = 1, member = 9, season = 2) method_BC <- 'ME' res <- BEI_PDFBest(index_obs, index_hind1, index_hind2, index_fcst1, -index_fcst2, method_BC) -dim(res) -# time statistic season -# 1 2 2 +index_fcst2, method_BC) # Example 2 for the BEI_PDFBest function index_obs<- rnorm(10, sd = 3) dim(index_obs) <- c(time = 5, season = 2) @@ -120,9 +117,6 @@ dim(index_fcst2) <- c(time = 1, member = 9, season = 2) method_BC <- c('LMEV', 'ME') res <- BEI_PDFBest(index_obs, index_hind1, index_hind2, index_fcst1, index_fcst2, method_BC) -dim(res) -# time statistic season -# 1 2 2 } \references{ Regionally improved seasonal forecast of precipitation through diff --git a/man/BEI_ProbsWeighting.Rd b/man/BEI_ProbsWeighting.Rd new file mode 100644 index 0000000000000000000000000000000000000000..17c1d592d7968281396375fdafc056983c84931d --- /dev/null +++ b/man/BEI_ProbsWeighting.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CST_BEI_Weighting.R +\name{BEI_ProbsWeighting} +\alias{BEI_ProbsWeighting} +\title{Computing the weighted tercile probabilities for SFSs.} +\usage{ +BEI_ProbsWeighting( + var_exp, + aweights, + terciles, + time_dim_name = "time", + memb_dim = "member" +) +} +\arguments{ +\item{var_exp}{Variable (e.g. precipitation, temperature, NAO index) +array from a SFS with at least dimensions (time, member) for a spatially +aggregated variable or dimensions (time, member, lat, lon) for a spatial +variable, as 'time' the spatial dimension by default.} + +\item{aweights}{Normalized weights array with at least dimensions +(time, member), when 'time' is the temporal dimension as default.} + +\item{terciles}{A numeric array with at least one dimension 'tercil' equal to +2, the first element is the lower tercil for a hindcast period, and the second +element is the upper tercile.} + +\item{time_dim_name}{A character string indicating the name of the +temporal dimension, by default 'time'.} + +\item{memb_dim}{A character string indicating the name of the +member dimension, by default 'member'.} +} +\value{ +BEI_ProbsWeighting() returns an array with at least two or four +dimensions depending if the variable is a spatially aggregated variable +(as e.g. NAO index)(time, tercil) or it is spatial variable (as e.g. +precipitation or temperature)(time, tercile, lat, lon), containing the +terciles probabilities computing with weighted members. +The first tercil is the lower tercile, the second is the normal tercile and +the third is the upper tercile. +} +\description{ +This function implements the computation to obtain the tercile +probabilities for a weighted variable for SFSs using a normalized weights array, +} +\examples{ +# Example 1 +var_exp <- 1 : (2 * 4) +dim(var_exp) <- c(time = 2, member = 4) +aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +dim(aweights) <- c(time = 2, member = 4) +terciles <- c(2.5,5) +dim(terciles) <- c(tercil = 2) +res <- BEI_ProbsWeighting(var_exp, aweights, terciles) + +# Example 2 +var_exp <- rnorm(48, 50, 9) +dim(var_exp) <- c(time = 2, member = 4, lat = 2, lon = 3) +aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +dim(aweights) <- c(time = 2, member = 4) +terciles <- rep(c(48,50), 2*3) +dim(terciles) <- c(tercil = 2, lat = 2, lon = 3) +res <- BEI_ProbsWeighting(var_exp, aweights, terciles) +} +\references{ +Regionally improved seasonal forecast of precipitation through Best +estimation of winter NAO, Sanchez-Garcia, E. et al., +Adv. Sci. Res., 16, 165174, 2019, \url{https://doi.org/10.5194/asr-16-165-2019} +} +\author{ +Eroteida Sanchez-Garcia - AEMET, \email{esanchezg@aemet.es} +} diff --git a/man/BEI_TercilesWeighting.Rd b/man/BEI_TercilesWeighting.Rd new file mode 100644 index 0000000000000000000000000000000000000000..ab88af1845d9533e8250e338ef84487312e569d8 --- /dev/null +++ b/man/BEI_TercilesWeighting.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CST_BEI_Weighting.R +\name{BEI_TercilesWeighting} +\alias{BEI_TercilesWeighting} +\title{Computing the weighted terciles for SFSs.} +\usage{ +BEI_TercilesWeighting( + var_exp, + aweights, + time_dim_name = "time", + memb_dim = "member" +) +} +\arguments{ +\item{var_exp}{Variable (e.g. precipitation, temperature, NAO index) +array from a SFS with at least dimensions (time, member) for a spatially +aggregated variable or dimensions (time, member, lat, lon) for a spatial +variable, as 'time' the spatial dimension by default.} + +\item{aweights}{Normalized weights array with at least dimensions +(time, member), when 'time' is the temporal dimension as default.} + +\item{time_dim_name}{A character string indicating the name of the +temporal dimension, by default 'time'.} + +\item{memb_dim}{A character string indicating the name of the +member dimension, by default 'member'.} +} +\value{ +BEI_TercilesWeighting() returns an array with at least one +dimension depending if the variable is a spatially aggregated variable +(as e.g. NAO index)(tercil) or it is spatial variable (as e.g. +precipitation or temperature)(tercil, lat, lon), containing the +terciles computing with weighted members. +The first tercil is the lower tercile, the second is the upper tercile. +} +\description{ +This function implements the computation to obtain the terciles +for a weighted variable for SFSs using a normalized weights array, +} +\examples{ +# Example 1 +var_exp <- 1 : (2 * 4) +dim(var_exp) <- c(time = 2, member = 4) +aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +dim(aweights) <- c(time = 2, member = 4) +res <- BEI_TercilesWeighting(var_exp, aweights) + +# Example 2 +var_exp <- rnorm(48, 50, 9) +dim(var_exp) <- c(time = 2, member = 4, lat = 2, lon = 3) +aweights<- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3) +dim(aweights) <- c(time = 2, member = 4) +res <- BEI_TercilesWeighting(var_exp, aweights) +} +\references{ +Regionally improved seasonal forecast of precipitation through Best +estimation of winter NAO, Sanchez-Garcia, E. et al., +Adv. Sci. Res., 16, 165174, 2019, https://doi.org/10.5194/asr-16-165-2019 +} +\author{ +Eroteida Sanchez-Garcia - AEMET, \email{esanchezg@aemet.es} +} diff --git a/man/CST_AdamontAnalog.Rd b/man/CST_AdamontAnalog.Rd index 12e150945c129ae2dd82781d85edd80690f7bcf5..e593b6a02ac26885eb69a9dc8c590acf9e5f9a76 100644 --- a/man/CST_AdamontAnalog.Rd +++ b/man/CST_AdamontAnalog.Rd @@ -33,28 +33,24 @@ AdamontAnalog( ) } \arguments{ -\item{exp}{\itemize{ -\item\code{CST_AdamontAnalog}{experiment data an object of class - \code{s2dv_cube}, can be output from quantile correction using - CST_AdamontQQCorr.} -\item\code{AdamontAnalog}{experiment data array with named dimension.}}} +\item{exp}{A multidimensional array with named dimensions containing the +experiment data.} -\item{obs}{\itemize{ -\item\code{CST_AdamontAnalog}{reference data, also of class \code{s2dv_cube}.} -\item\code{AdamontAnalog}{reference data array with named dimension.}} -Note that lat/lon dimensions need to be the same as \code{exp}} +\item{obs}{A multidimensional array with named dimensions containing the +reference data. Note that lat/lon dimensions need to be the same as +\code{exp}.} \item{wt_exp}{Corresponding weather types (same dimensions as \code{exp$data} but lat/lon).} \item{wt_obs}{Corresponding weather types (same dimensions as \code{obs$data} -but lat/lon)} +but lat/lon).} \item{nanalogs}{Integer defining the number of analog values to return -(default: 5)} +(default: 5).} \item{method}{A character string indicating the method used for analog -definition. Coded are: +definition. It can be: \itemize{ \item{'pattcorr': pattern correlation.} \item{'rain1' (for precip patterns): rain occurrence consistency.} @@ -63,7 +59,7 @@ definition. Coded are: }} \item{thres}{Real number indicating the threshold to define rain -occurrence/non occurrence in rain(0)1} +occurrence/non occurrence in rain (0)1.} \item{search_obsdims}{List of dimensions in \code{obs} along which analogs are searched for.} @@ -73,33 +69,47 @@ searched for.} \item{latdim}{Name of latitude dimension.} } \value{ -analog_vals -\itemize{ - \item\code{CST_AdamontAnalog}{An object of class \code{s2dv_cube} containing - nanalogs analog values for each value of \code{exp} input data.} - \item\code{AdamontAnalog}{An array containing nanalogs analog values.}} +analog_vals An object of class \code{s2dv_cube} containing + nanalogs analog values for each value of \code{exp} input data. + +analog_vals An array containing nanalogs analog values. } \description{ +This function searches for analogs in a reference dataset for +experiment data, based on corresponding weather types. The experiment data is +typically a hindcast, observations are typically provided by reanalysis data. + This function searches for analogs in a reference dataset for experiment data, based on corresponding weather types. The experiment data is typically a hindcast, observations are typically provided by reanalysis data. } \examples{ -\dontrun{ -wt_exp <- sample(1:3, 15*6*3, replace=T) -dim(wt_exp) <- c(dataset=1, member=15, sdate=6, ftime=3) -wt_obs <- sample(1:3, 6*3, replace=T) -dim(wt_obs) <- c(dataset=1, member=1, sdate=6, ftime=3) -analog_vals <- CST_AdamontAnalog(exp = lonlat_temp$exp, obs = lonlat_temp$obs, - wt_exp = wt_exp, wt_obs = wt_obs, nanalogs = 2) -} -\dontrun{ -wt_exp <- sample(1:3, 15*6*3, replace=T) -dim(wt_exp) <- c(dataset=1, member=15, sdate=6, ftime=3) -wt_obs <- sample(1:3, 6*3, replace=T) -dim(wt_obs) <- c(dataset=1, member=1, sdate=6, ftime=3) - obs=lonlat_temp$obs$data, wt_exp=wt_exp, wt_obs=wt_obs, nanalogs=2) -} +wt_exp <- sample(1:3, 15*6*3, replace = TRUE) +dim(wt_exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3) +wt_obs <- sample(1:3, 6*3, replace = TRUE) +dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3) +exp <- NULL +exp$data <- 1 : c(1 * 15 * 6 * 3 * 8 * 8) +dim(exp$data) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3, + lat = 8, lon = 8) +class(exp) <- 's2dv_cube' +obs <- NULL +obs$data <- 101 : c(100 + 1 * 1 * 6 * 3 * 8 * 8) +dim(obs$data) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3, + lat = 8, lon = 8) +class(obs) <- 's2dv_cube' +analog_vals <- CST_AdamontAnalog(exp = exp, obs = obs, wt_exp = wt_exp, + wt_obs = wt_obs, nanalogs = 2) +wt_exp <- sample(1:3, 15*6*3, replace = TRUE) +dim(wt_exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3) +wt_obs <- sample(1:3, 6*3, replace = TRUE) +dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3) +exp <- 1 : c(1 * 15 * 6 * 3 * 8 * 8) +dim(exp) <- c(dataset = 1, member = 15, sdate = 6, ftime = 3, lat = 8, lon = 8) +obs <- 101 : c(100 + 1 * 1 * 6 * 3 * 8 * 8) +dim(obs) <- c(dataset = 1, member = 1, sdate = 6, ftime = 3, lat = 8, lon = 8) +analog_vals <- AdamontAnalog(exp = exp, obs = obs, wt_exp = wt_exp, + wt_obs = wt_obs, nanalogs = 2) } \author{ Paola Marson, \email{paola.marson@meteo.fr} for PROSNOW version diff --git a/man/CST_AdamontQQCorr.Rd b/man/CST_AdamontQQCorr.Rd index 35ab00ade4221087c7878ddfd80eaa57e33566cc..fcea5fc2ae61597b22fc9ff4e868ee76c6ec6199 100644 --- a/man/CST_AdamontQQCorr.Rd +++ b/man/CST_AdamontQQCorr.Rd @@ -49,15 +49,23 @@ for experiment data (typically a hindcast) onto reference \code{obs}, typically provided by reanalysis data. } \examples{ -\dontrun{ -wt_exp <- sample(1:3, 15*6*3, replace=T) -dim(wt_exp) <- c(dataset=1, member=15, sdate=6, ftime=3) -wt_obs <- sample(1:3, 6*3, replace=T) -dim(wt_obs) <- c(dataset=1, member=1, sdate=6, ftime=3) -exp_corr <- CST_AdamontQQCorr(exp = lonlat_temp$exp, wt_exp = wt_exp, - obs=lonlat_temp$obs, wt_obs = wt_obs, - corrdims = c('dataset','member','sdate','ftime')) -} +wt_exp <- c(1,1,2,3,3,2,2,1,1,2,2,3) +dim(wt_exp) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +wt_obs <- c(3,3,1,2,2,2,2,1,3,1,1,2) +dim(wt_obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3) +exp <- NULL +exp$data <- 1 : c(1 * 1 * 4 * 3 * 4 * 4) +dim(exp$data) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, + lat = 4, lon = 4) +class(exp) <- 's2dv_cube' +obs <- NULL +obs$data <- 101 : c(100 + 1 * 1 * 4 * 3 * 4 * 4) +dim(obs$data) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, + lat = 4, lon = 4) +class(obs) <- 's2dv_cube' +exp_corr <- CST_AdamontQQCorr(exp = exp, wt_exp = wt_exp, + obs = obs, wt_obs = wt_obs, + corrdims = c('dataset','member','sdate','ftime')) } \author{ Lauriane Batté, \email{lauriane.batte@meteo.fr} diff --git a/man/CST_Analogs.Rd b/man/CST_Analogs.Rd index e085b752f5c757f9d1afa5bb8ab821fea7fa7607..cac70cdc023cf2898a37628c6acc4320fc540e45 100644 --- a/man/CST_Analogs.Rd +++ b/man/CST_Analogs.Rd @@ -25,7 +25,9 @@ large scale for which the analog is aimed. This field is used to in all the criterias. If parameter 'expVar' is not provided, the function will return the expL analog. The element 'data' in the 's2dv_cube' object must have, at least, latitudinal and longitudinal dimensions. The object is expect to be -already subset for the desired large scale region.} +already subset for the desired large scale region. Latitudinal dimension +accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. Longitudinal +dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 'nav_lon'.} \item{obsL}{An 's2dv_cube' object containing the observational field on the large scale. The element 'data' in the 's2dv_cube' object must have the same @@ -63,11 +65,11 @@ time_obsL), by default time_expL will be removed during the search of analogs.} \item{time_expL}{A character string indicating the date of the experiment in the same format than time_obsL (i.e. "yyyy-mm-dd"). By default it is NULL -and dates are taken from element \code{$Dates$start} from expL.} +and dates are taken from element \code{$attrs$Dates} from expL.} \item{time_obsL}{A character string indicating the date of the observations in the date format (i.e. "yyyy-mm-dd"). By default it is NULL and dates are -taken from element \code{$Dates$start} from obsL.} +taken from element \code{$attrs$Dates} from obsL.} \item{nAnalogs}{Number of Analogs to be selected to apply the criterias 'Local_dist' or 'Local_cor'. This is not the necessary the number of analogs @@ -126,17 +128,22 @@ function within 'CSTools' package. } \examples{ expL <- rnorm(1:200) -dim(expL) <- c(member = 10,lat = 4, lon = 5) -obsL <- c(rnorm(1:180),expL[1,,]*1.2) -dim(obsL) <- c(time = 10,lat = 4, lon = 5) -time_obsL <- paste(rep("01", 10), rep("01", 10), 1994:2003, sep = "-") +dim(expL) <- c(member = 10, lat = 4, lon = 5) +obsL <- c(rnorm(1:180), expL[1, , ]*1.2) +dim(obsL) <- c(time = 10, lat = 4, lon = 5) +time_obsL <- as.POSIXct(paste(rep("01", 10), rep("01", 10), 1994:2003, sep = "-"), + format = "\%d-\%m-\%y") +dim(time_obsL) <- c(time = 10) time_expL <- time_obsL[1] -lon <- seq(-1,5,1.5) -lat <- seq(30,35,1.5) -expL <- s2dv_cube(data = expL, lat = lat, lon = lon, - Dates = list(start = time_expL, end = time_expL)) -obsL <- s2dv_cube(data = obsL, lat = lat, lon = lon, - Dates = list(start = time_obsL, end = time_obsL)) +lon <- seq(-1, 5, 1.5) +lat <- seq(30, 35, 1.5) +coords <- list(lon = seq(-1, 5, 1.5), lat = seq(30, 35, 1.5)) +attrs_expL <- list(Dates = time_expL) +attrs_obsL <- list(Dates = time_obsL) +expL <- list(data = expL, coords = coords, attrs = attrs_expL) +obsL <- list(data = obsL, coords = coords, attrs = attrs_obsL) +class(expL) <- 's2dv_cube' +class(obsL) <- 's2dv_cube' region <- c(min(lon), max(lon), min(lat), max(lat)) downscaled_field <- CST_Analogs(expL = expL, obsL = obsL, region = region) diff --git a/man/CST_Anomaly.Rd b/man/CST_Anomaly.Rd index cbd665b3be6581c47af9df9b7b8e0c2ca9e9c74c..5ad20a47a6a13fd889c0934b3293c85f57f1b5fa 100644 --- a/man/CST_Anomaly.Rd +++ b/man/CST_Anomaly.Rd @@ -68,15 +68,15 @@ computation is carried out independently for experimental and observational data products. } \examples{ -# Example 1: mod <- 1 : (2 * 3 * 4 * 5 * 6 * 7) dim(mod) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) obs <- 1 : (1 * 1 * 4 * 5 * 6 * 7) dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod, lat = lat, lon = lon) -obs <- list(data = obs, lat = lat, lon = lon) +coords <- list(lon = lon, lat = lat) +exp <- list(data = mod, coords = coords) +obs <- list(data = obs, coords = coords) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' diff --git a/man/CST_BEI_Weighting.Rd b/man/CST_BEI_Weighting.Rd index 89fb4f6e3862c8b3d953e6b65f3bb2c6624a36b6..749d2f612de72d29fefd01b05e1e39d8b91eb2e5 100644 --- a/man/CST_BEI_Weighting.Rd +++ b/man/CST_BEI_Weighting.Rd @@ -9,7 +9,8 @@ CST_BEI_Weighting( aweights, terciles = NULL, type = "ensembleMean", - time_dim_name = "time" + time_dim_name = "time", + memb_dim = "member" ) } \arguments{ @@ -45,6 +46,9 @@ means computing with weighted members.} \item{time_dim_name}{A character string indicating the name of the temporal dimension, by default 'time'.} + +\item{memb_dim}{A character string indicating the name of the +member dimension, by default 'member'.} } \value{ CST_BEI_Weighting() returns a CSTools object (i.e., of the @@ -69,9 +73,6 @@ dim(aweights) <- c(time = 2, member = 4, dataset = 2) var_exp <- list(data = var_exp) class(var_exp) <- 's2dv_cube' res_CST <- CST_BEI_Weighting(var_exp, aweights) -dim(res_CST$data) -# time lat lon dataset -# 2 3 2 2 } \references{ Regionally improved seasonal forecast of precipitation through diff --git a/man/CST_BiasCorrection.Rd b/man/CST_BiasCorrection.Rd index 48c593d00fc96caea8e8d50da236d99e66062c58..be2b2aed73d48af400ef2c175c02d84ac2278cb1 100644 --- a/man/CST_BiasCorrection.Rd +++ b/man/CST_BiasCorrection.Rd @@ -68,8 +68,9 @@ obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod1, lat = lat, lon = lon) -obs <- list(data = obs1, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +exp <- list(data = mod1, coords = coords) +obs <- list(data = obs1, coords = coords) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' a <- CST_BiasCorrection(exp = exp, obs = obs) diff --git a/man/CST_Calibration.Rd b/man/CST_Calibration.Rd index 2e8861e78fe5b6d9e8e9d5d0c1bdd1982ff87bee..07226a1e3fbe56520e06f3c0982bdc677bde9023 100644 --- a/man/CST_Calibration.Rd +++ b/man/CST_Calibration.Rd @@ -135,8 +135,9 @@ obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod1, lat = lat, lon = lon) -obs <- list(data = obs1, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +exp <- list(data = mod1, coords = coords) +obs <- list(data = obs1, coords = coords) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' a <- CST_Calibration(exp = exp, obs = obs, cal.method = "mse_min", eval.method = "in-sample") @@ -150,8 +151,9 @@ obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod1, lat = lat, lon = lon) -obs <- list(data = obs1, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +exp <- list(data = mod1, coords = coords) +obs <- list(data = obs1, coords = coords) exp_cor <- list(data = mod2, lat = lat, lon = lon) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' diff --git a/man/CST_CategoricalEnsCombination.Rd b/man/CST_CategoricalEnsCombination.Rd index 9ef28f43b6e9ffc09a1f163ee8d0ca70ac712be1..85ebb7f8f00c0c393418d341af002cfee464a726 100644 --- a/man/CST_CategoricalEnsCombination.Rd +++ b/man/CST_CategoricalEnsCombination.Rd @@ -87,21 +87,22 @@ the weights by minimizing the ignorance score. Finally, the function can also be used to categorize the observations in the categorical quantiles. } \examples{ - mod1 <- 1 : (2 * 2* 4 * 5 * 2 * 2) dim(mod1) <- c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, lon = 2) mod1[2, 1, , , , ] <- NA -dimnames(mod1)[[1]] <- c("MF", "UKMO") +datasets <- c("MF", "UKMO") obs1 <- 1 : (1 * 1 * 4 * 5 * 2 * 2) dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, lon = 2) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod1, lat = lat, lon = lon) -obs <- list(data = obs1, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +attrs <- list(Datasets = datasets) +exp <- list(data = mod1, coords = coords, attrs = attrs) +obs <- list(data = obs1, coords = coords) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' -a <- CST_CategoricalEnsCombination(exp = exp, obs = obs, amt.cat = 3, cat.method = "mmw") - +a <- CST_CategoricalEnsCombination(exp = exp, obs = obs, amt.cat = 3, + cat.method = "mmw") } \references{ Rajagopalan, B., Lall, U., & Zebiak, S. E. (2002). Categorical diff --git a/man/CST_DynBiasCorrection.Rd b/man/CST_DynBiasCorrection.Rd index f9eb3c9ec67329d1215c98ddafa2aa27d434d89b..0f3a1ab28683708fdea1a6978c3d5fc529082b20 100644 --- a/man/CST_DynBiasCorrection.Rd +++ b/man/CST_DynBiasCorrection.Rd @@ -52,36 +52,36 @@ values with lower 'dim', and the same for theta. The function gives two options of bias correction: one for 'dim' and/or one for 'theta' } \examples{ -# example 1: simple data s2dvcube style -set.seed(1) expL <- rnorm(1:2000) -dim (expL) <- c(time =100,lat = 4, lon = 5) -obsL <- c(rnorm(1:1980),expL[1,,]*1.2) -dim (obsL) <- c(time = 100,lat = 4, lon = 5) -time_obsL <- paste(rep("01", 100), rep("01", 100), 1920 : 2019, sep = "-") -time_expL <- paste(rep("01", 100), rep("01", 100), 1929 : 2019, sep = "-") -lon <- seq(-1,5,1.5) -lat <- seq(30,35,1.5) -# qm=0.98 # too high for this short dataset, it is possible that doesn't +dim(expL) <- c(time = 100, lat = 4, lon = 5) +obsL <- c(rnorm(1:1980), expL[1, , ] * 1.2) +dim(obsL) <- c(time = 100, lat = 4, lon = 5) +time_obsL <- as.POSIXct(paste(rep("01", 100), rep("01", 100), 1920:2019, sep = "-"), + format = "\%d-\%m-\%y") +time_expL <- as.POSIXct(paste(rep("01", 100), rep("01", 100), 1929:2019, sep = "-"), + format = "\%d-\%m-\%y") +lon <- seq(-1, 5, 1.5) +lat <- seq(30, 35, 1.5) +# qm = 0.98 #'too high for this short dataset, it is possible that doesn't # get the requirement, in that case it would be necessary select a lower qm -# for instance qm=0.60 -expL <- s2dv_cube(data = expL, lat = lat, lon = lon, - Dates = list(start = time_expL, end = time_expL)) -obsL <- s2dv_cube(data = obsL, lat = lat, lon = lon, - Dates = list(start = time_obsL, end = time_obsL)) +# for instance qm = 0.60 +expL <- s2dv_cube(data = expL, coords = list(lon = lon, lat = lat), + Dates = time_expL) +obsL <- s2dv_cube(data = obsL, coords = list(lon = lon, lat = lat), + Dates = time_obsL) # to use DynBiasCorrection dynbias1 <- DynBiasCorrection(exp = expL$data, obs = obsL$data, proxy= "dim", - quanti = 0.6) + quanti = 0.6) # to use CST_DynBiasCorrection dynbias2 <- CST_DynBiasCorrection(exp = expL, obs = obsL, proxy= "dim", - quanti = 0.6) + quanti = 0.6) } \references{ Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and Yiou, P. (2019). The hammam effect or how a warm ocean enhances large scale atmospheric predictability.Nature Communications, 10(1), 1316. -DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " +DOI = \doi{10.1038/s41467-019-09305-8} " Faranda, D., Gabriele Messori and Pascal Yiou. (2017). Dynamical proxies of North Atlantic predictability and extremes. diff --git a/man/CST_EnsClustering.Rd b/man/CST_EnsClustering.Rd index 28a094fff6cfb2993593f713d8da1b8a4c316fb2..7b1dd6cf4a71ebda8404e98fa93ce1c3d939e49b 100644 --- a/man/CST_EnsClustering.Rd +++ b/man/CST_EnsClustering.Rd @@ -20,9 +20,10 @@ CST_EnsClustering( } \arguments{ \item{exp}{An object of the class 's2dv_cube', containing the variables to be -analysed. Each data object in the list is expected to have an element named -\code{$data} with at least two spatial dimensions named "lon" and "lat", and -dimensions "dataset", "member", "ftime", "sdate".} +analysed. The element 'data' in the 's2dv_cube' object must have, at +least, spatial and temporal dimensions. Latitudinal dimension accepted +names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. Longitudinal +dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 'nav_lon'.} \item{time_moment}{Decides the moment to be applied to the time dimension. Can be either 'mean' (time mean), 'sd' (standard deviation along time) or 'perc' @@ -109,11 +110,15 @@ centroid (i.e. the closest and the furthest member), the intra-cluster standard deviation for each cluster (i.e. how much the cluster is compact). } \examples{ -exp <- lonlat_temp$exp -exp$data <- ClimProjDiags::Subset(exp$data, along = c('member', 'lat'), list(1:2, 1:7)) -exp$lat <- exp$lat[1:7] -# Example 1: Cluster on all start dates, members and models -res <- CST_EnsClustering(exp, numclus = 3, +dat_exp <- array(abs(rnorm(1152))*275, dim = c(dataset = 1, member = 4, + sdate = 6, ftime = 3, + lat = 4, lon = 4)) +lon <- seq(0, 3) +lat <- seq(48, 45) +coords <- list(lon = lon, lat = lat) +exp <- list(data = dat_exp, coords = coords) +attr(exp, 'class') <- 's2dv_cube' +res <- CST_EnsClustering(exp = exp, numclus = 3, cluster_dim = c("sdate")) } diff --git a/man/CST_MergeDims.Rd b/man/CST_MergeDims.Rd index aaa04ba52d3d08cad71335c87b8f193484dc1251..5f9b4d1301a4bdf34ecdcddffae5015ce7df81b9 100644 --- a/man/CST_MergeDims.Rd +++ b/man/CST_MergeDims.Rd @@ -35,14 +35,11 @@ dim(data) <- c(time = 7, lat = 2, lon = 3, monthly = 4, member = 6, dataset = 5, var = 1) data[2,,,,,,] <- NA data[c(3,27)] <- NA -data <-list(data = data) +data <- list(data = data) class(data) <- 's2dv_cube' new_data <- CST_MergeDims(data, merge_dims = c('time', 'monthly')) -dim(new_data$data) new_data <- CST_MergeDims(data, merge_dims = c('lon', 'lat'), rename_dim = 'grid') -dim(new_data$data) new_data <- CST_MergeDims(data, merge_dims = c('time', 'monthly'), na.rm = TRUE) -dim(new_data$data) } \author{ Nuria Perez-Zanon, \email{nuria.perez@bsc.es} diff --git a/man/CST_MultiEOF.Rd b/man/CST_MultiEOF.Rd index dcafcc414e3e42ac7ca70b56bf06903efd99bacf..11f8877fa0ada4c68692da0052eba93ad1567bdc 100644 --- a/man/CST_MultiEOF.Rd +++ b/man/CST_MultiEOF.Rd @@ -17,7 +17,10 @@ CST_MultiEOF( \item{datalist}{A list of objects of the class 's2dv_cube', containing the variables to be analysed. Each data object in the list is expected to have an element named \code{$data} with at least two spatial dimensions named -"lon" and "lat", a dimension "ftime" and a dimension "sdate".} +"lon" and "lat", a dimension "ftime" and a dimension "sdate". Latitudinal +dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. +Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', +'nav_lon'.} \item{neof_max}{Maximum number of single eofs considered in the first decomposition.} @@ -47,19 +50,28 @@ components needed to reach the user-defined variance is retained. The function weights the input data for the latitude cosine square root. } \examples{ -exp <- lonlat_temp$exp -exp$data <- ClimProjDiags::Subset(exp$data, along = c('lat', 'lon'), list(1:4, 1:4)) -exp$lat <- exp$lat[1:4] -exp$lon <- exp$lon[1:4] +seq <- 1 : (2 * 3 * 4 * 5 * 6 * 8) +mod1 <- sin( 0.7 + seq )^2 + cos( seq ^ 2 * 1.22 ) +dim(mod1) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, + lon = 8) +mod2 <- sin( seq * 2 ) ^ 3 + cos( seq ^ 2 ) +dim(mod2) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, + lon = 8) +lon <- seq(0, 35, 5) +lat <- seq(0, 25, 5) +exp1 <- list(data = mod1, coords = list(lat = lat, lon = lon)) +exp2 <- list(data = mod2, coords = list(lat = lat, lon = lon)) +attr(exp1, 'class') <- 's2dv_cube' +attr(exp2, 'class') <- 's2dv_cube' +d = as.POSIXct(c("2017/01/01", "2017/01/02", "2017/01/03", "2017/01/04", + "2017/01/05", "2018/01/01", "2018/01/02", "2018/01/03", + "2018/01/04", "2018/01/05", "2019/01/01", "2019/01/02", + "2019/01/03", "2019/01/04", "2019/01/05", "2020/01/01", + "2020/01/02", "2020/01/03", "2020/01/04", "2020/01/05")) +exp1$attrs$Dates = d +exp2$attrs$Dates = d -# Create three datasets (from the members) -exp1 <- exp -exp2 <- exp - -exp1$data <- ClimProjDiags::Subset(exp$data, along = 2, indices = 1:5) -exp2$data <- ClimProjDiags::Subset(exp$data, along = 2, indices = 6:10) - -cal <- CST_MultiEOF(list(exp1, exp2) , minvar = 0.9) +cal <- CST_MultiEOF(datalist = list(exp1, exp2), neof_composed = 2) } \author{ Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it} diff --git a/man/CST_MultiMetric.Rd b/man/CST_MultiMetric.Rd index f348aab2022d120005594b8fff5c8583018d13ff..3489fab391c36503aeafc003b0078988425836f0 100644 --- a/man/CST_MultiMetric.Rd +++ b/man/CST_MultiMetric.Rd @@ -55,14 +55,15 @@ skill score (RMSSS) of individual anomaly models and multi-models mean (if desired) with the observations. } \examples{ -mod <- rnorm(2 * 2 * 4 * 5 * 2 * 2) +mod <- rnorm(2*2*4*5*2*2) dim(mod) <- c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, lon = 2) -obs <- rnorm(1 * 1 * 4 * 5 * 2 * 2) +obs <- rnorm(1*1*4*5*2*2) dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, lon = 2) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod, lat = lat, lon = lon) -obs <- list(data = obs, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +exp <- list(data = mod, coords = coords) +obs <- list(data = obs, coords = coords) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' a <- CST_MultiMetric(exp = exp, obs = obs) diff --git a/man/CST_MultivarRMSE.Rd b/man/CST_MultivarRMSE.Rd index e6de57a4677803444131ccb17e2d1dae2f2833af..6fa8d1b5c377097d1263d2ddb5f8cd417fbcbddb 100644 --- a/man/CST_MultivarRMSE.Rd +++ b/man/CST_MultivarRMSE.Rd @@ -4,7 +4,15 @@ \alias{CST_MultivarRMSE} \title{Multivariate Root Mean Square Error (RMSE)} \usage{ -CST_MultivarRMSE(exp, obs, weight = NULL) +CST_MultivarRMSE( + exp, + obs, + weight = NULL, + memb_dim = "member", + dat_dim = "dataset", + sdate_dim = "sdate", + ftime_dim = "ftime" +) } \arguments{ \item{exp}{A list of objects, one for each variable, of class \code{s2dv_cube} @@ -18,6 +26,22 @@ element named \code{$data}.} \item{weight}{(optional) A vector of weight values to assign to each variable. If no weights are defined, a value of 1 is assigned to every variable.} + +\item{memb_dim}{A character string indicating the name of the member +dimension. It must be one dimension in 'exp' and 'obs'. The default value is +'member'.} + +\item{dat_dim}{A character string indicating the name of the dataset +dimension. It must be one dimension in 'exp' and 'obs'. If there is no +dataset dimension, it can be NULL. The default value is 'dataset'.} + +\item{sdate_dim}{A character string indicating the name of the start date +dimension. It must be one dimension in 'exp' and 'obs'. The default value is +'sdate'.} + +\item{ftime_dim}{A character string indicating the name of the forecast time +dimension. It must be one dimension in 'exp' and 'obs'. The default value is +'ftime'.} } \value{ An object of class \code{s2dv_cube} containing the RMSE in the element @@ -33,41 +57,39 @@ Variables can be weighted based on their relative importance (defined by the user). } \examples{ -# Creation of sample s2dv objects. These are not complete s2dv objects -# though. The Load function returns complete objects. -# using package zeallot is optional: -library(zeallot) # Example with 2 variables -mod1 <- 1 : (1 * 3 * 4 * 5 * 6 * 7) -mod2 <- 1 : (1 * 3 * 4 * 5 * 6 * 7) +mod1 <- abs(rnorm(1 * 3 * 4 * 5 * 6 * 7)) +mod2 <- abs(rnorm(1 * 3 * 4 * 5 * 6 * 7)) dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) dim(mod2) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) -obs1 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) -obs2 <- 1 : (1 * 1 * 4 * 5 * 6 * 7) +obs1 <- abs(rnorm(1 * 1 * 4 * 5 * 6 * 7)) +obs2 <- abs(rnorm(1 * 1 * 4 * 5 * 6 * 7)) dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) dim(obs2) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp1 <- list(data = mod1, lat = lat, lon = lon, Datasets = "EXP1", - source_files = "file1", Variable = list('pre')) +coords <- list(lat = lat, lon = lon) +exp1 <- list(data = mod1, coords = coords, + attrs = list(Datasets = "EXP1", source_files = "file1", + Variable = list(varName = 'pre'))) +exp2 <- list(data = mod2, coords = coords, + attrs = list(Datasets = "EXP2", source_files = "file2", + Variable = list(varName = 'tas'))) +obs1 <- list(data = obs1, coords = coords, + attrs = list(Datasets = "OBS1", source_files = "file1", + Variable = list(varName = 'pre'))) +obs2 <- list(data = obs2, coords = coords, + attrs = list(Datasets = "OBS2", source_files = "file2", + Variable = list(varName = 'tas'))) attr(exp1, 'class') <- 's2dv_cube' -exp2 <- list(data = mod2, lat = lat, lon = lon, Datasets = "EXP2", - source_files = "file2", Variable = list('tas')) attr(exp2, 'class') <- 's2dv_cube' -obs1 <- list(data = obs1, lat = lat, lon = lon, Datasets = "OBS1", - source_files = "file1", Variable = list('pre')) attr(obs1, 'class') <- 's2dv_cube' -obs2 <- list(data = obs2, lat = lat, lon = lon, Datasets = "OBS2", - source_files = "file2", Variable = list('tas')) attr(obs2, 'class') <- 's2dv_cube' - -c(ano_exp1, ano_obs1) \%<-\% CST_Anomaly(exp1, obs1, cross = TRUE, memb = TRUE) -c(ano_exp2, ano_obs2) \%<-\% CST_Anomaly(exp2, obs2, cross = TRUE, memb = TRUE) -ano_exp <- list(exp1, exp2) -ano_obs <- list(ano_obs1, ano_obs2) -weight <- c(1, 2) -a <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight = weight) -str(a) +anom1 <- CST_Anomaly(exp1, obs1, cross = TRUE, memb = TRUE) +anom2 <- CST_Anomaly(exp2, obs2, cross = TRUE, memb = TRUE) +ano_exp <- list(anom1$exp, anom2$exp) +ano_obs <- list(anom1$obs, anom2$obs) +a <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight = c(1, 2)) } \seealso{ \code{\link[s2dv]{RMS}} and \code{\link{CST_Load}} diff --git a/man/CST_ProxiesAttractor.Rd b/man/CST_ProxiesAttractor.Rd index ed21b11f4c34ff19982a8615792252be92f4cf78..45f4753a7f4504a8d6b6d05f0780baf6177dacf5 100644 --- a/man/CST_ProxiesAttractor.Rd +++ b/man/CST_ProxiesAttractor.Rd @@ -33,15 +33,16 @@ obs <- rnorm(2 * 3 * 4 * 8 * 8) dim(obs) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) lon <- seq(10, 13.5, 0.5) lat <- seq(40, 43.5, 0.5) -data <- list(data = obs, lon = lon, lat = lat) +coords <- list(lon = lon, lat = lat) +data <- list(data = obs, coords = coords) class(data) <- "s2dv_cube" attractor <- CST_ProxiesAttractor(data = data, quanti = 0.6) - } \references{ -Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and Yiou, P. (2019). -The hammam effect or how a warm ocean enhances large scale atmospheric predictability. -Nature Communications, 10(1), 1316. DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " +Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., +and Yiou, P. (2019). The hammam effect or how a warm ocean enhances large +scale atmospheric predictability. Nature Communications, 10(1), 1316. +DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " Faranda, D., Gabriele Messori and Pascal Yiou. (2017). Dynamical proxies of North Atlantic predictability and extremes. diff --git a/man/CST_QuantileMapping.Rd b/man/CST_QuantileMapping.Rd index 3c0deac4b8c2925a3270ed7352533a520735e554..fc77d3bfac261bf56994330a8045a3a934e284ad 100644 --- a/man/CST_QuantileMapping.Rd +++ b/man/CST_QuantileMapping.Rd @@ -74,20 +74,6 @@ dim(obs$data) <- c(dataset = 1, member = 1, sdate = 5, ftime = 4, class(obs) <- 's2dv_cube' res <- CST_QuantileMapping(exp, obs) -exp <- lonlat_temp$exp -exp$data <- exp$data[, , 1:4, , 1:2, 1:3] -dim(exp$data) <- c(dataset = 1, member = 15, sdate = 4, ftime = 3, - lat = 2, lon = 3) -obs <- lonlat_temp$obs -obs$data <- obs$data[, , 1:4, , 1:2, 1:3] -dim(obs$data) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, - lat = 2, lon = 3) -exp_cor <- lonlat_temp$exp -exp_cor$data <- exp_cor$data[, 1, 5:6, , 1:2, 1:3] -dim(exp_cor$data) <- c(dataset = 1, member = 1, sdate = 2, ftime = 3, - lat = 2, lon = 3) -res <- CST_QuantileMapping(exp, obs, exp_cor, window_dim = 'ftime') - } \seealso{ \code{\link[qmap]{fitQmap}} and \code{\link[qmap]{doQmap}} diff --git a/man/CST_RFSlope.Rd b/man/CST_RFSlope.Rd index ab30d81eaa577b174360e0b06447a554abcbbdda..3eeb1a0f3a4fc98d93fe2aa13d74491d91dc5095 100644 --- a/man/CST_RFSlope.Rd +++ b/man/CST_RFSlope.Rd @@ -4,7 +4,7 @@ \alias{CST_RFSlope} \title{RainFARM spectral slopes from a CSTools object} \usage{ -CST_RFSlope(data, kmin = 1, time_dim = NULL, ncores = 1) +CST_RFSlope(data, kmin = 1, time_dim = NULL, ncores = NULL) } \arguments{ \item{data}{An object of the class 's2dv_cube', containing the spatial @@ -38,22 +38,14 @@ object to be used for RainFARM stochastic precipitation downscaling method and accepts a CSTools object (of the class 's2dv_cube') as input. } \examples{ -#Example using CST_RFSlope for a CSTools object exp <- 1 : (2 * 3 * 4 * 8 * 8) dim(exp) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) lon <- seq(10, 13.5, 0.5) -dim(lon) <- c(lon = length(lon)) lat <- seq(40, 43.5, 0.5) -dim(lat) <- c(lat = length(lat)) -data <- list(data = exp, lon = lon, lat = lat) +coords <- list(lon = lon, lat = lat) +data <- list(data = exp, coords = coords) +class(data) <- 's2dv_cube' slopes <- CST_RFSlope(data) -dim(slopes) -# dataset member sdate -# 1 2 3 -slopes -# [,1] [,2] [,3] -#[1,] 1.893503 1.893503 1.893503 -#[2,] 1.893503 1.893503 1.893503 } \author{ Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it} diff --git a/man/CST_RFTemp.Rd b/man/CST_RFTemp.Rd index 19a3c0185787b46a3319e7c5949713f35092e70a..4f5d535419798c281fc5ab309358c737df46e863 100644 --- a/man/CST_RFTemp.Rd +++ b/man/CST_RFTemp.Rd @@ -85,15 +85,19 @@ t <- rnorm(7 * 6 * 2 * 3 * 4)*10 + 273.15 + 10 dim(t) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 6, lon = 7) lon <- seq(3, 9, 1) lat <- seq(42, 47, 1) -exp <- list(data = t, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +exp <- list(data = t, coords = coords) attr(exp, 'class') <- 's2dv_cube' o <- runif(29*29)*3000 -dim(o) <- c(lat = 29, lon = 29) +dim(o) <- c(lats = 29, lons = 29) lon <- seq(3, 10, 0.25) lat <- seq(41, 48, 0.25) -oro <- list(data = o, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +oro <- list(data = o, coords = coords) attr(oro, 'class') <- 's2dv_cube' -res <- CST_RFTemp(exp, oro, xlim=c(4,8), ylim=c(43, 46), lapse=6.5) +res <- CST_RFTemp(data = exp, oro = oro, xlim = c(4,8), ylim = c(43, 46), + lapse = 6.5, time_dim = 'ftime', + lon_dim = 'lon', lat_dim = 'lat') } \references{ Method described in ERA4CS MEDSCOPE milestone M3.2: diff --git a/man/CST_RFWeights.Rd b/man/CST_RFWeights.Rd index 3b8e9fa7b83f78565e40763015a6431c6d1561ea..54926f5f06fe437e3711bd9703761967f9d70df1 100644 --- a/man/CST_RFWeights.Rd +++ b/man/CST_RFWeights.Rd @@ -63,15 +63,16 @@ precipitation climatology file. } \examples{ # Create weights to be used with the CST_RainFARM() or RainFARM() functions -# using an external fine-scale climatology file. - -\dontrun{ -# Specify lon and lat of the input -lon <- seq(10,13.5,0.5) -lat <- seq(40,43.5,0.5) -nf <- 8 -ww <- CST_RFWeights("./worldclim.nc", nf, lon, lat, fsmooth = TRUE) -} +# using an external random data in the form of 's2dv_cube'. +obs <- rnorm(2 * 3 * 4 * 8 * 8) +dim(obs) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) +lon <- seq(10, 13.5, 0.5) +lat <- seq(40, 43.5, 0.5) +coords <- list(lon = lon, lat = lat) +data <- list(data = obs, coords = coords) +class(data) <- "s2dv_cube" +res <- CST_RFWeights(climfile = data, nf = 3, lon, lat, lonname = 'lon', + latname = 'lat', fsmooth = TRUE) } \references{ Terzago, S., Palazzi, E., & von Hardenberg, J. (2018). diff --git a/man/CST_RainFARM.Rd b/man/CST_RainFARM.Rd index 18c474276f2bc1ef41db6e124f0571f068a5479b..942e584ab05308602054acef61ca71a96a60e837 100644 --- a/man/CST_RainFARM.Rd +++ b/man/CST_RainFARM.Rd @@ -103,13 +103,13 @@ nf <- 8 # Choose a downscaling by factor 8 exp <- 1 : (2 * 3 * 4 * 8 * 8) dim(exp) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) lon <- seq(10, 13.5, 0.5) -dim(lon) <- c(lon = length(lon)) lat <- seq(40, 43.5, 0.5) -dim(lat) <- c(lat = length(lat)) -data <- list(data = exp, lon = lon, lat = lat) +coords <- list(lon = lon, lat = lat) +data <- list(data = exp, coords = coords) +class(data) <- 's2dv_cube' # Create a test array of weights ww <- array(1., dim = c(lon = 8 * nf, lat = 8 * nf)) -res <- CST_RainFARM(data, nf = nf, weights = ww, nens = 3) +res <- CST_RainFARM(data, nf = nf, weights = ww, nens = 3, time_dim = 'ftime') } \references{ Terzago, S. et al. (2018). NHESS 18(11), 2825-2840. diff --git a/man/CST_RegimesAssign.Rd b/man/CST_RegimesAssign.Rd index 123799b16cdd4b4c04b37617c6a2a127d76eba47..2fec7426ca2c259211199ea49c751b8ea5745ec8 100644 --- a/man/CST_RegimesAssign.Rd +++ b/man/CST_RegimesAssign.Rd @@ -50,18 +50,20 @@ percentage of assignations corresponding to each map.). This function performs the matching between a field of anomalies and a set of maps which will be used as a reference. The anomalies will be assigned to the reference map for which the minimum Eucledian distance -(method=’distance’) or highest spatial correlation (method = 'ACC') is +(method =’distance’) or highest spatial correlation (method = 'ACC') is obtained. } \examples{ -\dontrun{ -regimes <- CST_WeatherRegimes(data = lonlat_temp$obs, EOFs = FALSE, +data <- array(abs(rnorm(1280, 282.7, 6.4)), dim = c(dataset = 2, member = 2, + sdate = 3, ftime = 3, + lat = 4, lon = 4)) +coords <- list(lon = seq(0, 3), lat = seq(47, 44)) +exp <- list(data = data, coords = coords) +class(exp) <- 's2dv_cube' +regimes <- CST_WeatherRegimes(data = exp, EOFs = FALSE, ncenters = 4) -res1 <- CST_RegimesAssign(data = lonlat_temp$exp, ref_maps = regimes, +res1 <- CST_RegimesAssign(data = exp, ref_maps = regimes, composite = FALSE) -res2 <- CST_RegimesAssign(data = lonlat_temp$exp, ref_maps = regimes, - composite = TRUE) -} } \references{ Torralba, V. (2019) Seasonal climate prediction for the wind diff --git a/man/CST_SaveExp.Rd b/man/CST_SaveExp.Rd index 8c8ada305053496a1e0ae6e396c74b772f4fb52a..067bbae9af11b1135a79c915b451f53b44b686cf 100644 --- a/man/CST_SaveExp.Rd +++ b/man/CST_SaveExp.Rd @@ -2,10 +2,19 @@ % Please edit documentation in R/CST_SaveExp.R \name{CST_SaveExp} \alias{CST_SaveExp} -\title{Save CSTools objects of class 's2dv_cube' containing experiments or observed -data in NetCDF format} +\title{Save objects of class 's2dv_cube' to data in NetCDF format} \usage{ -CST_SaveExp(data, destination = "./CST_Data", extra_string = NULL) +CST_SaveExp( + data, + destination = "./", + sdate_dim = "sdate", + ftime_dim = "time", + dat_dim = "dataset", + var_dim = "var", + memb_dim = "member", + single_file = FALSE, + extra_string = NULL +) } \arguments{ \item{data}{An object of class \code{s2dv_cube}.} @@ -13,30 +22,67 @@ CST_SaveExp(data, destination = "./CST_Data", extra_string = NULL) \item{destination}{A character string containing the directory name in which to save the data. NetCDF file for each starting date are saved into the folder tree: \cr -destination/experiment/variable/. By default the function -creates and saves the data into the folder "CST_Data" in the working -directory.} +destination/Dataset/variable/. By default the function +creates and saves the data into the working directory.} + +\item{sdate_dim}{A character string indicating the name of the start date +dimension. By default, it is set to 'sdate'. It can be NULL if there is no +start date dimension.} + +\item{ftime_dim}{A character string indicating the name of the forecast time +dimension. By default, it is set to 'time'. It can be NULL if there is no +forecast time dimension.} + +\item{dat_dim}{A character string indicating the name of dataset dimension. +By default, it is set to 'dataset'. It can be NULL if there is no dataset +dimension.} + +\item{var_dim}{A character string indicating the name of variable dimension. +By default, it is set to 'var'. It can be NULL if there is no variable +dimension.} + +\item{memb_dim}{A character string indicating the name of the member dimension. +By default, it is set to 'member'. It can be NULL if there is no member +dimension.} + +\item{single_file}{A logical value indicating if all object is saved in a +single file (TRUE) or in multiple files (FALSE). When it is FALSE, +the array is separated for Datasets, variable and start date. It is FALSE +by default.} \item{extra_string}{A character string to be include as part of the file name, for instance, to identify member or realization. It would be added to the file name between underscore characters.} } +\value{ +If single_file is TRUE only one file is created. If single_file is +FALSE multiple files are created. When multiple files are created, each file +contains the data subset for each start date, variable and dataset. Files +with different variables and Datasets are stored in separated directories. +The path will be created with the name of the variable and each start date. +NetCDF file for each starting date are saved into the + folder tree: \cr + destination/Dataset/variable/. +} \description{ This function allows to divide and save a object of class 's2dv_cube' into a NetCDF file, allowing to reload the saved data using -\code{CST_Load} function. +\code{Start} function from StartR package. If the original 's2dv_cube' object +has been created from \code{CST_Load()}, then it can be reloaded with +\code{Load()}. } \examples{ \dontrun{ -library(CSTools) data <- lonlat_temp$exp -destination <- "./path2/" -CST_SaveExp(data = data, destination = destination) +destination <- "./" +CST_SaveExp(data = data, destination = destination, ftime_dim = 'ftime', + var_dim = NULL, ftime_dim = 'ftime', var_dim = NULL) } } \seealso{ -\code{\link{CST_Load}}, \code{\link{as.s2dv_cube}} and \code{\link{s2dv_cube}} +\code{\link[startR]{Start}}, \code{\link{as.s2dv_cube}} and +\code{\link{s2dv_cube}} } \author{ Perez-Zanon Nuria, \email{nuria.perez@bsc.es} diff --git a/man/CST_SplitDim.Rd b/man/CST_SplitDim.Rd index 9c23a38467fff510943d1427f35e889e50ba7f56..b07d9897ceac08db2b876ffa67d30322c87d34b5 100644 --- a/man/CST_SplitDim.Rd +++ b/man/CST_SplitDim.Rd @@ -27,7 +27,8 @@ dates provided in the s2dv_cube object (element Dates) will be used.} independently of the year they belong to, while 'monthly' differenciates months from different years.} -\item{new_dim_name}{A character string indicating the name of the new dimension.} +\item{new_dim_name}{A character string indicating the name of the new +dimension.} \item{insert_ftime}{An integer indicating the number of time steps to add at the begining of the time series.} @@ -36,7 +37,8 @@ the begining of the time series.} This function split a dimension in two. The user can select the dimension to split and provide indices indicating how to split that dimension or dates and the frequency expected (monthly or by day, month and year). The -user can also provide a numeric frequency indicating the length of each division. +user can also provide a numeric frequency indicating the length of each +division. } \details{ Parameter 'insert_ftime' has been included for the case of using @@ -52,7 +54,6 @@ while from positon 2 to 30 will be filled with the data provided. This allows to select correctly days trhough time dimension. } \examples{ - data <- 1 : 20 dim(data) <- c(time = 10, lat = 2) data <-list(data = data) @@ -65,13 +66,9 @@ time <- c(seq(ISOdate(1903, 1, 1), ISOdate(1903, 1, 4), "days"), data <- list(data = data$data, Dates = time) class(data) <- 's2dv_cube' new_data <- CST_SplitDim(data, indices = time) -dim(new_data$data) new_data <- CST_SplitDim(data, indices = time, freq = 'day') -dim(new_data$data) new_data <- CST_SplitDim(data, indices = time, freq = 'month') -dim(new_data$data) new_data <- CST_SplitDim(data, indices = time, freq = 'year') -dim(new_data$data) } \author{ Nuria Perez-Zanon, \email{nuria.perez@bsc.es} diff --git a/man/CST_WeatherRegimes.Rd b/man/CST_WeatherRegimes.Rd index 388affbc26f63e4ae4a2488b3db7faeda7f8a132..220b0aca368710bcc31069b8f01af97c05e0a6a1 100644 --- a/man/CST_WeatherRegimes.Rd +++ b/man/CST_WeatherRegimes.Rd @@ -17,7 +17,7 @@ CST_WeatherRegimes( ) } \arguments{ -\item{data}{An 's2dv_cube' object} +\item{data}{An 's2dv_cube' object.} \item{ncenters}{Number of clusters to be calculated with the clustering function.} @@ -69,10 +69,16 @@ analysis can be performed with the traditional k-means or those methods included in the hclust (stats package). } \examples{ -\dontrun{ -res1 <- CST_WeatherRegimes(data = lonlat_temp$obs, EOFs = FALSE, ncenters = 4) -res2 <- CST_WeatherRegimes(data = lonlat_temp$obs, EOFs = TRUE, ncenters = 3) -} +data <- array(abs(rnorm(1280, 283.7, 6)), dim = c(dataset = 2, member = 2, + sdate = 3, ftime = 3, + lat = 4, lon = 4)) +coords <- list(lon = seq(0, 3), lat = seq(47, 44)) +obs <- list(data = data, coords = coords) +class(obs) <- 's2dv_cube' + +res1 <- CST_WeatherRegimes(data = obs, EOFs = FALSE, ncenters = 4) +res2 <- CST_WeatherRegimes(data = obs, EOFs = TRUE, ncenters = 3) + } \references{ Cortesi, N., V., Torralba, N., González-Reviriego, A., Soret, and diff --git a/man/EnsClustering.Rd b/man/EnsClustering.Rd index f7b73266740bb24ee00245170972dda850ebc312..17915b3f2b258637b08c6e25e941fc803076e5d2 100644 --- a/man/EnsClustering.Rd +++ b/man/EnsClustering.Rd @@ -22,7 +22,9 @@ EnsClustering( } \arguments{ \item{data}{A matrix of dimensions 'dataset member sdate ftime lat lon' -containing the variables to be analysed.} +containing the variables to be analysed. Latitudinal dimension accepted +names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. Longitudinal +dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', 'nav_lon'.} \item{lat}{Vector of latitudes.} @@ -72,10 +74,12 @@ and returns a number of scenarios, with representative members for each of them. The clustering is performed in a reduced EOF space. } \examples{ -exp <- lonlat_temp$exp -exp$data <- ClimProjDiags::Subset(exp$data, along = c('member', 'lat'), list(1:5, 1:10)) -exp$lat <- exp$lat[1:10] -res <- EnsClustering(exp$data, exp$lat, exp$lon, numclus = 2, +exp <- array(abs(rnorm(1152))*275, dim = c(dataset = 1, member = 4, + sdate = 6, ftime = 3, + lat = 4, lon = 4)) +lon <- seq(0, 3) +lat <- seq(48, 45) +res <- EnsClustering(exp, lat = lat, lon = lon, numclus = 2, cluster_dim = c("member", "dataset", "sdate")) } diff --git a/man/MultiEOF.Rd b/man/MultiEOF.Rd index e80fbbbcad7737b3f20ac074563f3a4a23ad545e..04963e1ac27d7d68a464dc0c8bb62291a53360e1 100644 --- a/man/MultiEOF.Rd +++ b/man/MultiEOF.Rd @@ -22,7 +22,10 @@ MultiEOF( \arguments{ \item{data}{A multidimensional array with dimension \code{"var"}, containing the variables to be analysed. The other diemnsions follow the same structure -as the \code{"exp"} element of a 's2dv_cube' object.} +as the \code{"exp"} element of a 's2dv_cube' object. Latitudinal +dimension accepted names: 'lat', 'lats', 'latitude', 'y', 'j', 'nav_lat'. +Longitudinal dimension accepted names: 'lon', 'lons','longitude', 'x', 'i', +'nav_lon'.} \item{lon}{Vector of longitudes.} @@ -63,12 +66,15 @@ variance is retained. The function weights the input data for the latitude cosine square root. } \examples{ -exp <- lonlat_temp$exp -exp$data <- ClimProjDiags::Subset(exp$data, c('member', 'lat', 'lon'), list(1:5, 1:4, 1:4)) -exp$lon <- exp$lon[1:4] -exp$lat <- exp$lat[1:4] -dim(exp$data) <- c(dim(exp$data), var = 1) -cal <- MultiEOF(data = exp$data, lon = exp$lon, lat = exp$lat, time = exp$Dates$start) +exp <- array(runif(1280)*280, dim = c(dataset = 2, member = 2, sdate = 3, + ftime = 3, lat = 4, lon = 4, var = 1)) +lon <- seq(0, 3) +lat <- seq(47, 44) +dates <- c("2000-11-01", "2000-12-01", "2001-01-01", "2001-11-01", + "2001-12-01", "2002-01-01", "2002-11-01", "2002-12-01", "2003-01-01") +Dates <- as.POSIXct(dates, format = "\%Y-\%m-\%d") +dim(Dates) <- c(ftime = 3, sdate = 3) +cal <- MultiEOF(data = exp, lon = lon, lat = lat, time = Dates) } \author{ Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it} diff --git a/man/MultiMetric.Rd b/man/MultiMetric.Rd index cd26141de3d9745e4fbf7dbaa95b08b2f918c8b5..d99b073f4e3fa47ad77e176621342999a4c50e15 100644 --- a/man/MultiMetric.Rd +++ b/man/MultiMetric.Rd @@ -50,10 +50,12 @@ skill score (RMSSS) of individual anomaly models and multi-models mean (if desired) with the observations on arrays with named dimensions. } \examples{ -exp <- array(rnorm(2 *2 * 4 * 5 * 2 * 2), - dim = c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, lon = 2)) -obs <- array(rnorm(1 * 1 * 4 * 5 * 2 * 2), - c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, lon = 2)) +exp <- array(rnorm(2*2*4*5*2*2), + dim = c(dataset = 2, member = 2, sdate = 4, ftime = 5, lat = 2, + lon = 2)) +obs <- array(rnorm(1*1*4*5*2*2), + dim = c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 2, + lon = 2)) res <- MultiMetric(exp = exp, obs = obs) } \references{ diff --git a/man/PDFIndexHind.Rd b/man/PDFIndexHind.Rd new file mode 100644 index 0000000000000000000000000000000000000000..74c79911ceaa021120d12ff7b4fb19cfded13199 --- /dev/null +++ b/man/PDFIndexHind.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/BEI_PDFBest.R +\name{PDFIndexHind} +\alias{PDFIndexHind} +\title{Computing the Index PDFs for a dataset of SFSs for a hindcats period.} +\usage{ +PDFIndexHind( + index_hind, + index_obs, + method = "ME", + time_dim_name = "time", + na.rm = FALSE +) +} +\arguments{ +\item{index_hind}{Index (e.g. NAO index) array from SFSs +with at least two dimensions (time , member) or (time, statistic). +The temporal dimension, by default 'time', must be greater than 2. +The dimension 'member' must be greater than 1. +The dimension 'statistic' must be equal to 2, for containing the two +paramenters of a normal distribution (mean and sd) representing the ensemble +of a SFS. It is not possible to have the dimension 'member' and 'statistic' +together.} + +\item{index_obs}{Index (e.g. NAO index) array from an observational database +or reanalysis with at least a temporal dimension (by default 'time'), +which must be greater than 2.} + +\item{method}{A character string indicating which methodology is applied +to compute the PDFs. One of "ME" (default) or "LMEV".} + +\item{time_dim_name}{A character string indicating the name of the temporal +dimension, by default 'time'.} + +\item{na.rm}{Logical (default = FALSE). Should missing values be removed?} +} +\value{ +An array with at least two dimensions (time, statistic = 4). The firt +statistic is the parameter 'mean' of the PDF with not bias corrected. +The second statistic is the parameter 'standard deviation' of the PDF with not +bias corrected. The third statistic is the parameter 'mean' of the PDF with +bias corrected. The fourth statistic is the parameter 'standard deviation' of +the PDF with bias corrected. +} +\description{ +This function implements the computation to obtain the index PDFs +(e.g. NAO index) to improve the index estimate from SFSs for a hindcast period. +} +\examples{ +# Example for the PDFIndexHind function +# Example 1 +index_obs <- 1 : (5 * 3 ) +dim(index_obs) <- c(time = 5, season = 3) +index_hind <- 1 : (5 * 4 * 3) +dim(index_hind) <- c(time = 5, member = 4, season = 3) +res <- PDFIndexHind(index_hind, index_obs) +dim(res) +# time statistic season +# 5 4 3 +# Example 2 +index_obs <- 1 : (5 * 3) +dim(index_obs) <- c(time = 5, season = 3) +index_hind <- 1 : (5 * 2 * 3) +dim(index_hind) <- c(time = 5, statistic = 2, season = 3) +res <- PDFIndexHind(index_hind, index_obs) +} +\references{ +Regionally improved seasonal forecast of precipitation through Best +estimation of winter NAO, Sanchez-Garcia, E. et al., +Adv. Sci. Res., 16, 165174, 2019, \url{https://doi.org/10.5194/asr-16-165-2019} +} +\author{ +Eroteida Sanchez-Garcia - AEMET, \email{esanchezg@aemet.es} +} diff --git a/man/PlotMostLikelyQuantileMap.Rd b/man/PlotMostLikelyQuantileMap.Rd index c9a6ead2d6667606e5dc58216db504942c04fff6..0dde63ff0480fd076769cc77b48a14ac9ec563d2 100644 --- a/man/PlotMostLikelyQuantileMap.Rd +++ b/man/PlotMostLikelyQuantileMap.Rd @@ -150,7 +150,6 @@ PlotMostLikelyQuantileMap(bins, lons, lats, mask = 1 - (w1 + w2 / max(c(w1, w2))), brks = 20, width = 10, height = 8) } - } \seealso{ \code{PlotCombinedMap} and \code{PlotEquiMap} diff --git a/man/ProxiesAttractor.Rd b/man/ProxiesAttractor.Rd index 1cd883e30a588eea4767ef8bf1ceab104fc55aae..998a1113ed9336ed6d3ba2d543ad83b915b58d56 100644 --- a/man/ProxiesAttractor.Rd +++ b/man/ProxiesAttractor.Rd @@ -35,14 +35,14 @@ qm <- 0.90 # imposing a threshold Attractor <- ProxiesAttractor(data = mat, quanti = qm) # to plot the result time = c(1:length(Attractor$theta)) -layout(matrix(c(1, 3, 2, 3), 2, 2)) plot(time, Attractor$dim, xlab = 'time', ylab = 'd', main = 'local dimension', type = 'l') } \references{ -Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and Yiou, P. (2019). -The hammam effect or how a warm ocean enhances large scale atmospheric predictability. -Nature Communications, 10(1), 1316. DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " +Faranda, D., Alvarez-Castro, M.C., Messori, G., Rodriguez, D., and +Yiou, P. (2019). The hammam effect or how a warm ocean enhances large scale +atmospheric predictability. Nature Communications, 10(1), 1316. +DOI = \url{https://doi.org/10.1038/s41467-019-09305-8} " Faranda, D., Gabriele Messori and Pascal Yiou. (2017). Dynamical proxies of North Atlantic predictability and extremes. diff --git a/man/QuantileMapping.Rd b/man/QuantileMapping.Rd index 804a1b50a09704882a005eb65bf8806b73a43dcf..c4c29e7f47d2121b36f65d6e47cc33a20457da9f 100644 --- a/man/QuantileMapping.Rd +++ b/man/QuantileMapping.Rd @@ -73,20 +73,6 @@ dim(obs) <- c(dataset = 1, member = 1, sdate = 5, ftime = 4, lat = 3, lon = 2) res <- QuantileMapping(exp, obs) -# Use data in package -\donttest{ -exp <- lonlat_temp$exp$data[, , 1:4, , 1:2, 1:3] -dim(exp) <- c(dataset = 1, member = 15, sdate = 4, ftime = 3, - lat = 2, lon = 3) -obs <- lonlat_temp$obs$data[, , 1:4, , 1:2, 1:3] -dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 3, - lat = 2, lon = 3) -exp_cor <- lonlat_temp$exp$data[, 1, 5:6, , 1:2, 1:3] -dim(exp_cor) <- c(dataset = 1, member = 1, sdate = 2, ftime = 3, - lat = 2, lon = 3) -res <- QuantileMapping(exp, obs, exp_cor, window_dim = 'ftime') -} - } \seealso{ \code{\link[qmap]{fitQmap}} and \code{\link[qmap]{doQmap}} diff --git a/man/RFSlope.Rd b/man/RFSlope.Rd index 88bf615dee10f8be8091ced1c99d4577c08f9a57..ecbb52d115f7e9688085ab8d5a6e77b3ae3f9501 100644 --- a/man/RFSlope.Rd +++ b/man/RFSlope.Rd @@ -10,7 +10,7 @@ RFSlope( time_dim = NULL, lon_dim = "lon", lat_dim = "lat", - ncores = 1 + ncores = NULL ) } \arguments{ @@ -52,19 +52,9 @@ to be used for RainFARM stochastic precipitation downscaling method. # 3 starting dates and 20 ensemble members. pr <- 1:(4*3*8*8*20) dim(pr) <- c(ensemble = 4, sdate = 3, lon = 8, lat = 8, ftime = 20) - # Compute the spectral slopes ignoring the wavenumber # corresponding to the largest scale (the box) -slopes <- RFSlope(pr, kmin=2) -dim(slopes) -# ensemble sdate -# 4 3 -slopes -# [,1] [,2] [,3] -#[1,] 1.893503 1.893503 1.893503 -#[2,] 1.893503 1.893503 1.893503 -#[3,] 1.893503 1.893503 1.893503 -#[4,] 1.893503 1.893503 1.893503 +slopes <- RFSlope(pr, kmin = 2, time_dim = 'ftime') } \author{ Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it} diff --git a/man/RFTemp.Rd b/man/RFTemp.Rd index d16904dff58ce152294f521de8287c6b1a8c567a..1e519d8800b3e43f873acfa94cd572b118498b18 100644 --- a/man/RFTemp.Rd +++ b/man/RFTemp.Rd @@ -99,7 +99,7 @@ dim(o) <- c(lat = 29, lon = 29) lono <- seq(3, 10, 0.25) lato <- seq(41, 48, 0.25) res <- RFTemp(t, lon, lat, o, lono, lato, xlim = c(4, 8), ylim = c(43, 46), - lapse = 6.5) + lapse = 6.5, time_dim = 'ftime') } \references{ Method described in ERA4CS MEDSCOPE milestone M3.2: diff --git a/man/RF_Weights.Rd b/man/RF_Weights.Rd index 44b4d0359e4b2e8d54a0610971cc84931826c59c..d82fbe111b7c114f8b03f35b5d85391364707a6c 100644 --- a/man/RF_Weights.Rd +++ b/man/RF_Weights.Rd @@ -59,7 +59,7 @@ precipitation climatology file. \examples{ a <- array(1:2500, c(lat = 50, lon = 50)) res <- RF_Weights(a, seq(0.1 ,5, 0.1), seq(0.1 ,5, 0.1), - nf = 5, lat = 1:5, lon = 1:5) + nf = 5, lat = 1:5, lon = 1:5) } \references{ Terzago, S., Palazzi, E., & von Hardenberg, J. (2018). diff --git a/man/RainFARM.Rd b/man/RainFARM.Rd index 700ded13b100a74e847dbedb78418681face437e..333896dccba2d46e6261f6a0762cfc647033d359 100644 --- a/man/RainFARM.Rd +++ b/man/RainFARM.Rd @@ -42,7 +42,7 @@ increased by this factor).} \item{weights}{Multi-dimensional array with climatological weights which can be obtained using the \code{CST_RFWeights} function. If \code{weights=1.} (default) no weights are used. The names of these dimensions must be at -least 'lon' and 'lat'.} +least the same longitudinal and latitudinal dimension names as data.} \item{nens}{Number of ensemble members to produce (default: \code{nens=1}).} @@ -115,19 +115,14 @@ vary with 'sdate' dimension. \examples{ # Example for the 'reduced' RainFARM function nf <- 8 # Choose a downscaling by factor 8 -nens <- 3 # Number of ensemble members -# create a test array with dimension 8x8 and 20 timesteps -# or provide your own read from a netcdf file -pr <- rnorm(8 * 8 * 20) -dim(pr) <- c(lon = 8, lat = 8, ftime = 20) -lon_mat <- seq(10, 13.5, 0.5) # could also be a 2d matrix -lat_mat <- seq(40, 43.5, 0.5) +exp <- 1 : (2 * 3 * 4 * 8 * 8) +dim(exp) <- c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 8, lon = 8) +lon <- seq(10, 13.5, 0.5) +lat <- seq(40, 43.5, 0.5) # Create a test array of weights ww <- array(1., dim = c(lon = 8 * nf, lat = 8 * nf)) -# downscale using weights (ww=1. means do not use weights) -res <- RainFARM(pr, lon_mat, lat_mat, nf, - fsmooth = TRUE, fglob = FALSE, - weights = ww, nens = 2, verbose = TRUE) +res <- RainFARM(data = exp, lon = lon, lat = lat, nf = nf, + weights = ww, nens = 3, time_dim = 'ftime') } \author{ Jost von Hardenberg - ISAC-CNR, \email{j.vonhardenberg@isac.cnr.it} diff --git a/man/RegimesAssign.Rd b/man/RegimesAssign.Rd index c11091f25ea00d86378b70c5552b897f2f51e5a8..797367c8edcbed5933f8f2f12fd04b16ac5e2c97 100644 --- a/man/RegimesAssign.Rd +++ b/man/RegimesAssign.Rd @@ -60,12 +60,13 @@ assigned to the reference map for which the minimum Eucledian distance obtained. } \examples{ -\dontrun{ -regimes <- WeatherRegime(data = lonlat_temp$obs$data, lat = lonlat_temp$obs$lat, +data <- array(abs(rnorm(1280, 282.7, 6.4)), dim = c(dataset = 2, member = 2, + sdate = 3, ftime = 3, + lat = 4, lon = 4)) +regimes <- WeatherRegime(data = data, lat = seq(47, 44), EOFs = FALSE, ncenters = 4)$composite -res1 <- RegimesAssign(data = lonlat_temp$exp$data, ref_maps = drop(regimes), - lat = lonlat_temp$exp$lat, composite = FALSE) -} +res1 <- RegimesAssign(data = data, ref_maps = drop(regimes), + lat = seq(47, 44), composite = FALSE) } \references{ Torralba, V. (2019) Seasonal climate prediction for the wind diff --git a/man/SaveExp.Rd b/man/SaveExp.Rd index 3eb7705c146ca9d33e9b5f45397a3f405d577627..6ddb4afb2cc729f36a15012f0c053e9709ecb92c 100644 --- a/man/SaveExp.Rd +++ b/man/SaveExp.Rd @@ -2,86 +2,114 @@ % Please edit documentation in R/CST_SaveExp.R \name{SaveExp} \alias{SaveExp} -\title{Save an experiment in a format compatible with CST_Load} +\title{Save a multidimensional array with metadata to data in NetCDF format} \usage{ SaveExp( data, - lon, - lat, - Dataset, - var_name, - units, - startdates, - Dates, - cdo_grid_name, - projection, - destination, + destination = "./", + Dates = NULL, + coords = NULL, + varname = NULL, + metadata = NULL, + Datasets = NULL, + startdates = NULL, + dat_dim = "dataset", + sdate_dim = "sdate", + ftime_dim = "time", + var_dim = "var", + memb_dim = "member", + single_file = FALSE, extra_string = NULL ) } \arguments{ -\item{data}{An multi-dimensional array with named dimensions (longitude, -latitude, time, member, sdate).} +\item{data}{A multi-dimensional array with named dimensions.} -\item{lon}{Vector of logitud corresponding to the longitudinal dimension in -data.} +\item{destination}{A character string indicating the path where to store the +NetCDF files.} -\item{lat}{Vector of latitud corresponding to the latitudinal dimension in -data.} +\item{Dates}{An named array of dates with the corresponding sdate and forecast +time dimension.} -\item{Dataset}{A vector of character string indicating the names of the -datasets.} +\item{coords}{A named list with elements of the coordinates corresponding to +the dimensions of the data parameter. The names and length of each element +must correspond to the names of the dimensions. If any coordinate is not +provided, it is set as an index vector with the values from 1 to the length +of the corresponding dimension.} -\item{var_name}{A character string indicating the name of the variable to be +\item{varname}{A character string indicating the name of the variable to be saved.} -\item{units}{A character string indicating the units of the variable.} +\item{metadata}{A named list where each element is a variable containing the +corresponding information. The information must be contained in a list of +lists for each variable.} + +\item{Datasets}{A vector of character string indicating the names of the +datasets.} \item{startdates}{A vector of dates indicating the initialization date of each simulations.} -\item{Dates}{A matrix of dates with two dimension 'time' and 'sdate'.} +\item{dat_dim}{A character string indicating the name of dataset dimension. +By default, it is set to 'dataset'. It can be NULL if there is no dataset +dimension.} -\item{cdo_grid_name}{A character string indicating the name of the grid e.g.: -'r360x181'} +\item{sdate_dim}{A character string indicating the name of the start date +dimension. By default, it is set to 'sdate'. It can be NULL if there is no +start date dimension.} -\item{projection}{A character string indicating the projection name.} +\item{ftime_dim}{A character string indicating the name of the forecast time +dimension. By default, it is set to 'time'. It can be NULL if there is no +forecast time dimension.} -\item{destination}{A character string indicating the path where to store the -NetCDF files.} +\item{var_dim}{A character string indicating the name of variable dimension. +By default, it is set to 'var'. It can be NULL if there is no variable +dimension.} + +\item{memb_dim}{A character string indicating the name of the member dimension. +By default, it is set to 'member'. It can be NULL if there is no member +dimension.} + +\item{single_file}{A logical value indicating if all object is saved in a +unique file (TRUE) or in separated directories (FALSE). When it is FALSE, +the array is separated for Datasets, variable and start date. It is FALSE +by default.} \item{extra_string}{A character string to be include as part of the file name, -for instance, to identify member or realization.} +for instance, to identify member or realization. It would be added to the +file name between underscore characters.} } \value{ -The function creates as many files as sdates per dataset. Each file -could contain multiple members. It would be added to the file name between -underscore characters. The path will be created with the name of the variable -and each Datasets. +If single_file is TRUE only one file is created. If single_file is +FALSE multiple files are created. When multiple files are created, each file +contains the data subset for each start date, variable and dataset. Files +with different variables and Datasets are stored in separated directories. +The path will be created with the name of the variable and each start date. +NetCDF file for each starting date are saved into the + folder tree: \cr + destination/Dataset/variable/. } \description{ -This function is created for compatibility with CST_Load/Load for -saving post-processed datasets such as those calibrated of downscaled with -CSTools functions +This function allows to save a data array with metadata into a +NetCDF file, allowing to reload the saved data using \code{Start} function +from StartR package. If the original 's2dv_cube' object has been created from +\code{CST_Load()}, then it can be reloaded with \code{Load()}. } \examples{ \dontrun{ data <- lonlat_temp$exp$data -lon <- lonlat_temp$exp$lon -lat <- lonlat_temp$exp$lat -Dataset <- 'XXX' -var_name <- 'tas' -units <- 'k' -startdates <- lapply(1:length(lonlat_temp$exp$Datasets), - function(x) { - lonlat_temp$exp$Datasets[[x]]$InitializationDates[[1]]})[[1]] -Dates <- lonlat_temp$exp$Dates$start -dim(Dates) <- c(time = length(Dates)/length(startdates), sdate = length(startdates)) -cdo_grid_name = attr(lonlat_temp$exp$lon, 'cdo_grid_name') -projection = attr(lonlat_temp$exp$lon, 'projection') -destination = './path/' -SaveExp(data, lon, lat, Dataset, var_name, units, startdates, Dates, - cdo_grid_name, projection, destination) +lon <- lonlat_temp$exp$coords$lon +lat <- lonlat_temp$exp$coords$lat +coords <- list(lon = lon, lat = lat) +Datasets <- lonlat_temp$exp$attrs$Datasets +varname <- 'tas' +Dates <- lonlat_temp$exp$attrs$Dates +destination = './' +metadata <- lonlat_temp$exp$attrs$Variable$metadata +SaveExp(data = data, destination = destination, coords = coords, + Datasets = Datasets, varname = varname, Dates = Dates, + metadata = metadata, single_file = TRUE, ftime_dim = 'ftime', + var_dim = NULL) } } \author{ diff --git a/man/WeatherRegimes.Rd b/man/WeatherRegimes.Rd index 68d67b76d60e45e2d0195bbcc11eafc888d84db3..fe52d152b85cb6cd18cba54382002b45fc5a1ad4 100644 --- a/man/WeatherRegimes.Rd +++ b/man/WeatherRegimes.Rd @@ -77,10 +77,12 @@ to filter the dataset. The cluster analysis can be performed with the traditional k-means or those methods included in the hclust (stats package). } \examples{ -\dontrun{ -res <- WeatherRegime(data = lonlat_temp$obs$data, lat = lonlat_temp$obs$lat, - EOFs = FALSE, ncenters = 4) -} +data <- array(abs(rnorm(1280, 283.7, 6)), dim = c(dataset = 2, member = 2, + sdate = 3, ftime = 3, + lat = 4, lon = 4)) +lat <- seq(47, 44) +res <- WeatherRegime(data = data, lat = lat, + EOFs = FALSE, ncenters = 4) } \references{ Cortesi, N., V., Torralba, N., González-Reviriego, A., Soret, and diff --git a/man/as.s2dv_cube.Rd b/man/as.s2dv_cube.Rd index 23a761e60ca53e01070bd39c7814bc152fd1409b..e80044f5dcd8455e91a1527b8ddbe57934df90e1 100644 --- a/man/as.s2dv_cube.Rd +++ b/man/as.s2dv_cube.Rd @@ -4,44 +4,92 @@ \alias{as.s2dv_cube} \title{Conversion of 'startR_array' or 'list' objects to 's2dv_cube'} \usage{ -as.s2dv_cube(object) +as.s2dv_cube(object, remove_attrs_coords = FALSE, remove_null = FALSE) } \arguments{ -\item{object}{an object of class 'startR_array' generated from function \code{Start} from startR package (version 0.1.3 from earth.bsc.es/gitlab/es/startR) or a list output from function \code{Load} from s2dv package.} +\item{object}{An object of class 'startR_array' generated from function +\code{Start} from startR package or a list output from function \code{Load} +from s2dv package. Any other object class will not be accepted.} + +\item{remove_attrs_coords}{A logical value indicating whether to remove the +attributes of the coordinates (TRUE) or not (FALSE). The default value is +FALSE.} + +\item{remove_null}{Optional. A logical value indicating whether to remove the +elements that are NULL (TRUE) or not (FALSE) of the output object. It is +only used when the object is an output from function \code{Load}. The +default value is FALSE.} } \value{ -The function returns a 's2dv_cube' object to be easily used with functions \code{CST} from CSTools package. +The function returns an 's2dv_cube' object to be easily used with +functions with the prefix \code{CST} from CSTools and CSIndicators packages. +The object is mainly a list with the following elements:\cr +\itemize{ + \item{'data', array with named dimensions.} + \item{'dims', named vector of the data dimensions.} + \item{'coords', named list with elements of the coordinates corresponding to + the dimensions of the data parameter. If any coordinate is not provided, it + is set as an index vector with the values from 1 to the length of the + corresponding dimension. The attribute 'indices' indicates wether the + coordinate is an index vector (TRUE) or not (FALSE).} + \item{'attrs', named list with elements: + \itemize{ + \item{'Dates', array with named temporal dimensions of class 'POSIXct' + from time values in the data.} + \item{'Variable', has the following components: + \itemize{ + \item{'varName', character vector of the short variable name. It is + usually specified in the parameter 'var' from the functions + Start and Load.} + \item{'metadata', named list of elements with variable metadata. + They can be from coordinates variables (e.g. longitude) or + main variables (e.g. 'var').} + } + } + \item{'Datasets', character strings indicating the names of the + datasets.} + \item{'source_files', a vector of character strings with complete paths + to all the found files involved in loading the data.} + \item{'when', a time stamp of the date issued by the Start() or Load() + call to obtain the data.} + \item{'load_parameters', it contains the components used in the + arguments to load the data from Start() or Load() functions.} + } + } +} } \description{ -This function converts data loaded using startR package or s2dv Load function into a 's2dv_cube' object. +This function converts data loaded using Start function from startR package or +Load from s2dv into an 's2dv_cube' object. } \examples{ \dontrun{ +# Example 1: convert an object from startR::Start function to 's2dv_cube' library(startR) repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' data <- Start(dat = repos, var = 'tas', sdate = c('20170101', '20180101'), - ensemble = indices(1:20), + ensemble = indices(1:5), time = 'all', - latitude = 'all', - longitude = indices(1:40), + latitude = indices(1:5), + longitude = indices(1:5), return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'), retrieve = TRUE) data <- as.s2dv_cube(data) -class(data) +# Example 2: convert an object from s2dv::Load function to 's2dv_cube' startDates <- c('20001101', '20011101', '20021101', - '20031101', '20041101', '20051101') + '20031101', '20041101', '20051101') data <- Load(var = 'tas', exp = 'system5c3s', - nmember = 15, sdates = startDates, - leadtimemax = 3, latmin = 27, latmax = 48, - lonmin = -12, lonmax = 40, output = 'lonlat') + nmember = 2, sdates = startDates, + leadtimemax = 3, latmin = 10, latmax = 30, + lonmin = -10, lonmax = 10, output = 'lonlat') data <- as.s2dv_cube(data) -class(data) } } \seealso{ -\code{\link{s2dv_cube}}, \code{\link[s2dv]{Load}}, \code{\link[startR]{Start}} and \code{\link{CST_Load}} +\code{\link{s2dv_cube}}, \code{\link[s2dv]{Load}}, +\code{\link[startR]{Start}} and \code{\link{CST_Load}} } \author{ Perez-Zanon Nuria, \email{nuria.perez@bsc.es} diff --git a/man/s2dv_cube.Rd b/man/s2dv_cube.Rd index 327f3d17c0d95c2e10fe88281dff15dd0ced2c5d..ff302ccd93252143b387eb102991c3d1edb29caa 100644 --- a/man/s2dv_cube.Rd +++ b/man/s2dv_cube.Rd @@ -6,60 +6,88 @@ \usage{ s2dv_cube( data, - lon = NULL, - lat = NULL, - Variable = NULL, + coords = NULL, + varName = NULL, + metadata = NULL, Datasets = NULL, Dates = NULL, - time_dims = NULL, when = NULL, - source_files = NULL + source_files = NULL, + ... ) } \arguments{ -\item{data}{an array with any number of named dimensions, typically an object -output from CST_Load, with the following dimensions: dataset, member, sdate, -ftime, lat and lon.} +\item{data}{A multidimensional array with named dimensions, typically with +dimensions: dataset, member, sdate, ftime, lat and lon.} -\item{lon}{an array with one dimension containing the longitudes and -attributes: dim, cdo_grid_name, data_across_gw, array_across_gw, first_lon, -last_lon and projection.} +\item{coords}{A named list with elements of the coordinates corresponding to +the dimensions of the data parameter. The names and length of each element +must correspond to the names of the dimensions. If any coordinate is not +provided, it is set as an index vector with the values from 1 to the length +of the corresponding dimension.} -\item{lat}{an array with one dimension containing the latitudes and -attributes: dim, cdo_grid_name, first_lat, last_lat and projection.} +\item{varName}{A character string indicating the abbreviation of the variable +name.} -\item{Variable}{a list of two elements: \code{varName} a character string -indicating the abbreviation of a variable name and \code{level} a character -string indicating the level (e.g., "2m"), if it is not required it could be -set as NULL.} +\item{metadata}{A named list where each element is a variable containing the +corresponding information. The information can be contained in a list of +lists for each variable.} -\item{Datasets}{a named list with the dataset model with two elements: -\code{InitiatlizationDates}, containing a list of the start dates for each -member named with the names of each member, and \code{Members} containing a -vector with the member names (e.g., "Member_1")} +\item{Datasets}{Character strings indicating the names of the dataset. It +there are multiple datasets it can be a vector of its names or a list of +lists with additional information.} -\item{Dates}{a named list of one to two elements: The first element, -\code{start}, is an array of dimensions (sdate, time) with the POSIX initial -date of each forecast time of each starting date. The second element, -\code{end} (optional), is an array of dimensions (sdate, time) with the POSIX} +\item{Dates}{A POSIXct array of time dimensions containing the Dates.} -\item{time_dims}{a vector of strings containing the names of the temporal -dimensions found in \code{data}.} +\item{when}{A time stamp of the date when the data has been loaded. This +parameter is also found in Load() and Start() functions output.} -\item{when}{a time stamp of the date issued by the Load() call to obtain the -data.} +\item{source_files}{A vector of character strings with complete paths to all +the found files involved in loading the data.} -\item{source_files}{a vector of character strings with complete paths to all -the found files involved in the Load() call.} +\item{\dots}{Additional elements to be added in the object. They will be +stored in the end of 'attrs' element. Multiple elements are accepted.} } \value{ -The function returns an object of class 's2dv_cube'. +The function returns an object of class 's2dv_cube' with the following +elements in the structure:\cr +\itemize{ + \item{'data', array with named dimensions.} + \item{'dims', named vector of the data dimensions.} + \item{'coords', named list with elements of the coordinates corresponding to + the dimensions of the data parameter. If any coordinate is not provided, it + is set as an index vector with the values from 1 to the length of the + corresponding dimension. The attribute 'indices' indicates wether the + coordinate is an index vector (TRUE) or not (FALSE).} + \item{'attrs', named list with elements: + \itemize{ + \item{'Dates', array with named temporal dimensions of class 'POSIXct' from + time values in the data.} + \item{'Variable', has the following components: + \itemize{ + \item{'varName', with the short name of the loaded variable as specified + in the parameter 'var'.} + \item{''metadata', named list of elements with variable metadata. + They can be from coordinates variables (e.g. longitude) or + main variables (e.g. 'var').} + } + } + \item{'Datasets', character strings indicating the names of the dataset.} + \item{'source_files', a vector of character strings with complete paths to + all the found files involved in loading the data.} + \item{'when', a time stamp of the date issued by the Start() or Load() call to + obtain the data.} + \item{'load_parameters', it contains the components used in the arguments to + load the data from Start() or Load() functions.} + } + } +} } \description{ -This function allows to create a 's2dv_cube' object by passing +This function allows to create an 's2dv_cube' object by passing information through its parameters. This function will be needed if the data hasn't been loaded using CST_Load or has been transformed with other methods. -A 's2dv_cube' object has many different components including metadata. This +An 's2dv_cube' object has many different components including metadata. This function will allow to create 's2dv_cube' objects even if not all elements are defined and for each expected missed parameter a warning message will be returned. @@ -69,44 +97,42 @@ exp_original <- 1:100 dim(exp_original) <- c(lat = 2, time = 10, lon = 5) exp1 <- s2dv_cube(data = exp_original) class(exp1) -exp2 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50)) +coords <- list(lon = seq(-10, 10, 5), lat = c(45, 50)) +exp2 <- s2dv_cube(data = exp_original, coords = coords) class(exp2) -exp3 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), - Variable = list(varName = 'tas', level = '2m')) +metadata <- list(tas = list(level = '2m')) +exp3 <- s2dv_cube(data = exp_original, coords = coords, + varName = 'tas', metadata = metadata) class(exp3) -exp4 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), - Variable = list(varName = 'tas', level = '2m'), - Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), - end = paste0(rep("31", 10), rep("01", 10), 1990:1999))) +Dates = as.POSIXct(paste0(rep("01", 10), rep("01", 10), 1990:1999), format = "\%d\%m\%Y") +dim(Dates) <- c(time = 10) +exp4 <- s2dv_cube(data = exp_original, coords = coords, + varName = 'tas', metadata = metadata, + Dates = Dates) class(exp4) -exp5 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), - Variable = list(varName = 'tas', level = '2m'), - Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), - end = paste0(rep("31", 10), rep("01", 10), 1990:1999)), - when = "2019-10-23 19:15:29 CET") +exp5 <- s2dv_cube(data = exp_original, coords = coords, + varName = 'tas', metadata = metadata, + Dates = Dates, when = "2019-10-23 19:15:29 CET") class(exp5) -exp6 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), - Variable = list(varName = 'tas', level = '2m'), - Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), - end = paste0(rep("31", 10), rep("01", 10), 1990:1999)), +exp6 <- s2dv_cube(data = exp_original, coords = coords, + varName = 'tas', metadata = metadata, + Dates = Dates, when = "2019-10-23 19:15:29 CET", - source_files = c("/path/to/file1.nc", "/path/to/file2.nc")) + source_files = c("/path/to/file1.nc", "/path/to/file2.nc")) class(exp6) -exp7 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), - Variable = list(varName = 'tas', level = '2m'), - Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), - end = paste0(rep("31", 10), rep("01", 10), 1990:1999)), +exp7 <- s2dv_cube(data = exp_original, coords = coords, + varName = 'tas', metadata = metadata, + Dates = Dates, when = "2019-10-23 19:15:29 CET", source_files = c("/path/to/file1.nc", "/path/to/file2.nc"), Datasets = list( exp1 = list(InitializationsDates = list(Member_1 = "01011990", Members = "Member_1")))) class(exp7) -dim(exp_original) <- c(dataset = 1, member = 1, sdate = 2, ftime = 5, lat = 2, lon = 5) -exp8 <- s2dv_cube(data = exp_original, lon = seq(-10, 10, 5), lat = c(45, 50), - Variable = list(varName = 'tas', level = '2m'), - Dates = list(start = paste0(rep("01", 10), rep("01", 10), 1990:1999), - end = paste0(rep("31", 10), rep("01", 10), 1990:1999))) +dim(exp_original) <- c(dataset = 1, member = 1, time = 10, lat = 2, lon = 5) +exp8 <- s2dv_cube(data = exp_original, coords = coords, + varName = 'tas', metadata = metadata, + Dates = Dates, original_dates = Dates) class(exp8) } \seealso{ diff --git a/tests/testthat/test-CST_Analogs.R b/tests/testthat/test-CST_Analogs.R index b239b44a529fb5825af696e06d5ae5648bdd90e9..66e1c88a8026878285ee3a705014184e0319f88a 100644 --- a/tests/testthat/test-CST_Analogs.R +++ b/tests/testthat/test-CST_Analogs.R @@ -13,14 +13,23 @@ time_obsL1 <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-") time_expL1 <- "01-01-1994" lon1 <- seq(0, 20, 5) lat1 <- seq(0, 15, 4) -exp <- list(data = exp1, lat = lat1, lon = lon1) -obs <- list(data = obs1, lat = lat1, lon = lon1) +coords = list(lat = lat1, lon = lon1) +attrs_expL <- list(Dates = time_expL1) +attrs_obsL <- list(Dates = time_obsL1) +exp <- list(data = exp1, coords = coords, attrs = attrs_expL) +obs <- list(data = obs1, coords = coords, attrs = attrs_obsL) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' +# dat2 +obs2 <- obs +obs2$coords <- NULL +obs2_2 <- obs2 +obs2_2$coords <- list(long = seq(1:4), lati = seq(1:4)) + ############################################## test_that("1. Input checks: CST_Analogs", { - # s2dv_cube + # Check 's2dv_cube' expect_error( CST_Analogs(expL = 1, obsL = 1), paste0("Parameter 'expL' and 'obsL' must be of the class 's2dv_cube', ", @@ -36,6 +45,29 @@ test_that("1. Input checks: CST_Analogs", { paste0("Parameter 'obsVar' must be of the class 's2dv_cube', ", "as output by CSTools::CST_Load.") ) + + # Check 'obsL' object structure + expect_error( + CST_Analogs(expL = exp, obsL = obs2), + paste0("Parameter 'obsL' must have 'data', 'coords' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + ) + expect_error( + CST_Analogs(expL = exp, obsL = obs2_2), + paste0("Spatial coordinate names of parameter 'obsL' do not match any ", + "of the names accepted by the package.") + ) + # Check 'obsVar' object structure + expect_error( + CST_Analogs(expL = exp, obsL = obs, expVar = exp, obsVar = obs2), + paste0("Parameter 'obsVar' must have 'data', 'coords' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + ) + expect_error( + CST_Analogs(expL = exp, obsL = obs, expVar = exp, obsVar = obs2_2), + paste0("Spatial coordinate names of parameter 'obsVar' do not match any ", + "of the names accepted by the package.") + ) }) ############################################## @@ -94,14 +126,42 @@ test_that("2. Input checks: Analogs", { expect_error( Analogs(expL = exp1, obsL = obs1, criteria = "Local_cor", lonL = lon1, time_expL = time_expL1, time_obsL = NULL, latL = lat1), - "Parameter 'time_obsL' cannot be NULL." + "Parameters 'lonVar' and 'latVar' cannot be NULL." ) ) suppressWarnings( expect_error( Analogs(expL = exp1, obsL = obs1, criteria = "Local_cor", lonL = lon1, - time_obsL = time_obsL1, latL = lat1), + time_obsL = time_obsL1, latL = lat1, lonVar = lon1, latVar = lat1), "Parameter 'time_expL' cannot be NULL." ) ) }) + +############################################## + +test_that("3. Output checks" , { + suppressWarnings( + res <- CST_Analogs(expL = exp, obsL = obs) + ) + expect_equal( + names(res), + c('data', 'coords', 'attrs') + ) + expect_equal( + dim(res$data), + c(nAnalogs = 1, lat = 4, lon = 5) + ) + suppressWarnings( + res1 <- CST_Analogs(expL = exp, obsL = obs, expVar = exp, obsVar = obs, + AnalogsInfo = TRUE) + ) + expect_equal( + names(res1$data), + c('fields', 'analogs', 'metric', 'dates') + ) + expect_equal( + dim(res1$data$fields), + c(nAnalogs = 1, lat = 4, lon = 5) + ) +}) diff --git a/tests/testthat/test-CST_BEI_Weighting.R b/tests/testthat/test-CST_BEI_Weighting.R index e3686fead7a00b03e722b73b1a505272195a5603..3a70f38aa20452884e95d338711c0daea432fb62 100644 --- a/tests/testthat/test-CST_BEI_Weighting.R +++ b/tests/testthat/test-CST_BEI_Weighting.R @@ -1,166 +1,196 @@ -context("Generic tests") -test_that("basic use case", { - - var_exp <- 1 : (2 * 4 * 3 * 2) - dim(var_exp) <- c(time = 2, member = 4, lat = 3, lon = 2) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3, 0.1, 0.2, 0.4, 0.4, 0.1, 0.2, 0.4, 0.2) - dim(aweights) <- c(time = 2, member = 4, dataset = 2) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - result <- array(c(4.4, 5.4, 12.4, 13.4, 20.4, 21.4, - 28.4, 29.4, 36.4, 37.4, 44.4, 45.4, - 4.6, 4.8, 12.6, 12.8, 20.6, 20.8, - 28.6, 28.8, 36.6, 36.8, 44.6, 44.8), - dim = c(time = 2, lat = 3, lon = 2, dataset =2)) - expect_equal(CST_BEI_Weighting(var_exp, aweights, type = 'ensembleMean', - time_dim_name = 'time')$data, result, tolerance=1e-4) - - var_exp <- 1 : (2 * 3 * 1 * 2) - dim(var_exp) <- c(time = 2, member = 3, lat = 1, lon = 2) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(time = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - result <- array(c(0.5, 0.1, 0.0, 0.4, 0.5, 0.5, 0.5, 0.1, 0.0, 0.4, 0.5, 0.5), - dim = c(time = 2, tercil = 3, lat = 1, lon = 2)) - expect_equal(CST_BEI_Weighting(var_exp, aweights, type = 'probs', - time_dim_name = 'time')$data, result, tolerance=1e-4) - - var_exp <- 1 : (2 * 3 * 1 * 2) - dim(var_exp) <- c(sdate = 2, member = 3, lat = 1, lon = 2) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(sdate = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - result <- array(c(0.5, 0.1, 0.0, 0.4, 0.5, 0.5, - 0.5, 0.1, 0.0, 0.4, 0.5, 0.5), - dim = c(sdate = 2, tercil = 3, lat = 1, lon = 2)) - - expect_equal(CST_BEI_Weighting(var_exp, aweights, type = 'probs', - time_dim_name = 'sdate')$data, result, tolerance=1e-4) - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(sdate = 2, member = 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(sdate = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - result <- array(c(0.5, 0.1, 0.0, 0.4, 0.5, 0.5), - dim = c(sdate = 2, tercil = 3)) - - expect_equal(CST_BEI_Weighting(var_exp, aweights, type = 'probs', - time_dim_name = 'sdate')$data, result, tolerance=1e-4) -}) +context("CSTools::CST_CST_BEI_Weighting tests") + +# dat +var_exp <- array(1:6, dim = c(sdate = 2, member = 3)) +var_exp <- list(data = var_exp) +class(var_exp) <- 's2dv_cube' +aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) +dim(aweights) <- c(sdate = 2, member = 3) +terciles <- rep(c(35, 45)) +dim(terciles) <- c(tercil = 2) + +# dat1 +var_exp1 <- array(1:6, dim = c(time = 2, member = 3)) +aweights1 <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) +dim(aweights1) <- c(time = 2, member = 3) + +# dat2 +var_exp2 <- array(1:(2*4*3*2), dim = c(time = 2, member = 4, lat = 3, lon = 2)) +aweights2 <- c(0.2, 0.1, 0.3, 0.4, 0.1, 0.2, 0.4, 0.3, + 0.1, 0.2, 0.4, 0.4, 0.1, 0.2, 0.4, 0.2) +dim(aweights2) <- c(time = 2, member = 4, dataset = 2) +var_exp2 <- list(data = var_exp2) +class(var_exp2) <- 's2dv_cube' +terciles2 <- rep(c(35, 45), 3*2) +dim(terciles2) <- c(tercil = 2, lat = 3, lon = 2) -test_that("Sanity checks", { +result2 <- array(c(4.4, 5.4, 12.4, 13.4, 20.4, 21.4, + 28.4, 29.4, 36.4, 37.4, 44.4, 45.4, + 4.6, 4.8, 12.6, 12.8, 20.6, 20.8, + 28.6, 28.8, 36.6, 36.8, 44.6, 44.8), + dim = c(time = 2, lat = 3, lon = 2, dataset = 2)) + +############################################## + +test_that("1. Input checks", { + # s2dv_cube expect_error( - CST_BEI_Weighting(var_exp, aweights, type = 'probs', time_dim_name = 1), - paste0("Parameter 'time_dim_name' must be a character string indicating", - " the name of the temporal dimension.")) - + CST_BEI_Weighting(var_exp = 1, aweights = 1, type = 'probs', time_dim_name = 1), + paste0("Parameter 'var_exp' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # type expect_error( - CST_BEI_Weighting(var_exp, aweights, type = 2), + CST_BEI_Weighting(var_exp = var_exp, aweights = aweights, type = 1, + time_dim_name = 1), paste0("Parameter 'type' must be a character string, 'probs' or ", - "'ensembleMean', indicating the type of output.")) - + "'ensembleMean', indicating the type of output.") + ) expect_error( - CST_BEI_Weighting(var_exp = 1, aweights), - paste0("Parameter 'var_exp' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.")) - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(sdate = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - expect_error( - CST_BEI_Weighting(var_exp, aweights = 2), - "Parameter 'aweights' must be an array.") - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(2, 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(2, 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - paste0("Element 'data' from parameter 'var_exp' and parameter 'aweights'", - " should have dimmension names.")) - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(sdate = 2, member = 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(sdate = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - paste0("Element 'data' from parameter 'var_exp' must have ", - "temporal dimension.")) - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(time = 2, member = 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(sdate = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - "Parameter 'aweights' must have temporal dimension.") - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(time = 2, season = 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(time = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - paste0("Element 'data' from parameter 'var_exp' must have ", - "dimension 'member'.")) - - var_exp <- 1 : (2 * 3) - dim(var_exp) <- c(time = 2, member = 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(time = 2, season = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - paste0("Parameter 'aweights' must have ", - "dimension 'member'.")) - - var_exp <- 1 : (3 * 3) - dim(var_exp) <- c(time = 3, member = 3) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(time = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - paste0("Length of temporal dimensions ", - "of element 'data' from parameter 'var_exp' and parameter ", - "'aweights' must be equals.")) - - var_exp <- 1 : (3 * 4) - dim(var_exp) <- c(time = 3, member = 4) - aweights <- c(0.2, 0.1, 0.3, 0.4, 0.5, 0.5) - dim(aweights) <- c(time = 2, member = 3) - var_exp <- list(data = var_exp) - class(var_exp) <- 's2dv_cube' - - expect_error( - CST_BEI_Weighting(var_exp, aweights), - paste0("Length of temporal dimensions of element 'data' from ", - "parameter 'var_exp' and parameter 'aweights' must be equals.")) - + CST_BEI_Weighting(var_exp = var_exp, aweights = aweights, type = c('a'), + time_dim_name = 1), + paste0("Parameter 'type' must be a character string ('probs' or ", + "'ensembleMean'), indicating the type of output."), + fixed = TRUE + ) + # var_exp + expect_error( + BEI_EMWeighting(var_exp = 1, aweights = 2), + "Parameter 'var_exp' must be an array." + ) + expect_error( + BEI_ProbsWeighting(var_exp = 1, aweights = 2), + "Parameter 'var_exp' must be an array." + ) + # aweights + expect_error( + BEI_EMWeighting(var_exp = var_exp$data, aweights = 2), + "Parameter 'aweights' must be an array." + ) + # aweights + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = 2), + "Parameter 'aweights' must be an array." + ) + # terciles + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, terciles = NULL), + "Parameter 'terciles' cannot be null." + ) + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, + terciles = 1), + "Parameter 'terciles' must be an array." + ) + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, + terciles = array(1:10, c(10))), + "Parameter 'terciles' should have dimension names." + ) + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, + terciles = array(1:10, c(time = 10))), + "Parameter 'terciles' must have dimension 'tercil'." + ) + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, + terciles = array(1:10, c(tercil = 10))), + paste0("Length of dimension 'tercil' ", + "of parameter 'terciles' must be equal to 2.") + ) + # time_dim_name + expect_error( + BEI_EMWeighting(var_exp = var_exp$data, aweights = aweights, time_dim_name = 1), + paste0("Parameter 'time_dim_name' must be a character string indicating", + " the name of the temporal dimension.") + ) + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, + terciles = terciles, time_dim_name = 1), + paste0("Parameter 'time_dim_name' must be a character string indicating", + " the name of the temporal dimension.") + ) + # memb_dim + expect_error( + BEI_EMWeighting(var_exp = var_exp$data, aweights = aweights, memb_dim = 1), + paste0("Parameter 'memb_dim' must be a character string indicating", + " the name of the member dimension.") + ) + expect_error( + BEI_ProbsWeighting(var_exp = var_exp$data, aweights = aweights, + terciles = terciles, memb_dim = 1), + paste0("Parameter 'memb_dim' must be a character string indicating", + " the name of the member dimension.") + ) + # var_exp, aweights (2) + expect_error( + BEI_EMWeighting(var_exp = array(10), aweights = array(10)), + "Parameters 'var_exp' and 'aweights' should have dimension names." + ) + expect_error( + BEI_EMWeighting(var_exp = var_exp$data, aweights = aweights), + "Parameter 'var_exp' must have temporal dimension." + ) + expect_error( + BEI_EMWeighting(var_exp = var_exp1, aweights = aweights), + "Parameter 'aweights' must have temporal dimension." + ) + expect_error( + BEI_EMWeighting(var_exp = array(1:6, dim = c(time = 2, members = 3)), + aweights = aweights1), + "Parameter 'var_exp' must have member dimension." + ) + expect_error( + BEI_EMWeighting(var_exp = var_exp1, + aweights = array(1:6, dim = c(time = 2, members = 3))), + "Parameter 'aweights' must have member dimension." + ) + expect_error( + BEI_EMWeighting(var_exp = array(1:6, dim = c(time = 1, member = 3)), + aweights = array(1:6, dim = c(time = 2, member = 3))), + paste0("Length of temporal dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") + ) + expect_error( + BEI_EMWeighting(var_exp = array(1:6, dim = c(time = 2, member = 2)), + aweights = array(1:6, dim = c(time = 2, member = 3))), + paste0("Length of member dimension ", + "of parameter 'var_exp' and 'aweights' must be equal.") + ) }) + +############################################## + +test_that("basic use case", { + expect_equal( + CST_BEI_Weighting(var_exp2, aweights2, type = 'ensembleMean')$data, + result2, + tolerance = 1e-4 + ) + expect_equal( + as.vector(CST_BEI_Weighting(var_exp2, aweights2)$data[, , 2, 2]), + c(28.6, 28.8, 36.6, 36.8, 44.6, 44.8), + tolerance = 1e-4 + ) + res <- CST_BEI_Weighting(var_exp2, aweights2, type = 'probs', + terciles = terciles2)$data + expect_equal( + dim(res), + c(time = 2, tercil = 3, lat = 3, lon = 2, dataset = 2), + tolerance = 1e-4 + ) + expect_equal( + res[, , 2, 2, 2], + array(c(0.5, 0.2, 0.5, 0.8, 0, 0), dim = c(time = 2, tercil = 3)), + tolerance = 1e-4 + ) + expect_equal( + BEI_EMWeighting(var_exp = array(1:6, dim = c(times = 2, members = 3)), + aweights = array(1:6, dim = c(times = 2, members = 3)), + time_dim_name = 'times', memb_dim = 'members'), + array(c(35, 56), dim = c(times = 2)), + tolerance = 1e-4 + ) +}) + +############################################## \ No newline at end of file diff --git a/tests/testthat/test-CST_BiasCorrection.R b/tests/testthat/test-CST_BiasCorrection.R index 0a590ce40df6b240442beb52ca53745f0a43c8bf..e9e6ff08c3456cee2bca3507cfccf5b012112eac 100644 --- a/tests/testthat/test-CST_BiasCorrection.R +++ b/tests/testthat/test-CST_BiasCorrection.R @@ -11,8 +11,9 @@ dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 30, 5) lat <- seq(0, 25, 5) -exp <- list(data = mod, lat = lat, lon = lon) -obs <- list(data = obs, lat = lat, lon = lon) +coords <- list(lat = lat, lon = lon) +exp <- list(data = mod, coords = coords) +obs <- list(data = obs, coords = coords) attr(exp, 'class') <- 's2dv_cube' attr(obs, 'class') <- 's2dv_cube' @@ -198,18 +199,18 @@ test_that("2. Output checks: dat1", { bc <- CST_BiasCorrection(exp = exp, obs = obs) expect_equal( length(bc), - 3 + 2 ) expect_equal( dim(bc$data), c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) ) expect_equal( - bc$lat, + bc$coords$lat, lat ) expect_equal( - bc$lon, + bc$coords$lon, lon ) expect_equal( diff --git a/tests/testthat/test-CST_Calibration.R b/tests/testthat/test-CST_Calibration.R index 35eccbe9bb67f9fef5aa74658cc9451d703dc988..898acbed1054b42b5a2914e94cb22ec2a7de1e09 100644 --- a/tests/testthat/test-CST_Calibration.R +++ b/tests/testthat/test-CST_Calibration.R @@ -3,11 +3,17 @@ context("CSTools::CST_Calibration tests") ############################################## # dat -exp_obs <- lonlat_temp -exp <- exp_obs$exp -obs <- exp_obs$obs -exp$data <- ClimProjDiags::Subset(exp$data, c('lat', 'lon'), list(1:5, 1:5)) -obs$data <- ClimProjDiags::Subset(obs$data, c('lat', 'lon'), list(1:5, 1:5)) +data_exp = array(1:20, dim = c(dataset = 1, member = 15, sdate = 6, ftime = 3, lat = 5, lon = 5)) +lon <- seq(0, 4) +lat <- seq(1, 5) +coords <- list(lon = lon, lat = lat) +attrs_exp = list(Datasets = 'exp_sample_data') +exp <- list(data = data_exp, coords = coords, attrs = attrs_exp) +class(exp) <- 's2dv_cube' +data_obs <- array(1:20, dim = c(dataset = 1, member = 1, sdate = 6, ftime = 3, lat = 5, lon = 5)) +attrs_obs = list(Datasets = 'obs_sample_data') +obs <- list(data = data_obs, coords = coords, attrs = attrs_obs) +class(obs) <- 's2dv_cube' # dat1 exp1 <- list(data = array(1:20, dim = c(time = 20))) @@ -209,27 +215,27 @@ test_that("2. Output checks: dat1", { cal <- CST_Calibration(exp = exp, obs = obs) expect_equal( length(cal), - 9 + 3 ) expect_equal( as.numeric(dim(cal$data)), as.numeric(dim(exp$data)) ) expect_equal( - cal$lat, - exp$lat + cal$coords$lat, + exp$coords$lat ) expect_equal( - cal$lat, - obs$lat + cal$coords$lat, + obs$coords$lat ) expect_equal( - cal$lon, - exp$lon + cal$coords$lon, + exp$coords$lon ) expect_equal( - cal$lon, - obs$lon + cal$coords$lon, + obs$coords$lon ) expect_equal( dim(cal$data), @@ -237,7 +243,7 @@ test_that("2. Output checks: dat1", { ) expect_equal( as.vector(cal$data)[1:5], - c(280.8678, 281.1716, 280.3992, 282.6034, 281.6749), + c(1.594311, 1.861058, 2.127805, 2.394551, 2.661298), tolerance = 0.0001 ) }) diff --git a/tests/testthat/test-CST_CategoricalEnsCombination.R b/tests/testthat/test-CST_CategoricalEnsCombination.R index fad6cff0a573238064a189d4341fef065c264fd9..2dfc4a036026d002f628018a140637f51466f2b5 100644 --- a/tests/testthat/test-CST_CategoricalEnsCombination.R +++ b/tests/testthat/test-CST_CategoricalEnsCombination.R @@ -2,15 +2,19 @@ context("CSTools::CST_CategoricalEnsCombination tests") ############################################## # dat1 -exp_obs <- lonlat_temp -exp <- exp_obs[[1]] -obs <- exp_obs[[2]] -exp$data <- ClimProjDiags::Subset(exp_obs[[1]]$data, c('member', 'lon', 'lat'), list(1:4, 1:4, 1:4)) -obs$data <- ClimProjDiags::Subset(exp_obs[[2]]$data, c('lon', 'lat'), list(1:4, 1:4)) -exp$lon <- exp$lon[1:4] -exp$lat <- exp$lat[1:4] -obs$lon <- obs$lon[1:4] -obs$lat <- obs$lat[1:4] +dat_exp <- array(abs(rnorm(4*6*3*4*4))*275, dim = c(dataset = 1, member = 4, sdate = 6, + ftime = 3, lat = 4, lon = 4)) +dat_obs <- array(abs(rnorm(6*3*4*4))*275, dim = c(dataset = 1, member = 1, sdate = 6, + ftime = 3, lat = 4, lon = 4)) +lon <- seq(0, 3) +lat <- seq(48, 27) + +coords <- list(lon = lon, lat = lat) + +exp <- list(data = dat_exp, coords = coords) +obs <- list(data = dat_obs, coords = coords) +attr(exp, 'class') <- 's2dv_cube' +attr(obs, 'class') <- 's2dv_cube' # dat2 exp2 <- exp @@ -32,7 +36,7 @@ test_that("Sanity checks", { cal <- CST_CategoricalEnsCombination(exp = exp, obs = obs) expect_equal( length(cal), - 9 + 2 ) expect_equal( as.numeric(dim(cal$data)[c(1, 2)]), @@ -82,4 +86,4 @@ test_that("Sanity checks", { CST_CategoricalEnsCombination(exp = exp2, obs = obs2), "Parameter 'obs' contains NA values", "Parameter 'exp' contains NA values." ) -}) +}) \ No newline at end of file diff --git a/tests/testthat/test-CST_EnsClustering.R b/tests/testthat/test-CST_EnsClustering.R index 104b8ecde8310ae8647f57ef402820b64d16008f..afbe1598d740bc649fc6579abd9effb048044afd 100644 --- a/tests/testthat/test-CST_EnsClustering.R +++ b/tests/testthat/test-CST_EnsClustering.R @@ -1,4 +1,4 @@ -context("Generic tests") +context("CSTools::CST_EnsClustering tests") ############################################## # dat1 @@ -7,31 +7,61 @@ dim(data) <- c(dataset = 2, member = 10, sdate = 4, ftime = 5, lat = 6, lon = 7) lon <- seq(0, 12, 2) lat <- seq(10, 15, 1) -exp <- list(data = data, lat = lat, lon = lon) +coords <- list(lon = lon, lat = lat) +exp <- list(data = data, coords = coords) attr(exp, "class") <- "s2dv_cube" + +# dat2 +exp2 <- exp +exp2$attrs <- list(source_files = 'exp') +exp2$coords <- NULL +exp2_2 <- exp2 +exp2_2$coords <- list(long = seq(1:4), lati = seq(1:4)) ############################################## test_that("1. Input checks", { - # Check error messages + # Check 's2dv_cube' expect_error( CST_EnsClustering(rnorm(2 * 15 * 4 * 5 * 6 * 7)), - "Parameter 'exp' must be of the class 's2dv_cube'" + paste0("Parameter 'exp' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # Check 'exp' object structure + expect_error( + CST_EnsClustering(exp2), + paste0("Parameter 'exp' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + ) + expect_error( + CST_EnsClustering(exp2_2), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package. Latitudes accepted names: 'lat', 'lats', 'latitude',", + " 'y', 'j', 'nav_lat'. Longitudes accepted names: 'lon', 'lons',", + " 'longitude', 'x', 'i', 'nav_lon'.") + ) + expect_error( + EnsClustering(array(rnorm(8400), dim = c(member = 10, sdate = 4, ftime = 5, + lati = 6, loni = 7)), + lat = seq(1:5), lon = seq(1:6)), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package.") ) + # Checks in Analogs function expect_error( CST_EnsClustering(exp, time_moment = "invalid"), "Invalid time_moment" ) - exp$lat <- 1 + exp$coords$lat <- 1 expect_error( CST_EnsClustering(exp), "Incorrect lat length" ) - exp$lon <- 1 - exp$lat <- lat + exp$coords$lon <- 1 + exp$coords$lat <- lat expect_error( CST_EnsClustering(exp), "Incorrect lon length" ) - exp$lon <- lon + exp$coords$lon <- lon }) test_that("2. Output checks", { diff --git a/tests/testthat/test-CST_MultiEOF.R b/tests/testthat/test-CST_MultiEOF.R index d9c46ab1ec06169593c39e72e20c83b4fa503ca6..f4843231cc664f85c586e49862c123f3afcc1005 100644 --- a/tests/testthat/test-CST_MultiEOF.R +++ b/tests/testthat/test-CST_MultiEOF.R @@ -1,77 +1,160 @@ -context("Generic tests") -test_that("Sanity checks and simple use case", { - library(abind) - # Generate simple synthetic data - seq <- 1 : (2 * 3 * 4 * 5 * 6 * 8) - seq3 <- 1 : (2 * 3 * 4 * 4 * 6 * 8) - mod1 <- sin( 0.7 + seq )^2 + cos( seq ^ 2 * 1.22 ) - dim(mod1) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) - mod2 <- sin( seq * 2 ) ^ 3 + cos( seq ^ 2 ) - dim(mod2) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) - mod3 <- cos( 0.5 + seq3 ) + sin ( seq3 ^ 2 * 0.2 ) - dim(mod3) <- c(dataset = 2, member = 3, sdate = 4, ftime = 4, lat = 6, lon = 8) - lon <- seq(0, 35, 5) - lat <- seq(0, 25, 5) - exp1 <- list(data = mod1, lat = lat, lon = lon) - exp2 <- list(data = mod2, lat = lat, lon = lon) - exp3 <- list(data = mod3, lat = lat, lon = lon) - attr(exp1, 'class') <- 's2dv_cube' - attr(exp2, 'class') <- 's2dv_cube' - attr(exp3, 'class') <- 's2dv_cube' - d=as.POSIXct(c("2017/01/01", "2017/01/02", "2017/01/03", "2017/01/04", "2017/01/05", +context("CSTools::CST_MultiEOF tests") + + +############################################## + +# exp1, exp2, exp03 +seq <- 1 : (2 * 3 * 4 * 5 * 6 * 8) +seq3 <- 1 : (2 * 3 * 4 * 4 * 6 * 8) +mod1 <- sin( 0.7 + seq )^2 + cos( seq ^ 2 * 1.22 ) +dim(mod1) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) +mod2 <- sin( seq * 2 ) ^ 3 + cos( seq ^ 2 ) +dim(mod2) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) +mod3 <- cos( 0.5 + seq3 ) + sin ( seq3 ^ 2 * 0.2 ) +dim(mod3) <- c(dataset = 2, member = 3, sdate = 4, ftime = 4, lat = 6, lon = 8) +lon <- seq(0, 35, 5) +lat <- seq(0, 25, 5) +exp1 <- list(data = mod1, coords = list(lat = lat, lon = lon)) +exp2 <- list(data = mod2, coords = list(lat = lat, lon = lon)) +exp03 <- list(data = mod3, coords = list(lat = lat, lon = lon)) +attr(exp1, 'class') <- 's2dv_cube' +attr(exp2, 'class') <- 's2dv_cube' +attr(exp03, 'class') <- 's2dv_cube' +d = as.POSIXct(c("2017/01/01", "2017/01/02", "2017/01/03", "2017/01/04", "2017/01/05", "2018/01/01", "2018/01/02", "2018/01/03", "2018/01/04", "2018/01/05", "2019/01/01", "2019/01/02", "2019/01/03", "2019/01/04", "2019/01/05", "2020/01/01", "2020/01/02", "2020/01/03", "2020/01/04", "2020/01/05")) - - exp1$Dates$start=d - exp2$Dates$start=d - exp3$Dates$start=d + +exp1$attrs$Dates = d +exp2$attrs$Dates = d +exp03$attrs$Dates = d + +# dat3 +exp3 <- exp03 +mod3 <- cos( 0.5 + seq ) + sin( seq ^ 2 * 0.2 ) +dim(mod3) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) +exp3$data <- mod3 +# dat0 +dat0 <- exp1 +dat01 <- exp2 +dat0$coords <- NULL +dat01$coords <- NULL +dat02 <- dat0 +dat03 <- dat01 +dat02$coords <- list(long = seq(1:4), lati = seq(1:4)) +dat03$coords <- list(long = seq(1:4), lati = seq(1:4)) + +############################################## +test_that("1. Input checks", { expect_error( CST_MultiEOF(datalist = 1), - "Elements of the list in parameter 'datalist' must be of the class 's2dv_cube', as output by CSTools::CST_Load." + paste0("Elements of the list in parameter 'datalist' must be of the class ", + "'s2dv_cube', as output by CSTools::CST_Load.") ) + # Check if all dims equal expect_error( - CST_MultiEOF(list(exp1, exp3)), + CST_MultiEOF(list(exp1, exp03)), "Input data fields must all have the same dimensions." ) - mod3 <- cos( 0.5 + seq ) + sin( seq ^ 2 * 0.2 ) - dim(mod3) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) - exp3$data <- mod3 - + # Know spatial coordinates names + expect_error( + CST_MultiEOF(list(dat0, dat01)), + paste0("Parameter 'datalist' must have 'data', 'coords' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + ) expect_error( - CST_MultiEOF(list(exp1, exp2, exp3), lon_lim=c(-250, -245), lat_lim=c(10, 25)), + CST_MultiEOF(list(dat02, dat03)), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package. Latitudes accepted names: 'lat', 'lats', 'latitude',", + " 'y', 'j', 'nav_lat'. Longitudes accepted names: 'lon', 'lons',", + " 'longitude', 'x', 'i', 'nav_lon'.") + ) + expect_error( + MultiEOF(data = array(rnorm(96), dim = c(var = 2, lonss = 8, latss = 6)), + lon = seq(1:7), lat = seq(1:5), lon_dim = 'lonss', lat_dim = 'latss'), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + ) + expect_error( + CST_MultiEOF(list(exp1, exp2, exp3), lon_lim = c(-250, -245), lat_lim = c(10, 25)), "No intersection between longitude bounds and data domain.") +}) - cal <- CST_MultiEOF(list(exp1, exp2, exp3), neof_composed=2) - expect_equal(length(cal), 5) - dimexp=dim(exp1$data) - expect_equal(dim(cal$coeff), c(dimexp["ftime"], dimexp["sdate"], - eof=2, dimexp["dataset"], dimexp["member"])) - expect_equal(dim(cal$variance), c(eof=2, dimexp["dataset"], dimexp["member"])) - expect_equal(dim(cal$eof_pattern), c(var=3, dimexp["lon"], dimexp["lat"], - eof=2, dimexp["dataset"], - dimexp["member"])) - expect_equal(cal$variance[1, 1, 1], 0.2909419, tolerance = .00001) - expect_equal(cal$coeff[2, 1, 1, 1, 1], 0.5414261, tolerance = .00001) - expect_equal(cal$eof_pattern[1, 2, 2, 2, 1, 1], 0.3932484, tolerance = .00001) - - cal <- CST_MultiEOF(list(exp1, exp2, exp3), neof_max=5, neof_composed=2, minvar=0.2) - expect_equal(cal$coeff[2, 1, 1, 1, 1], -0.6117927, tolerance = .00001) - - cal <- CST_MultiEOF(list(exp1, exp2, exp3), lon_lim=c(5, 30), lat_lim=c(10, 25)) - expect_equal(cal$coeff[2, 1, 1, 1, 1], 0.8539488, tolerance = .00001) - expect_equivalent(cal$lon, seq(5, 30, 5)) - expect_equivalent(cal$lat, seq(10, 25, 5)) - cal <- CST_MultiEOF(list(exp1, exp2, exp3), lon_lim=c(350, 15), lat_lim=c(10, 25)) - expect_equivalent(cal$lon, seq(0, 15, 5)) - expect_equivalent(cal$lat, seq(10, 25, 5)) - cal <- CST_MultiEOF(list(exp1, exp2, exp3), lon_lim=c(-355, -345)) - expect_equivalent(cal$lon, seq(5, 15, 5)) +############################################## - exp3$data[1, 1, 1, 1, 1, 1]=NaN +test_that("2. Output checks", { + cal <- CST_MultiEOF(datalist = list(exp1, exp2, exp3), neof_composed=2) + expect_equal( + length(cal), + 5 + ) + dimexp = dim(exp1$data) + expect_equal( + dim(cal$coeff), + c(dimexp["ftime"], dimexp["sdate"], eof=2, dimexp["dataset"], dimexp["member"]) + ) + expect_equal( + dim(cal$variance), + c(eof = 2, dimexp["dataset"], dimexp["member"]) + ) + expect_equal( + dim(cal$eof_pattern), + c(var = 3, dimexp["lon"], dimexp["lat"], eof = 2, + dimexp["dataset"], dimexp["member"]) + ) + expect_equal( + cal$variance[1, 1, 1], + 0.2909419, + tolerance = .00001 + ) + expect_equal( + cal$coeff[2, 1, 1, 1, 1], + 0.5414261, + tolerance = .00001 + ) + expect_equal( + cal$eof_pattern[1, 2, 2, 2, 1, 1], + 0.3932484, + tolerance = .00001 + ) + cal <- CST_MultiEOF(list(exp1, exp2, exp3), neof_max = 5, + neof_composed = 2, minvar = 0.2) + expect_equal( + cal$coeff[2, 1, 1, 1, 1], + -0.6117927, + tolerance = .00001 + ) + cal <- CST_MultiEOF(list(exp1, exp2, exp3), lon_lim = c(5, 30), lat_lim = c(10, 25)) + expect_equal( + cal$coeff[2, 1, 1, 1, 1], + 0.8539488, + tolerance = .00001 + ) + expect_equivalent( + cal$lon, + seq(5, 30, 5) + ) + expect_equivalent( + cal$lat, + seq(10, 25, 5) + ) + cal <- CST_MultiEOF(list(exp1, exp2, exp3), lon_lim = c(350, 15), lat_lim = c(10, 25)) + expect_equivalent( + cal$lon, seq(0, 15, 5) + ) + expect_equivalent( + cal$lat, + seq(10, 25, 5) + ) + cal <- CST_MultiEOF(list(exp1, exp2, exp3), lon_lim = c(-355, -345)) + expect_equivalent( + cal$lon, + seq(5, 15, 5) + ) + exp3$data[1, 1, 1, 1, 1, 1] = NaN expect_error( - CST_MultiEOF(list(exp1, exp3), neof_max=8, neof_composed=2), + CST_MultiEOF(list(exp1, exp3), neof_max = 8, neof_composed=2), "Input data contain NA values." ) }) diff --git a/tests/testthat/test-CST_MultiMetric.R b/tests/testthat/test-CST_MultiMetric.R index 6914058581485b63d1ccb59fa7d271ab6f4d9bdd..5c45e6a5da6590f7304920621e9efb67579809d8 100644 --- a/tests/testthat/test-CST_MultiMetric.R +++ b/tests/testthat/test-CST_MultiMetric.R @@ -1,91 +1,107 @@ -context("Generic tests") -test_that("basic use case", { - mod <- 1 : (2 * 3 * 4 * 5 * 6 * 8) - dim(mod) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) - obs <- 1 : (1 * 1 * 4 * 5 * 6 * 8) - dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 8) - lon <- seq(0, 30, 5) - lat <- seq(0, 30, 5) - exp <- list(data = mod, lat = lat, lon = lon) - obs <- list(data = obs, lat = lat, lon = lon) - attr(exp, 'class') <- 's2dv_cube' - attr(obs, 'class') <- 's2dv_cube' - - result <- list(data = list(corr = array(rep(1, 3* 48), - dim = c(nexp = 3, nobs = 1, - lat = 6, lon = 8)), - p.val = array(rep(0, 3 * 48), dim = c(nexp = 3, nobs = 1, - lat = 6, lon = 8)), - conf.lower = array(rep(1, 3* 48), - dim = c(nexp = 3, nobs = 1, - lat = 6, lon = 8)), - conf.upper = array(rep(1, 3* 48), - dim = c(nexp = 3, nobs = 1, - lat = 6, lon = 8))), - lat = lat, lon = lon) - attr(result, 'class') <- 's2dv_cube' - expect_equal(CST_MultiMetric(exp = exp, obs = obs), result) - - exp2 <- exp - exp2$data[1, 1, 1, 2, 1, 1] = NA - res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rms') - expect_equal(length(res), 3) - expect_equal(dim(res$data$rms), - c(nexp = 3, nobs = 1, lat = 6, lon = 8)) - res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rms', - multimodel = FALSE) - expect_equal(dim(res$data$rms), - c(nexp = 2, nobs = 1, lat = 6, lon = 8)) - expect_equal(length(res$data), 3) - res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rmsss') - expect_equal(dim(res$data$rmsss), - c(nexp = 3, nobs = 1, lat = 6, lon = 8)) - res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rmsss', multimodel = FALSE) - expect_equal(dim(res$data$rmsss), - c(nexp = 2, nobs = 1, lat = 6, lon = 8)) - }) +context("CSTools::CST_MultiMetric") + +################################################################################ + +# dat +mod <- 1 : (2 * 3 * 4 * 5 * 6 * 8) +dim(mod) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) +obs <- 1 : (1 * 1 * 4 * 5 * 6 * 8) +dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 8) +lon <- seq(0, 30, 5) +lat <- seq(0, 30, 5) +coords <- list(lon = lon, lat = lat) +exp <- list(data = mod, coords = coords) +obs <- list(data = obs, coords = coords) +attr(exp, 'class') <- 's2dv_cube' +attr(obs, 'class') <- 's2dv_cube' +################################################################################ -test_that("Sanity checks", { +test_that("1. Sanity checks", { expect_error( CST_MultiMetric(exp = 1), paste0("Parameter 'exp' and 'obs' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.")) - mod <- 1 : (2 * 3 * 4 * 5 * 6 * 8) - dim(mod) <- c(dataset = 2, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 8) - obs <- 1 : (1 * 1 * 4 * 5 * 6 * 8) - dim(obs) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 8) - lon <- seq(0, 30, 5) - lat <- seq(0, 30, 5) - exp <- list(data = mod, lat = lat, lon = lon) - obs <- list(data = obs, lat = lat, lon = lon) - attr(exp, 'class') <- 's2dv_cube' - attr(obs, 'class') <- 's2dv_cube' - - + "as output by CSTools::CST_Load.") + ) expect_error( CST_MultiMetric(exp = exp, obs = obs, metric = 1), paste0("Parameter 'metric' must be a character string indicating one ", - "of the options: 'correlation', 'rms', 'rmsss' or 'rpss'")) + "of the options: 'correlation', 'rms', 'rmsss' or 'rpss'") + ) expect_error( CST_MultiMetric(exp = exp, obs = obs, metric = NA), - "missing value where TRUE/FALSE needed") + "missing value where TRUE/FALSE needed" + ) expect_error( CST_MultiMetric(exp = exp, obs = obs, metric = NULL), - "argument is of length zero") + "argument is of length zero" + ) expect_error( - CST_MultiMetric(exp = exp, obs = obs, metric = "correlation", - multimodel = NULL), - "Parameter 'multimodel' must be a logical value.") + CST_MultiMetric(exp = exp, obs = obs, metric = "correlation", multimodel = NULL), + "Parameter 'multimodel' must be a logical value." + ) expect_error( - MultiMetric(exp = lonlat_temp$exp, obs = lonlat_temp$obs, metric = "rpss", - multimodel = TRUE), - "Element 'data' from parameters 'exp' and 'obs' should have dimmension names.") -exp <- lonlat_temp$exp$data[1,,,,,] -obs <- lonlat_temp$obs$data[1,,,,,] + MultiMetric(exp = array(rnorm(10)), obs = array(rnorm(10)), metric = "rpss", + multimodel = TRUE), + "Element 'data' from parameters 'exp' and 'obs' should have dimension names." + ) expect_error( - MultiMetric(exp = exp, obs = obs, metric = "rpss", - multimodel = TRUE), - paste0("Dimension names of element 'data' from parameters 'exp' and ", - "'obs' should have the same name dimmension.")) + MultiMetric(exp = array(rnorm(10), dim = c(sdate = 10)), + obs = array(rnorm(10), dim = c(time = 10)), + metric = "rpss", multimodel = TRUE), + paste0("Dimension names of element 'data' from parameters 'exp' and ", + "'obs' should have the same name dimmension.") + ) }) + +################################################################################ + +test_that("2. Basic use case", { + + corr <- array(rep(1, 3* 48), dim = c(nexp = 3, nobs = 1, lat = 6, lon = 8)) + p.val <- array(rep(0, 3 * 48), dim = c(nexp = 3, nobs = 1, lat = 6, lon = 8)) + conf.lower <- array(rep(1, 3* 48), dim = c(nexp = 3, nobs = 1, lat = 6, lon = 8)) + conf.upper = array(rep(1, 3* 48), dim = c(nexp = 3, nobs = 1, lat = 6, lon = 8)) + + data <- list(corr = corr, p.val = p.val, conf.lower = conf.lower, conf.upper = conf.upper) + result <- list(data = data, coords = coords) + attr(result, 'class') <- 's2dv_cube' + + expect_equal( + CST_MultiMetric(exp = exp, obs = obs), + result + ) + + exp2 <- exp + exp2$data[1, 1, 1, 2, 1, 1] <- NA + res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rms') + + expect_equal( + length(res), + 2 + ) + expect_equal( + dim(res$data$rms), + c(nexp = 3, nobs = 1, lat = 6, lon = 8) + ) + res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rms', + multimodel = FALSE) + expect_equal( + dim(res$data$rms), + c(nexp = 2, nobs = 1, lat = 6, lon = 8) + ) + expect_equal( + length(res$data), + 3 + ) + res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rmsss') + expect_equal( + dim(res$data$rmsss), + c(nexp = 3, nobs = 1, lat = 6, lon = 8) + ) + res <- CST_MultiMetric(exp = exp, obs = obs, metric = 'rmsss', multimodel = FALSE) + expect_equal( + dim(res$data$rmsss), + c(nexp = 2, nobs = 1, lat = 6, lon = 8) + ) +}) \ No newline at end of file diff --git a/tests/testthat/test-CST_MultivarRMSE.R b/tests/testthat/test-CST_MultivarRMSE.R new file mode 100644 index 0000000000000000000000000000000000000000..c4ca5d5fb2491bbc4b5759c9fe1abd97719b6ab4 --- /dev/null +++ b/tests/testthat/test-CST_MultivarRMSE.R @@ -0,0 +1,192 @@ +context("CSTools::CST_MultivarRMSE tests") + +# dat1 +set.seed(1) +mod1 <- abs(rnorm(1 * 3 * 4 * 5 * 6 * 7)) +set.seed(2) +mod2 <- abs(rnorm(1 * 3 * 4 * 5 * 6 * 7)) +dim(mod1) <- c(datasets = 1, members = 3, sdates = 4, ftimes = 5, lat = 6, lon = 7) +dim(mod2) <- c(datasets = 1, members = 3, sdates = 4, ftimes = 5, lat = 6, lon = 7) +set.seed(1) +obs1 <- abs(rnorm(1 * 1 * 4 * 5 * 6 * 7)) +set.seed(2) +obs2 <- abs(rnorm(1 * 1 * 4 * 5 * 6 * 7)) +dim(obs1) <- c(datasets = 1, members= 1, sdates = 4, ftimes = 5, lat = 6, lon = 7) +dim(obs2) <- c(datasets = 1, members = 1, sdates = 4, ftimes = 5, lat = 6, lon = 7) +lon <- seq(0, 30, 5) +lat <- seq(0, 25, 5) +coords <- list(lat = lat, lon = lon) + +exp1 <- list(data = mod1, coords = coords, + attrs = list(Datasets = "EXP1", source_files = "file1", + Variable = list(varName = 'pre'))) +exp2 <- list(data = mod2, coords = coords, + attrs = list(Datasets = "EXP2", source_files = "file2", + Variable = list(varName = 'tas'))) +obs1_1 <- list(data = obs1, coords = coords, + attrs = list(Datasets = "OBS1", source_files = "file1", + Variable = list(varName = 'pre'))) +obs2_1 <- list(data = obs2, coords = coords, + attrs = list(Datasets = "OBS2", source_files = "file2", + Variable = list(varName = 'tas'))) + +attr(exp1, 'class') <- 's2dv_cube' +attr(exp2, 'class') <- 's2dv_cube' +attr(obs1_1, 'class') <- 's2dv_cube' +attr(obs2_1, 'class') <- 's2dv_cube' + +anom1 <- CST_Anomaly(exp1, obs1_1, cross = TRUE, memb = TRUE, dim_anom = 'sdates', memb_dim = 'members',dat_dim = c('datasets', 'members')) +anom2 <- CST_Anomaly(exp2, obs2_1, cross = TRUE, memb = TRUE, dim_anom = 'sdates', memb_dim = 'members', dat_dim = c('datasets', 'members')) + +ano_exp <- list(anom1$exp, anom2$exp) +ano_obs <- list(anom1$obs, anom2$obs) + +# dat2 + +dim(mod1) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) +dim(mod2) <- c(dataset = 1, member = 3, sdate = 4, ftime = 5, lat = 6, lon = 7) +dim(obs1) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) +dim(obs2) <- c(dataset = 1, member = 1, sdate = 4, ftime = 5, lat = 6, lon = 7) + +exp1 <- list(data = mod1, coords = coords, + attrs = list(Datasets = "EXP1", source_files = "file1", + Variable = list(varName = 'pre'))) +exp2 <- list(data = mod2, coords = coords, + attrs = list(Datasets = "EXP2", source_files = "file2", + Variable = list(varName = 'tas'))) +obs1 <- list(data = obs1, coords = coords, + attrs = list(Datasets = "OBS1", source_files = "file1", + Variable = list(varName = 'pre'))) +obs2 <- list(data = obs2, coords = coords, + attrs = list(Datasets = "OBS2", source_files = "file2", + Variable = list(varName = 'tas'))) + +attr(exp1, 'class') <- 's2dv_cube' +attr(exp2, 'class') <- 's2dv_cube' +attr(obs1, 'class') <- 's2dv_cube' +attr(obs2, 'class') <- 's2dv_cube' + +anom1 <- CST_Anomaly(exp1, obs1, cross = TRUE, memb = TRUE) +anom2 <- CST_Anomaly(exp2, obs2, cross = TRUE, memb = TRUE) + +ano_exp2 <- list(anom1$exp, anom2$exp) +ano_obs2 <- list(anom1$obs, anom2$obs) + +############################################## +test_that("1. Input checks", { + # s2dv_cube + expect_error( + CST_MultivarRMSE(exp = 1, obs = 1), + "Parameters 'exp' and 'obs' must be lists of 's2dv_cube' objects" + ) + # exp and obs + expect_error( + CST_MultivarRMSE(exp = exp1, obs = exp1), + paste0("Elements of the list in parameter 'exp' must be of the class ", + "'s2dv_cube', as output by CSTools::CST_Load.") + ) + # exp and obs + expect_error( + CST_MultivarRMSE(exp = c(ano_exp, ano_exp), obs = ano_obs), + "Parameters 'exp' and 'obs' must be of the same length." + ) + # memb_dim + expect_error( + CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, memb_dim = NULL), + "Parameter 'memb_dim' cannot be NULL." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, memb_dim = 1), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs), + "Dimension names of element 'data' from parameters 'exp' and 'obs' should be equal." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' or in 'obs' dimension." + ) + # dat_dim + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, dat_dim = 1), + "Parameter 'dat_dim' must be a character string." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, dat_dim = 'dats'), + "Parameter 'dat_dim' is not found in 'exp' or in 'obs' dimension." + ) + # ftime_dim + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, ftime_dim = 1), + "Parameter 'ftime_dim' must be a character string." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, ftime_dim = 'ftimes'), + "Parameter 'ftime_dim' is not found in 'exp' or in 'obs' dimension." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, ftime_dim = NULL), + "Parameter 'ftime_dim' cannot be NULL." + ) + # sdate_dim + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, sdate_dim = 1), + "Parameter 'sdate_dim' must be a character string." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, sdate_dim = 'sdates'), + "Parameter 'sdate_dim' is not found in 'exp' or in 'obs' dimension." + ) + expect_error( + CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, sdate_dim = NULL), + "Parameter 'sdate_dim' cannot be NULL." + ) +}) + +############################################## + +test_that("2. Output checks", { + res1 <- CST_MultivarRMSE(exp = ano_exp2, obs = ano_obs2, weight = c(1, 2)) + res2 <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight = c(1, 2), + dat_dim = 'datasets', ftime_dim = 'ftimes', + memb_dim = 'members', sdate_dim = 'sdates') + # res3 <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight = c(1, 2), + # dat_dim = NULL, ftime_dim = 'ftimes', + # memb_dim = 'members', sdate_dim = 'sdates') + expect_equal( + names(res1), + c('data', 'coords', 'attrs') + ) + expect_equal( + dim(res1$data), + dim(res2$data) + ) + expect_equal( + dim(res1$data), + c(nexp = 1, nobs = 1, lat = 6, lon = 7) + ) + expect_equal( + res1$data, + res2$data + ) + expect_equal( + as.vector(res1$data)[1:5], + c(0.9184747, 1.0452328, 1.7559577, 0.7936543, 0.9163216), + tolerance = 0.0001 + ) + expect_equal( + as.vector(res2$data)[1:5], + c(0.9184747, 1.0452328, 1.7559577, 0.7936543, 0.9163216), + tolerance = 0.0001 + ) + # expect_equal( + # dim(res3$data), + # c(datasets = 1, lat = 6, lon = 7) + # ) + # expect_equal( + # as.vector(res3$data)[1:5], + # c(0.9184747, 1.0452328, 1.7559577, 0.7936543, 0.9163216), + # tolerance = 0.0001 + # ) +}) diff --git a/tests/testthat/test-CST_ProxiesAttractor.R b/tests/testthat/test-CST_ProxiesAttractor.R new file mode 100644 index 0000000000000000000000000000000000000000..65831b24a9fdd4e7beef7c625ed4b45577c44676 --- /dev/null +++ b/tests/testthat/test-CST_ProxiesAttractor.R @@ -0,0 +1,29 @@ +context("CSTools::CST_ProxiesAttractor tests") + +############################################## + +# dat1 +data <- rnorm(2 * 10 * 4 * 5 * 6 * 7) +dim(data) <- c(dataset = 2, member = 10, + sdate = 4, ftime = 5, lat = 6, lon = 7) +lon <- seq(0, 12, 2) +lat <- seq(10, 15, 1) +coords <- list(lon = lon, lat = lat) +exp1 <- list(data = data, coords = coords) +attr(exp1, "class") <- "s2dv_cube" + +############################################## +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_ProxiesAttractor(rnorm(2 * 15 * 4 * 5 * 6 * 7)), + paste0("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # Check quanti + expect_error( + CST_ProxiesAttractor(data = exp1, quanti = NULL), + paste0("Parameter 'quanti' cannot be NULL.") + ) +}) +############################################## \ No newline at end of file diff --git a/tests/testthat/test-CST_QuantileMapping.R b/tests/testthat/test-CST_QuantileMapping.R index 35f359480316caa1fb27a0869ff30be0b6f4a1aa..0b2890f3eb90d370d381ad629416f82826640ff7 100644 --- a/tests/testthat/test-CST_QuantileMapping.R +++ b/tests/testthat/test-CST_QuantileMapping.R @@ -50,13 +50,23 @@ obs3_2$data[1] <- NA res3_2$data[1] <- 0 # dat4 -exp4 <- lonlat_temp$exp -obs4 <- lonlat_temp$obs -exp4$data <- ClimProjDiags::Subset(exp4$data, c('member', 'lon', 'lat'), list(1:4, 1:4, 1:4)) -obs4$data <- ClimProjDiags::Subset(obs4$data, c('lon', 'lat'), list(1:4, 1:4)) +lon <- seq(0, 3) +lat <- seq(48, 45) +set.seed(1) +exp4 <- NULL +exp4$data <- array(runif(1152)*280, dim = c(dataset = 1, member = 4, sdate = 6, + ftime = 3, lat = 4, lon = 4)) +exp4$coords <- list(lon = lon, lat = lat) +class(exp4) <- 's2dv_cube' +set.seed(2) +obs4 <- NULL +obs4$data <- array(runif(288)*280, dim = c(dataset = 1, member = 1, sdate = 6, + ftime = 3, lat = 4, lon = 4)) +obs4$coords <- list(lon = lon, lat = lat) +class(obs4) <- 's2dv_cube' exp_cor4 <- exp4 -exp_cor4$data <- exp_cor4$data[,,5:6,,,] - +exp_cor4$data <- exp_cor4$data[, , 5:6, , , ] +class(exp_cor4) <- 's2dv_cube' # dat5 exp5 <- exp4 @@ -83,16 +93,24 @@ obs6_1$data[2] <- NA exp6_1 <- exp6 -exp6_1$data[1,,,1,1,1] <- NA +exp6_1$data[1, , , 1, 1, 1] <- NA exp_cor6_1 <- exp6_1 exp_cor6_1$data <- ClimProjDiags::Subset(exp_cor6_1$data, 'sdate', 1) exp_cor6_2 <- exp6 exp_cor6_2$data <- ClimProjDiags::Subset(exp_cor6_2$data, 'member', 1:2) +# # dat7 +# exp7 <- 1 : c(1 * 1 * 6 * 3 * 8 * 8) +# dim(exp7) <- c(dataset = 1, sdate = 6, ftime = 3, +# lat = 8, lon = 8) + +# obs7 <- 101 : c(100 + 1 * 1 * 6 * 3 * 8 * 8) +# dim(obs7) <- c(dataset = 1, sdate = 6, ftime = 3, +# lat = 8, lon = 8) + ############################################## test_that("1. Sanity checks", { - # s2dv_cube expect_error( CST_QuantileMapping(exp = 1), @@ -166,7 +184,7 @@ test_that("2. dat2, dat3 and dat4", { ) expect_equal( length(CST_QuantileMapping(exp4, obs4, exp_cor4)), - 9 + 2 ) }) @@ -174,16 +192,16 @@ test_that("2. dat2, dat3 and dat4", { test_that("3. dat5", { expect_equal( - dim(CST_QuantileMapping(exp5, obs5)$data), - dim(res5$data) + dim(CST_QuantileMapping(exp5, obs5)$data), + dim(res5$data) ) expect_equal( - dim(CST_QuantileMapping(exp5, obs5)$data), - dim(res5$data) + dim(CST_QuantileMapping(exp5, obs5)$data), + dim(res5$data) ) expect_equal( - dim(CST_QuantileMapping(exp5, obs5, sdate_dim = "ftime")$data), - dim(res5_1$data) + dim(CST_QuantileMapping(exp5, obs5, sdate_dim = "ftime")$data), + dim(res5_1$data) ) }) @@ -191,23 +209,35 @@ test_that("3. dat5", { test_that("4. dat6", { expect_equal( - CST_QuantileMapping(exp6, obs6, window_dim = 'window'), - CST_QuantileMapping(exp6, obs6, window_dim = 'window', na.rm = TRUE) + CST_QuantileMapping(exp6, obs6, window_dim = 'window'), + CST_QuantileMapping(exp6, obs6, window_dim = 'window', na.rm = TRUE) ) expect_equal( - dim(CST_QuantileMapping(exp6, obs6_1, window_dim = 'window')$data), - c(member = 4, sdate = 6, dataset = 1, ftime = 3, lat = 4, lon = 4) + dim(CST_QuantileMapping(exp6, obs6_1, window_dim = 'window')$data), + c(member = 4, sdate = 6, dataset = 1, ftime = 3, lat = 4, lon = 4) ) expect_equal( - sum(is.na(CST_QuantileMapping(exp6_1, obs6_1, exp_cor = exp_cor6_1, window_dim = 'window', na.rm = TRUE)$data)), + sum(is.na(CST_QuantileMapping(exp6_1, obs6_1, exp_cor = exp_cor6_1, + window_dim = 'window', na.rm = TRUE)$data)), sum(is.na(exp_cor6_1$data)) ) expect_equal( - dim(CST_QuantileMapping(exp6, obs6_1, exp_cor6_1, window_dim = 'window', na.rm = T)$data), - c(member = 4, sdate = 1, dataset = 1, ftime = 3, lat = 4, lon = 4) + dim(CST_QuantileMapping(exp6, obs6_1, exp_cor6_1, window_dim = 'window', + na.rm = T)$data), + c(member = 4, sdate = 1, dataset = 1, ftime = 3, lat = 4, lon = 4) ) expect_equal( - dim(CST_QuantileMapping(exp6, obs6_1, exp_cor6_2, window_dim = 'window')$data), + dim(CST_QuantileMapping(exp6, obs6_1, exp_cor6_2, + window_dim = 'window')$data), c(member = 2, sdate = 6, dataset = 1, ftime = 3, lat = 4, lon = 4) ) }) + +############################################## + +# test_that("5. dat7", { +# expect_equal( +# dim(QuantileMapping(exp7, obs7, memb_dim = NULL)), +# c(sdate = 6, dataset = 1, ftime = 3, lat = 8, lon = 8) +# ) +# }) \ No newline at end of file diff --git a/tests/testthat/test-CST_RFSlope.R b/tests/testthat/test-CST_RFSlope.R new file mode 100644 index 0000000000000000000000000000000000000000..f08d3a591443fb5a3a79cd2bd89d8058b2441263 --- /dev/null +++ b/tests/testthat/test-CST_RFSlope.R @@ -0,0 +1,32 @@ +context("CSTools::CST_RFSlope tests") + +############################################## +# dat1 +data <- rnorm(2 * 10 * 4 * 5 * 6 * 7) +dim(data) <- c(dataset = 2, member = 10, + sdate = 4, ftime = 5, lat = 6, lon = 7) +lon <- seq(0, 12, 2) +lat <- seq(10, 15, 1) +coords <- list(lon = lon, lat = lat) +exp <- list(data = data, coords = coords) +attr(exp, "class") <- "s2dv_cube" + +# dat2 +exp2_3 <- exp +names(dim(exp2_3$data)) <- c("dataset", "member", "sdate", "ftime", "lati", "loni") + +############################################## +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_RFSlope(rnorm(2 * 15 * 4 * 5 * 6 * 7)), + paste0("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # Check dimensions + expect_error( + CST_RFSlope(exp2_3), + paste0("Spatial dimension names do not match any of the names accepted by ", + "the package.") + ) +}) diff --git a/tests/testthat/test-CST_RFTemp.R b/tests/testthat/test-CST_RFTemp.R index 581e04a3535972a8d2c0f9268d448d2b348d3f8a..325b260becf999915a952fca004c4674335d1201 100644 --- a/tests/testthat/test-CST_RFTemp.R +++ b/tests/testthat/test-CST_RFTemp.R @@ -2,39 +2,96 @@ context("CSTools::CST_RFTemp tests") ############################################## -test_that("Sanity checks and simple use cases", { - # Generate simple synthetic data - t <- rnorm(2 * 6 * 6 * 2 * 3 * 4) * 10 + 273.15 + 10 - dim(t) <- c(dataset = 2, member = 2, sdate = 3, ftime = 4, lat = 6, lon = 6) - lon <- seq(4, 9, 1) - lat <- seq(42, 47, 1) - exp <- list(data = t, lat = lat, lon = lon) - o <- runif(29 * 29) * 3000 - dim(o) <- c(lat = 29, lon = 29) - lon <- seq(3.125, 10.125, 0.25) - 100 - lat <- seq(41.125, 48.125, 0.25) - 60 - oro <- list(data = o, lat = lat, lon = lon) - attr(oro, "class") <- "s2dv_cube" +# dat1 +data <- rnorm(2 * 10 * 4 * 5 * 6 * 7) +dim(data) <- c(dataset = 2, member = 10, + sdate = 4, ftime = 5, lat = 6, lon = 7) +lon <- seq(0, 12, 2) +lat <- seq(10, 15, 1) +coords <- list(lon = lon, lat = lat) +exp1 <- list(data = data, coords = coords) +attr(exp1, "class") <- "s2dv_cube" - expect_error( - res <- CST_RFTemp(exp, oro, xlim = c(1, 3), ylim = c(1, 3), time_dim = 'ftime'), - paste("Parameter 'data' must be of the class", - "'s2dv_cube', as output by CSTools::CST_Load.")) - attr(exp, "class") <- "s2dv_cube" +# dat2 +exp2 <- exp1 +exp2$attrs <- list(source_files = 'exp') +exp2$coords <- NULL +exp2_2 <- exp2 +exp2_2$coords <- list(long = seq(1:4), lati = seq(1:4)) + +# dat +t <- rnorm(2 * 6 * 6 * 2 * 3 * 4) * 10 + 273.15 + 10 +dim(t) <- c(dataset = 2, member = 2, sdate = 3, ftime = 4, lat = 6, lon = 6) +lon <- seq(4, 9, 1) +lat <- seq(42, 47, 1) +coords <- list(lon = lon, lat = lat) +exp <- list(data = t, coords = coords) +attr(exp, "class") <- "s2dv_cube" +o <- runif(29 * 29) * 3000 +dim(o) <- c(lat = 29, lon = 29) +lon <- seq(3.125, 10.125, 0.25) - 100 +lat <- seq(41.125, 48.125, 0.25) - 60 +coords <- list(lon = lon, lat = lat) +oro1 <- list(data = o, coords = coords) +attr(oro1, "class") <- "s2dv_cube" + +oro <- oro1 +oro$coords$lon <- oro$coords$lon + 100 +oro$coords$lat <- oro$coords$lat + 60 +############################################## +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_RFTemp(rnorm(2 * 15 * 4 * 5 * 6 * 7)), + paste0("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + expect_error( + CST_RFTemp(data = exp1, oro = rnorm(2 * 15 * 4 * 5 * 6 * 7)), + paste0("Parameter 'oro' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + expect_error( + CST_RFTemp(data = exp1, oro = exp1, delta = rnorm(2 * 15 * 4 * 5 * 6 * 7)), + paste0("Parameter 'delta' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # Check 's2dv_cube' structure + expect_error( + CST_RFTemp(exp2, oro = exp1), + paste0("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + ) expect_error( - res <- CST_RFTemp(exp, oro, xlim = c(1, 3), ylim = c(1, 3), time_dim = 'ftime'), + CST_RFTemp(oro = exp2, data = exp1), + paste0("Parameter 'oro' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + ) + # Check coordinates + expect_error( + CST_RFTemp(exp2_2, oro = exp1), + paste0("Spatial coordinate names of 'data' do not match any of the names ", + "accepted by the package.") + ) + expect_error( + CST_RFTemp(exp1, oro = exp2_2), + paste0("Spatial coordinate names of 'oro' do not match any of the names ", + "accepted by the package.") + ) + expect_error( + res <- CST_RFTemp(exp, oro1, xlim = c(1, 3), ylim = c(1, 3), time_dim = 'ftime'), "Orography not available for selected area" ) - - oro$lon <- oro$lon + 100 - oro$lat <- oro$lat + 60 - expect_error( res <- CST_RFTemp(exp, oro, xlim = c(3, 8), ylim = c(43, 46), time_dim = 'ftime'), "Downscaling area not contained in input data" ) +}) + +############################################## +test_that("2. Output checks", { expect_warning( resl <- CST_RFTemp(exp, oro, lapse = 6.5), "Selected time dim: ftime" diff --git a/tests/testthat/test-CST_RFWeights.R b/tests/testthat/test-CST_RFWeights.R new file mode 100644 index 0000000000000000000000000000000000000000..68b45830fd751f7d1c820ef83e7563e1c8f8d40d --- /dev/null +++ b/tests/testthat/test-CST_RFWeights.R @@ -0,0 +1,55 @@ +context("CSTools::CST_RFTWeights tests") + +############################################## +# dat1 +data <- rnorm(2 * 10 * 4 * 5 * 6 * 6) +dim(data) <- c(dataset = 2, member = 10, + sdate = 4, ftime = 5, lats = 6, lons = 6) +lon <- seq(0, 11, 2) +lat <- seq(10, 15, 1) +coords <- list(longitude = lon, latitude = lat) +exp <- list(data = data, coords = coords) +attr(exp, "class") <- "s2dv_cube" + +# dat2 +exp2_2 <- exp +exp2_2$coords <- NULL +exp2_3 <- exp +names(exp2_3$coords) <- c("lati", "loni") + +############################################## +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_RFWeights(rnorm(2 * 15 * 4 * 5 * 6 * 7), lon = lon, lat = lat), + paste0("Parameter 'climfile' is expected to be a character string indicating", + " the path to the files or an object of class 's2dv_cube'.") + ) + # Check object structure + expect_error( + CST_RFWeights(exp2_2, lon = lon, lat = lat, nf = 3), + paste0("Parameter 'climfile' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + ) + # Check coordinates + expect_error( + CST_RFWeights(exp2_3, lon = lon, lat = lat, nf = 3), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + ) +}) + +############################################## + +test_that("2. Output checks", { + res <- CST_RFWeights(climfile = exp, nf = 3, lon, lat, lonname = 'lons', + latname = 'lats', fsmooth = TRUE) + expect_equal( + names(res$coords), + c("longitude", "latitude") + ) + expect_equal( + names(dim(res$data)), + c("lons", "lats", "dataset", "member", "sdate", "ftime" ) + ) +}) \ No newline at end of file diff --git a/tests/testthat/test-CST_RainFARM.R b/tests/testthat/test-CST_RainFARM.R index d9414925dc4a4d1a48060022e02c93e9a9f430ed..c014cfdc68e2fdd046efe7221f95264ff74e1795 100644 --- a/tests/testthat/test-CST_RainFARM.R +++ b/tests/testthat/test-CST_RainFARM.R @@ -1,12 +1,58 @@ -context("Generic tests") -test_that("Sanity checks and simple use cases", { +context("CSTools::CST_RFSlope tests") + +############################################## +# dat1 +data <- rnorm(2 * 10 * 4 * 5 * 6 * 7) +dim(data) <- c(dataset = 2, member = 10, + sdate = 4, ftime = 5, lat = 6, lon = 7) +lon <- seq(0, 12, 2) +lat <- seq(10, 15, 1) +coords <- list(lon = lon, lat = lat) +exp <- list(data = data, coords = coords) +attr(exp, "class") <- "s2dv_cube" + +# dat2 +exp2 <- exp +exp2$attrs <- list(source_files = 'exp') +exp2$coords <- NULL +exp2_2 <- exp2 +exp2_2$coords <- list(long = seq(1:4), lati = seq(1:4)) +exp2_3 <- exp +names(dim(exp2_3$data)) <- c("dataset", "member", "sdate", "ftime", "lati", "loni") + +############################################## +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_RainFARM(rnorm(2 * 15 * 4 * 5 * 6 * 7)), + paste0("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # Check 'exp' object structure + expect_error( + CST_RainFARM(exp2), + paste0("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + ) + # Check coordinates + expect_error( + CST_RainFARM(exp2_2), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + ) + # Check dimensions + expect_error( + CST_RainFARM(exp2_3), + paste0("Spatial dimension names do not match any of the names accepted by ", + "the package.") + ) # Generate simple synthetic data # 4x5 in space, 2 members, 3 sdates, 6 ftime r <- exp(rnorm(1 * 2 * 3 * 6 * 5 * 4)) dim(r) <- c(dataset = 1, member = 2, sdate = 3, ftime = 6, lat = 5, lon = 4) lon <- seq(0, 6, 2) lat <- seq(10, 18, 2) - exp <- list(data = r, lat = lat, lon = lon) + exp <- list(data = r, coords = list(lat = lat, lon = lon)) attr(exp, 'class') <- 's2dv_cube' expect_warning( @@ -17,7 +63,7 @@ test_that("Sanity checks and simple use cases", { r <- exp(rnorm(1 * 2 * 3 * 6 * 4 * 4)) dim(r) <- c(dataset = 1, member = 2, sdate = 3, ftime = 6, lat = 4, lon = 4) lat <- seq(10, 16, 2) - exp <- list(data = r, lat = lat, lon = lon) + exp <- list(data = r, coords = list(lat = lat, lon = lon)) attr(exp, 'class') <- 's2dv_cube' expect_warning( @@ -26,29 +72,42 @@ test_that("Sanity checks and simple use cases", { ) expect_error( res <- CST_RainFARM(exp, nf=8, weights=array(0,dim=c(2,2))), - "Parameter 'weights' must have dimension names when it is not a scalar." + paste0("Parameters 'lon_dim' and 'lat_dim' do not match with 'weights' ", + "dimension names.") ) +}) + +############################################## + +test_that("2. Simple use case", { + r <- exp(rnorm(1 * 2 * 3 * 6 * 4 * 4)) + dim(r) <- c(dataset = 1, member = 2, sdate = 3, ftime = 6, lat = 4, lon = 4) + lat <- seq(10, 16, 2) + lon <- seq(0, 6, 2) + exp <- list(data = r, coords = list(lat = lat, lon = lon)) + attr(exp, 'class') <- 's2dv_cube' - dimexp=dim(exp$data) + dimexp = dim(exp$data) - res <- CST_RainFARM(exp, nf=8, time_dim=c("ftime", "sdate"), slope=1.7, nens=2) + res <- CST_RainFARM(exp, nf = 8, time_dim = c("ftime", "sdate"), + slope = 1.7, nens = 2) expect_equal(dim(res$data), c(dimexp["dataset"], dimexp["member"], realization = 2, dimexp["sdate"], dimexp["ftime"], dimexp["lat"] * 8, dimexp["lon"] * 8)) - expect_equivalent(length(res$lon), dimexp["lon"] * 8) - expect_equivalent(length(res$lat), dimexp["lat"] * 8) + expect_equivalent(length(res$coords$lon), dimexp["lon"] * 8) + expect_equivalent(length(res$coords$lat), dimexp["lat"] * 8) - res <- CST_RainFARM(exp, nf=8, time_dim=c("ftime", "sdate"), - nens=2, drop_realization_dim=TRUE) + res <- CST_RainFARM(exp, nf = 8, time_dim = c("ftime", "sdate"), + nens = 2, drop_realization_dim = TRUE) expect_equal(dim(res$data), c(dimexp["dataset"], dimexp["member"] * 2, dimexp["sdate"], dimexp["ftime"], dimexp["lat"] * 8, dimexp["lon"] * 8)) - res <- CST_RainFARM(exp, nf=8, time_dim=c("ftime", "sdate"), slope=1.7, - nens=2, nproc=2, fsmooth=FALSE) + res <- CST_RainFARM(exp, nf = 8, time_dim = c("ftime", "sdate"), slope = 1.7, + nens = 2, nproc = 2, fsmooth = FALSE) expect_equal(dim(res$data), c(dimexp["dataset"], dimexp["member"], realization = 2, dimexp["sdate"], dimexp["ftime"], dimexp["lat"] * 8, @@ -60,11 +119,11 @@ test_that("Sanity checks and simple use cases", { expect_equivalent(agg(res$data[1,1,1,1,1,,], 4), exp$data[1,1,1,1,,]) - res <- CST_RainFARM(exp, nf=8, time_dim=c("ftime", "sdate"), - nens=2, nproc=2, fglob=TRUE) + res <- CST_RainFARM(exp, nf = 8, time_dim = c("ftime", "sdate"), + nens = 2, nproc = 2, fglob = TRUE) expect_equal(mean(agg(res$data[1,1,1,1,1,,], 4)), - mean(exp$data[1,1,1,1,,])) + mean(exp$data[1,1,1,1,,])) # Create a more realistic perfect-model precipitation z <- 1 : (32 * 32) @@ -91,12 +150,13 @@ test_that("Sanity checks and simple use cases", { rpfm=agg(apply(rpf, c(5, 6), mean),32) # Use climatological mean of PF precipitation to generate sythetic weights - w <- rfweights(rpfm, res$lon, res$lat, exp$lon, exp$lat, 8, fsmooth=FALSE ) + w <- rfweights(rpfm, res$coords$lon, res$coords$lat, exp$coords$lon, + exp$coords$lat, 8, fsmooth = FALSE ) names(dim(w)) <- c('lon', 'lat') - res <- CST_RainFARM(exppf, nf=8, time_dim=c("ftime", "sdate", "member"), - nens=2, nproc=2, fsmooth=FALSE) - resw <- CST_RainFARM(exppf, nf=8, time_dim=c("ftime", "sdate", "member"), - nens=2, nproc=2, fsmooth=FALSE, weights=w) + res <- CST_RainFARM(exppf, nf = 8, time_dim = c("ftime", "sdate", "member"), + nens = 2, nproc = 2, fsmooth = FALSE) + resw <- CST_RainFARM(exppf, nf = 8, time_dim = c("ftime", "sdate", "member"), + nens = 2, nproc = 2, fsmooth = FALSE, weights = w) resm <- agg(apply(res$data, c(6,7), mean),32) reswm <- agg(apply(resw$data, c(6,7), mean),32) @@ -114,8 +174,10 @@ test_that("Sanity checks and simple use cases", { dim(r) <- c(dataset = 1, member = 1, sdate = 1, ftime = 1, lat = 256, lon = 256) expfine <- exp expfine$data <- r - res <- CST_RainFARM(expcoarse, nf=32, time_dim=c("ftime", "sdate"), - slope=1.7, fsmooth=FALSE, drop_realization_dim=TRUE) + res <- CST_RainFARM(expcoarse, nf = 32, time_dim=c("ftime", "sdate"), + slope = 1.7, fsmooth=FALSE, drop_realization_dim=TRUE) + # TO DO: Develop within the new s2dv_cube + sres= CST_RFSlope(res, time_dim = c("ftime", "sdate")) sexp= CST_RFSlope(expfine, time_dim = c("ftime", "sdate")) expect_equal(sres, sexp, tolerance=0.25) diff --git a/tests/testthat/test-CST_RegimesAssign.R b/tests/testthat/test-CST_RegimesAssign.R index b822f759d3abeaa303564e67195684b12969446b..456aaf8172200d8e4a603019d023007994483e44 100644 --- a/tests/testthat/test-CST_RegimesAssign.R +++ b/tests/testthat/test-CST_RegimesAssign.R @@ -1,104 +1,116 @@ -context("Generic tests") -test_that("Sanity checks", { +context("CSTools::CST_RegimesAssign") + +############################################## + +test_that("1. Input checks", { + # Check 's2dv_cube' expect_error( CST_RegimesAssign(data = 1), paste0("Parameter 'data' must be of the class 's2dv_cube', as output by ", - "CSTools::CST_Load.")) - + "CSTools::CST_Load.") + ) data1 <- 1 : 20 data1 <- list(data = data1) class(data1) <- 's2dv_cube' expect_error( - CST_RegimesAssign(data = data1,ref_maps=1), + CST_RegimesAssign(data = data1, ref_maps = 1), paste0("Parameter 'ref_maps' must be of the class 's2dv_cube', as output by ", - "CSTools::CST_Load.")) - + "CSTools::CST_Load.") + ) + # data regimes <- 1:20 - dim(regimes) <- c(lat = 5, lon=2, cluster=2) - regimes <- list(data=regimes) - class(regimes) <- 's2dv_cube' + dim(regimes) <- c(lat = 5, lon = 2, cluster = 2) + regimes <- list(data = regimes) expect_error( - CST_RegimesAssign(data = data1,ref_maps = regimes), - paste0("Parameter 'data' must be an array with named dimensions.")) - + RegimesAssign(data = data1$data, ref_maps = regimes$data), + paste0("Parameter 'data' must be an array with named dimensions.") + ) + # Temporal dimensions data1 <- 1 : 20 - dim(data1) <- c(lat = 5, lon=4) - data1 <- list(data = data1 , lat=1:5) + dim(data1) <- c(lat = 5, lon = 4) + data1 <- list(data = data1 , coords = list(lat = 1:5)) class(data1) <- 's2dv_cube' expect_error( - CST_RegimesAssign(data = data1,ref_maps = regimes), - paste0("Parameter 'data' must have temporal dimensions.")) - + RegimesAssign(data = data1$data, ref_maps = regimes$data, + lat = data1$coords$lat), + paste0("Parameter 'data' must have temporal dimensions.") + ) data1 <- 1 : 20 - dim(data1) <- c(time=20) + dim(data1) <- c(time = 20) data1 <- list(data = data1) class(data1) <- 's2dv_cube' expect_error( - CST_RegimesAssign(data = data1,ref_maps = regimes), - paste0("Parameter 'lat' must be specified.")) - - + RegimesAssign(data = data1$data, ref_maps = regimes$data, + lat = data1$coords$lat), + paste0("Parameter 'lat' must be specified.") + ) data1 <- 1 : 20 - dim(data1) <- c(time=20) - data1 <- list(data = data1,lat=1:5) - class(data1) <- 's2dv_cube' - - expect_error( - CST_RegimesAssign(data = data1,ref_maps = regimes), - paste0("Parameter 'data' must contain the named dimensions 'lat' and 'lon'.")) - - data1 <- 1: 20 - dim(data1) <- c(lat = 2, lon=5, time=2) - data1 <- list(data = data1, lat=1:5) + dim(data1) <- c(time = 20) + data1 <- list(data = data1, coords = list(lat = 1:5)) class(data1) <- 's2dv_cube' - expect_error( - CST_RegimesAssign(data = data1,ref_maps = regimes), - " Parameter 'lat' does not match with the dimension 'lat' in the - parameter 'data' or in the parameter 'ref_maps'.") + RegimesAssign(data = data1$data, ref_maps = regimes$data, + lat = data1$coords$lat), + paste0("Spatial coordinate dimension names do not match any of the names ", + "accepted by the package.") + ) +}) - +############################################## + +test_that("2. Output checks", { data1 <- 1: 20 - dim(data1) <- c(lat = 5, lon=2, time=2) - data1 <- list(data = data1, lat=1:5) + dim(data1) <- c(lat = 5, lon = 2, time = 2) + data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:2)) class(data1) <- 's2dv_cube' - - expect_equal(names(CST_RegimesAssign(data = data1, ref_maps = regimes)$statistics), - c('cluster', 'frequency')) - - expect_equal(names( - suppressWarnings( - CST_RegimesAssign( - data = data1, - ref_maps = regimes, - composite = TRUE))$statistics), c('pvalue', 'cluster', 'frequency')) - - expect_equal(names(dim( + regimes <- 1:20 + dim(regimes) <- c(lat = 5, lon = 2, cluster = 2) + regimes <- list(data = regimes, coords = list(lat = 1:5, lon = 1:2)) + class(regimes) <- 's2dv_cube' + expect_equal( + names(CST_RegimesAssign(data = data1, ref_maps = regimes)$statistics), + c('cluster', 'frequency') + ) + expect_equal( + names(suppressWarnings( + CST_RegimesAssign( + data = data1, + ref_maps = regimes, + composite = TRUE))$statistics), + c('pvalue', 'cluster', 'frequency') + ) + expect_equal( + names(dim( suppressWarnings( CST_RegimesAssign( data = data1, ref_maps = regimes, - composite = TRUE))$data)), c('lon', 'lat', 'composite.cluster')) + composite = TRUE))$data)), c('lon', 'lat', 'composite.cluster') + ) data1 <- 1: 160 dim(data1) <- c(lat = 5, lon=2, time=2, member=8) - data1 <- list(data = data1, lat=1:5) + data1 <- list(data = data1, coords = list(lat = 1:5)) class(data1) <- 's2dv_cube' - expect_equal(names(dim( + expect_equal( + names(dim( suppressWarnings( CST_RegimesAssign( data = data1, ref_maps = regimes, - composite = TRUE))$data)), c('lon', 'lat', 'composite.cluster', 'member')) + composite = TRUE))$data)), c('lon', 'lat', 'composite.cluster', 'member') + ) - expect_equal(names(dim( + expect_equal( + names(dim( suppressWarnings( CST_RegimesAssign( data = data1, ref_maps = regimes, - composite = TRUE))$statistics$cluster)), c('time', 'member')) + composite = TRUE))$statistics$cluster)), c('time', 'member') + ) regimes <- 1:60 dim(regimes) <- c(lat = 5, lon=2, cluster=6) @@ -109,17 +121,14 @@ test_that("Sanity checks", { unname(dim(regimes$data)['cluster'])) - regimes <- 1:60 - dim(regimes) <- c(lat = 5, lon=2, cluster=3, member=2) + regimes <- 1:240 + dim(regimes) <- c(lat = 5, lon=2, cluster=3, member=8) regimes <- list(data=regimes) class(regimes) <- 's2dv_cube' - expect_equal(names(dim(CST_RegimesAssign(data = data1, ref_maps = regimes, - composite = FALSE)$statistics$cluster)),c('time','member','member')) - - + expect_equal( + names(dim(CST_RegimesAssign(data = data1, ref_maps = regimes, + composite = FALSE)$statistics$cluster)), + c('member', 'time') + ) - - - - }) diff --git a/tests/testthat/test-CST_SaveExp.R b/tests/testthat/test-CST_SaveExp.R new file mode 100644 index 0000000000000000000000000000000000000000..987f41cfe884ca2d5fbbfa56df5137e91ef249bb --- /dev/null +++ b/tests/testthat/test-CST_SaveExp.R @@ -0,0 +1,220 @@ +context("CSTools::CST_SaveExp tests") +############################################## + +# cube0 +cube0 <- array(1:5, dim = c(sdate = 5, lon = 4, lat = 4, ftime = 1)) +class(cube0) <- 's2dv_cube' + +# cube1 +cube1 <- NULL +cube1$data <- array(1:5, dim = c(sdate = 5, lon = 4, lat = 4, ftime = 1)) +coords2 <- list(sdate = c('20000101', '20010102', '20020103', '20030104', '20040105'), + var = 'tas', + lon = 1.:4., + lat = 1.:4.) +cube1$coords <- coords2 +dates2 <- c('20000101', '20010102', '20020103', '20030104', '20040105') +dates2 <- as.Date(dates2, format = "%Y%m%d", tz = "UTC") +dim(dates2) <- c(sdate = 5, ftime = 1) +cube1$attrs$Dates <- dates2 +class(cube1) <- 's2dv_cube' + +# cube2 +cube2 <- cube1 +cube2$data <- array(1:5, dim = c(sdate = 5, lon = 4, lat = 4, ftime = 1, + test = 2, test2 = 3)) +dim(cube2$data) <- c(sdate = 5, lon = 4, lat = 4, ftime = 1, member = 1, + ensemble = 1, test = 2, test2 = 3) + +# cube3 +cube3 <- cube1 + +# dat0 +dates0 <- as.Date('2022-02-01', format = "%Y-%m-%d") +dim(dates0) <- c(sdate = 1) +# dat1 +dat1 <- array(1, dim = c(test = 1)) +# dat2 +dat2 <- array(1:5, dim = c(sdate = 5, lon = 4, lat = 4, ftime = 1)) +coords2 <- list(sdate = c('20000101', '20010102', '20020103', '20030104', '20040105'), + var = 'tas', + lon = 1.:4., + lat = 1.:4.) +dates2 <- c('20000101', '20010102', '20020103', '20030104', '20040105') +dates2 <- as.Date(dates2, format = "%Y%m%d", tz = "UTC") +dim(dates2) <- c(sdate = 5, ftime = 1) + +############################################## + +test_that("1. Input checks: CST_SaveExp", { + # s2dv_cube + expect_error( + CST_SaveExp(data = 1), + paste0("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + ) + # structure + expect_error( + CST_SaveExp(data = cube0), + paste0("Parameter 'data' must have at least 'data' and 'attrs' elements ", + "within the 's2dv_cube' structure.") + ) + cube0 <- list(data = cube0, attrs = 1) + class(cube0) <- 's2dv_cube' + expect_error( + CST_SaveExp(data = cube0), + paste0("Level 'attrs' must be a list with at least 'Dates' element.") + ) + # cube0$attrs <- NULL + # cube0$attrs$Dates <- dates2 + # expect_warning( + # CST_SaveExp(data = cube0, sdate_dim = c('sdate', 'sweek'), + # ftime_dim = 'ftime', memb_dim = NULL, dat_dim = NULL, + # var_dim = NULL, single_file = FALSE), + # paste0("Element 'coords' not found. No coordinates will be used.") + # ) + + # sdate_dim + suppressWarnings( + expect_error( + CST_SaveExp(data = cube1, sdate_dim = 1), + paste0("Parameter 'sdate_dim' must be a character string.") + ) + ) + # expect_warning( + # CST_SaveExp(data = cube1, sdate_dim = c('sdate', 'sweek'), + # ftime_dim = 'ftime', memb_dim = NULL, dat_dim = NULL, + # var_dim = NULL), + # paste0("Parameter 'sdate_dim' has length greater than 1 and ", + # "only the first element will be used.") + # ) + suppressWarnings( + expect_error( + CST_SaveExp(data = cube1, sdate_dim = 'a', ftime_dim = 'ftime'), + paste0("Parameter 'sdate_dim' is not found in 'data' dimension.") + ) + ) + # # metadata + # expect_warning( + # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + # dat_dim = NULL, var_dim = NULL), + # paste0("No metadata found in element Variable from attrs.") + # ) + cube1$attrs$Variable$metadata <- 'metadata' + expect_error( + CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + dat_dim = NULL, var_dim = NULL), + paste0("Element metadata from Variable element in attrs must be a list.") + ) + cube1$attrs$Variable$metadata <- list(test = 'var') + # expect_warning( + # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + # dat_dim = NULL, var_dim = NULL), + # paste0("Metadata is not found for any coordinate.") + # ) + cube1$attrs$Variable$metadata <- list(var = 'var') + # expect_warning( + # CST_SaveExp(data = cube1, ftime_dim = 'ftime', memb_dim = NULL, + # dat_dim = NULL, var_dim = NULL), + # paste0("Metadata is not found for any variable.") + # ) + # memb_dim + suppressWarnings( + expect_error( + CST_SaveExp(data = cube1, memb_dim = 1, ftime_dim = 'ftime'), + paste0("Parameter 'memb_dim' must be a character string.") + ) + ) + suppressWarnings( + expect_error( + CST_SaveExp(data = cube1, memb_dim = 'member', ftime_dim = 'ftime'), + paste0("Parameter 'memb_dim' is not found in 'data' dimension. Set it ", + "as NULL if there is no member dimension.") + ) + ) + # expect_warning( + # CST_SaveExp(data = cube2, memb_dim = c('member', 'ensemble'), + # ftime_dim = 'ftime', dat_dim = NULL, var_dim = NULL), + # paste0("Detected unknown dimension: test, test2") + # ) +}) + +############################################## + +test_that("1. Input checks", { + # data + expect_error( + SaveExp(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + SaveExp(data = 1:10), + "Parameter 'data' must be an array with named dimensions." + ) + # destination + expect_error( + SaveExp(data = array(1, dim = c(a = 1)), destination = NULL), + paste0("Parameter 'destination' must be a character string of one element ", + "indicating the name of the file (including the folder if needed) ", + "where the data will be saved."), + fixed = TRUE + ) + # Dates + expect_error( + SaveExp(data = array(1, dim = c(a = 1)), Dates = 'a'), + paste0("Parameter 'Dates' must be of 'POSIXct' or 'Dates' class.") + ) + expect_error( + SaveExp(data = array(1, dim = c(a = 1)), + Dates = as.Date('2022-02-01', format = "%Y-%m-%d")), + paste0("Parameter 'Dates' must have dimension names.") + ) + # # varname + # expect_warning( + # SaveExp(data = dat2, coords = coords2, + # metadata = list(tas = list(level = '2m')), + # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + # dat_dim = NULL, var_dim = NULL), + # paste0("Parameter 'varname' is NULL. It will be assigned to 'X'.") + # ) + suppressWarnings( + expect_error( + SaveExp(data = dat2, coords = coords2, varname = 1, + metadata = list(tas = list(level = '2m')), + Dates = dates2), + "Parameter 'varname' must be a character." + ) + ) + # # coords + # expect_warning( + # SaveExp(data = dat2, coords = list(sdate = coords2[[1]]), + # varname = 'tas', metadata = list(tas = list(level = '2m')), + # Dates = dates2, ftime_dim = 'ftime', memb_dim = NULL, + # dat_dim = NULL, var_dim = NULL), + # "Coordinate 'lon' is not provided and it will be set as index in element coords.", + # "Coordinate 'lat' is not provided and it will be set as index in element coords.", + # "Coordinate 'ftime' is not provided and it will be set as index in element coords." + # ) + # # varname, metadata, spatial coords, unknown dim + # expect_warning( + # SaveExp(data = dat1, ftime_dim = NULL, sdate_dim = NULL, memb_dim = NULL, + # dat_dim = NULL, var_dim = NULL, single_file = TRUE), + # "Parameter 'varname' is NULL. It will be assigned to 'X'.", + # "Parameter 'metadata' is not provided so the metadata saved will be incomplete.", + # paste0("Parameter 'single_file' is TRUE. Time values saved in the NetCDF ", + # "file may not be consistent for all the start dates. ", + # "Further development of the function is needed, sorry ", + # "for the inconvinience."), + # paste0("Spatial coordinate names do not match any of the names accepted by ", + # "the package."), + # "Detected unknown dimension: test" + # ) + expect_error( + SaveExp(data = dat1, varname = 1, ftime_dim = NULL, sdate_dim = NULL, + memb_dim = NULL, dat_dim = NULL, var_dim = NULL), + paste0("Parameter 'varname' must be a character string with the ", + "variable names.") + ) +}) + +############################################## diff --git a/tests/testthat/test-CST_SplitDim.R b/tests/testthat/test-CST_SplitDim.R index 59f88597261fc0b3524d32570fef30cc2e49e78d..c2652477c71fc52616aa41e3fd799f5c02be1638 100644 --- a/tests/testthat/test-CST_SplitDim.R +++ b/tests/testthat/test-CST_SplitDim.R @@ -1,92 +1,133 @@ -context("Generic tests") -test_that("Sanity checks", { +context("CSTools::CST_SplitDim tests") + + +############################################## + +# dat1 +data1 <- 1 : 20 +dim(data1) <- c(time = 20) +data1 <- list(data = data1) +class(data1) <- 's2dv_cube' + +indices1 <- c(rep(1,5), rep(2,5), rep (3, 5), rep(4, 5)) +output1 <- matrix(data1$data, nrow = 5, ncol = 4) +names(dim(output1)) <- c('time', 'monthly') +output1 <- list(data = output1) +class(output1) <- 's2dv_cube' + +exp_cor <- 1 : 20 +dim(exp_cor) <- 20 +exp_cor <- list(data = exp_cor) +class(exp_cor) <- 's2dv_cube' + +# dat2 +output2 <- matrix(data1$data, nrow = 5, ncol = 4) +names(dim(output2)) <- c('time', 'index') +output2 <- list(data = output2) +class(output2) <- 's2dv_cube' + +time2 <- c(seq(ISOdate(1903, 1, 1), ISOdate(1903, 1, 4), "days"), + seq(ISOdate(1903, 2, 1), ISOdate(1903, 2, 4), "days"), + seq(ISOdate(1904, 1, 1), ISOdate(1904, 1, 2), "days")) +attrs <- list(Dates = time2) +data2 <- list(data = data1$data, attrs = attrs) +class(data2) <- 's2dv_cube' + +# dat3 +time3 <- c(seq(ISOdate(1903, 1, 1), ISOdate(1903, 1, 8), "days"), + seq(ISOdate(1903, 2, 1), ISOdate(1903, 2, 8), "days"), + seq(ISOdate(1904, 1, 1), ISOdate(1904, 1, 4), "days")) +attrs <- list(Dates = time3) +data3 <- list(data = data1$data, attrs = attrs) +class(data3) <- 's2dv_cube' +output3 <- c(data3$data, rep(NA, 4)) +dim(output3) <- c(time = 8, monthly = 3) +result3 <- data3 +result3$data <- output3 + +# dat4 +data4 <- list(data = array(rnorm(10), dim = c(sdate = 2, lon = 5))) +class(data4) <- 's2dv_cube' + +############################################## + +test_that("1. Input checks", { expect_error( CST_SplitDim(data = 1), paste0("Parameter 'data' must be of the class 's2dv_cube', as output by ", - "CSTools::CST_Load.")) - - data <- 1 : 20 - dim(data) <- c(time = 20) - data <- list(data = data) - class(data) <- 's2dv_cube' + "CSTools::CST_Load.") + ) expect_error( - CST_SplitDim(data = data), + CST_SplitDim(data = data1), paste0("Parameter 'freq' must be a integer number indicating ", - " the length of each chunk.")) -indices <- c(rep(1,5), rep(2,5), rep (3, 5), rep(4, 5)) -output = matrix(data$data, nrow = 5, ncol = 4) -names(dim(output)) <- c('time', 'monthly') -output <- list(data = output) -class(output) <- 's2dv_cube' - expect_equal( - CST_SplitDim(data = data, indices = indices), output) -output = matrix(data$data, nrow = 5, ncol = 4) -names(dim(output)) <- c('time', 'index') -output <- list(data = output) -class(output) <- 's2dv_cube' - expect_equal( - CST_SplitDim(data = data, freq = 5), output) - -time <- c(seq(ISOdate(1903, 1, 1), ISOdate(1903, 1, 4), "days"), - seq(ISOdate(1903, 2, 1), ISOdate(1903, 2, 4), "days"), - seq(ISOdate(1904, 1, 1), ISOdate(1904, 1, 2), "days")) -data <- list(data = data$data, Dates = time) -class(data) <- 's2dv_cube' + " the length of each chunk.") + ) expect_error( - CST_SplitDim(data = data), + CST_SplitDim(data = data2), paste0("Parameter 'indices' has different length of parameter data ", - "in the dimension supplied in 'split_dim'.")) -time <- c(seq(ISOdate(1903, 1, 1), ISOdate(1903, 1, 8), "days"), - seq(ISOdate(1903, 2, 1), ISOdate(1903, 2, 8), "days"), - seq(ISOdate(1904, 1, 1), ISOdate(1904, 1, 4), "days")) -data <- list(data = data$data, Dates = time) -class(data) <- 's2dv_cube' -output <- c(data$data, rep(NA, 4)) -dim(output) <- c(time = 8, monthly = 3) -result <- data -result$data <- output - - expect_equal( - CST_SplitDim(data = data), result) - - exp_cor <- 1 : 20 - dim(exp_cor) <- 20 - exp_cor <- list(data = exp_cor) - class(exp_cor) <- 's2dv_cube' + "in the dimension supplied in 'split_dim'.") + ) expect_error( CST_SplitDim(data = exp_cor, freq = 5), - "Parameter 'data' must have dimension names.") - # expect_error( - # CST_SplitDim(data, freq = 'x'), - # paste0("Parameter 'freq' must be numeric or a character: by 'day', ", - # "'month', 'year' or 'monthly' (for distinguishable month).")) - -library(CSTools) + "Parameter 'data' must have dimension names." + ) expect_error( - CST_SplitDim(data = lonlat_temp$exp), - "Parameter 'split_dims' must be one of the dimension names in parameter 'data'.") - output <- lonlat_temp$exp$data - output <- abind(output[, , , 1, ,], output[, , , 2, ,], output[, , , 3, ,], along = 5) - dim(output) <- c(dataset = 1, member = 15, sdate = 6, ftime = 1, - lat = 22, lon = 53, monthly = 3) - result <- lonlat_temp$exp - result$data <- output - expect_equal(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'ftime'), - result) - - expect_equal(dim(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', - freq = 5)$data), - c(dataset = 1, member = 5, sdate = 6, ftime = 3, - lat = 22, lon = 53, index = 3)) - expect_warning(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', - freq = 5, new_dim_name = c('a', 'b')), - paste0("Parameter 'new_dim_name' has length greater than 1 ", - "and only the first elemenst is used.")) - expect_error(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', - freq = 5, new_dim_name = 3), - "Parameter 'new_dim_name' must be character string") - expect_equal(dim(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', - freq = 5, new_dim_name = 'wt')$data), - c(dataset = 1, member = 5, sdate = 6, ftime = 3, - lat = 22, lon = 53, wt = 3)) + CST_SplitDim(data = data4), + "Parameter 'split_dims' must be one of the dimension names in parameter 'data'." + ) }) + +############################################## + +test_that("2. Output checks", { + expect_equal( + CST_SplitDim(data = data1, indices = indices1), + output1 + ) + expect_equal( + CST_SplitDim(data = data1, freq = 5), + output2 + ) + expect_equal( + CST_SplitDim(data = data3), + result3 + ) +}) + +############################################## + +# test_that("3. Output checks: sample data", { +# output <- lonlat_temp$exp$data +# output <- abind(output[, , , 1, ,], output[, , , 2, ,], output[, , , 3, ,], along = 5) +# dim(output) <- c(dataset = 1, member = 15, sdate = 6, ftime = 1, +# lat = 22, lon = 53, monthly = 3) +# result <- lonlat_temp$exp +# result$data <- output +# expect_equal( +# CST_SplitDim(data = lonlat_temp$exp, split_dim = 'ftime'), +# result +# ) +# expect_equal( +# dim(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', +# freq = 5)$data), +# c(dataset = 1, member = 5, sdate = 6, ftime = 3, lat = 22, +# lon = 53, index = 3) +# ) +# expect_warning( +# CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', freq = 5, +# new_dim_name = c('a', 'b')), +# paste0("Parameter 'new_dim_name' has length greater than 1 ", +# "and only the first elemenst is used.") +# ) +# expect_error( +# CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', freq = 5, +# new_dim_name = 3), +# "Parameter 'new_dim_name' must be character string" +# ) +# expect_equal( +# dim(CST_SplitDim(data = lonlat_temp$exp, split_dim = 'member', +# freq = 5, new_dim_name = 'wt')$data), +# c(dataset = 1, member = 5, sdate = 6, ftime = 3, lat = 22, +# lon = 53, wt = 3) +# ) +# }) diff --git a/tests/testthat/test-CST_WeatherRegimes.R b/tests/testthat/test-CST_WeatherRegimes.R index 5f2967a172f393659dea3c93f8f1cc06986a9099..ebf8730de07460b2d92cde998ca211c6a9212503 100644 --- a/tests/testthat/test-CST_WeatherRegimes.R +++ b/tests/testthat/test-CST_WeatherRegimes.R @@ -1,72 +1,121 @@ context("Generic tests") -test_that("Sanity checks", { - expect_error( + +############################################## +# dat1 +data <- rnorm(2 * 10 * 4 * 5 * 6 * 7) +dim(data) <- c(dataset = 2, member = 10, + sdate = 4, ftime = 5, lat = 6, lon = 7) +lon <- seq(0, 12, 2) +lat <- seq(10, 15, 1) +coords <- list(lon = lon, lat = lat) +exp <- list(data = data, coords = coords) +attr(exp, "class") <- "s2dv_cube" + +# dat2 +exp2 <- exp +exp2$attrs <- list(source_files = 'exp') +exp2$coords <- NULL +exp2_2 <- exp2 +exp2_2$coords <- list(long = seq(1:4), lati = seq(1:4)) + +# data1 +data1 <- 1 : 400 +dim(data1) <- c(time = 20, lat = 5, lon = 4) +data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:4)) +class(data1) <- 's2dv_cube' + +############################################## +test_that("1. Input checks", { + expect_error( CST_WeatherRegimes(data = 1), paste0("Parameter 'data' must be of the class 's2dv_cube', as output by ", - "CSTools::CST_Load.")) - + "CSTools::CST_Load.") + ) + # Check 'exp' object structure + expect_error( + CST_WeatherRegimes(exp2), + paste0("Parameter 'data' must have 'data' and 'coords' elements ", + "within the 's2dv_cube' structure.") + ) + expect_error( + CST_WeatherRegimes(exp2_2, ncenters = 3), + paste0("Spatial coordinate names do not match any of the names accepted ", + "the package.") + ) + expect_error( + WeatherRegime(array(rnorm(8400), dim = c(member = 10, sdate = 4, ftime = 5, + lati = 6, loni = 7)), + lat = seq(1:5), lon = seq(1:6), ncenters = 3), + paste0("Spatial coordinate names do not match any of the names accepted by ", + "the package.") + ) data1 <- 1 : 20 - data1 <- list(data = data1) + data1 <- list(data = data1, coords = list(lat = 1, lon = 1)) class(data1) <- 's2dv_cube' expect_error( CST_WeatherRegimes(data = data1), - paste0("Parameter 'data' must be an array with named dimensions.")) - + paste0("Parameter 'data' must be an array with named dimensions.") + ) data1 <- 1 : 20 dim(data1) <- c(lat = 5, lon = 4) - data1 <- list(data = data1 , lat = 1:5) + data1 <- list(data = data1 , coords = list(lat = 1:5, lon = 1:4)) class(data1) <- 's2dv_cube' expect_error( CST_WeatherRegimes(data = data1), - paste0("Parameter 'data' must have temporal dimensions.")) - - data1 <- 1 : 20 - dim(data1) <- c(time = 20) - data1 <- list(data = data1) - class(data1) <- 's2dv_cube' - expect_error( - CST_WeatherRegimes(data = data1) , - paste0("Parameter 'lat' must be specified.")) - + paste0("Parameter 'data' must have temporal dimensions.") + ) data1 <- 1 : 400 dim(data1) <- c(time = 20, lat = 5, lon = 4) - data1 <- list(data = data1, lat = 1:5) + data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:4)) class(data1) <- 's2dv_cube' expect_error( CST_WeatherRegimes(data = data1), - paste0("Parameter 'ncenters' must be specified.")) - + paste0("Parameter 'ncenters' must be specified.") + ) expect_error( - CST_WeatherRegimes(data = data1, ncenters = 3), - paste0("Parameter 'lon' must be specified.")) - + WeatherRegime(data = data1$data, ncenters = 3), + paste0("Parameter 'lon' must be specified.") + ) + expect_error( + WeatherRegime(data = data1$data, lon = data1$coords$lon, ncenters = 3), + paste0("Parameter 'lat' must be specified.") + ) +}) + +############################################## + +test_that("2. Output checks", { expect_equal( names(dim(CST_WeatherRegimes(data = data1, ncenters = 3, EOFs = FALSE)$data)), - c('lat', 'lon', 'cluster')) - + c('lat', 'lon', 'cluster') + ) data1 <- 1 : 400 dim(data1) <- c(sdate = 2, ftime = 10, lat = 5, lon = 4) - data1 <- list(data = data1, lat = 1:5) + data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:4)) class(data1) <- 's2dv_cube' - nclusters <- 3 - - expect_equal( - dim(CST_WeatherRegimes(data = data1 , - ncenters = nclusters, - EOFs = FALSE)$statistics$frequency), c(2, nclusters)) - expect_equal( - names(dim(CST_WeatherRegimes(data = data1, nclusters, EOFs = FALSE)$data)), - c('lat', 'lon', 'cluster')) - + nclusters <- 3 + suppressWarnings( + expect_equal( + dim(CST_WeatherRegimes(data = data1 , + ncenters = nclusters, + EOFs = FALSE)$statistics$frequency), + c(2, nclusters) + ) + ) + suppressWarnings( + expect_equal( + names(dim(CST_WeatherRegimes(data = data1, nclusters, EOFs = FALSE)$data)), + c('lat', 'lon', 'cluster') + ) + ) data1 <- 1 : 400 dim(data1) <- c(sdate = 2, ftime = 10, lat = 5, lon = 4) - data1 <- list(data = data1, lat = 1:5 ,lon = 1:4) + data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:4)) class(data1) <- 's2dv_cube' - expect_equal( names(CST_WeatherRegimes(data = data1 , ncenters = 4)$statistics), - c('pvalue', 'cluster', 'frequency', 'persistence')) - + c('pvalue', 'cluster', 'frequency', 'persistence') + ) expect_equal( names(CST_WeatherRegimes(data = data1 , ncenters = 4, method = 'ward.D')$statistics), c('pvalue', 'cluster')) @@ -77,27 +126,29 @@ test_that("Sanity checks", { data1 <- 1 : 400 dim(data1) <- c(time = 20, lat = 5, lon = 4) - data1[4,,] <- NA - data1 <- list(data = data1, lat = 1:5 ,lon = 1:4) + data1[4, , ] <- NA + data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:4)) class(data1) <- 's2dv_cube' expect_error( CST_WeatherRegimes(data = data1, ncenters = 3, EOFs = FALSE), - paste0("Parameter 'data' contains NAs in the 'time' dimensions.")) - + paste0("Parameter 'data' contains NAs in the 'time' dimensions.") + ) data1 <- 1 : 400 dim(data1) <- c(time = 20, lat = 5, lon = 4) - data1[,2,3] <- NA - data1 <- list(data = data1, lat = 1:5 ,lon = 1:4) + data1[, 2, 3] <- NA + data1 <- list(data = data1, coords = list(lat = 1:5, lon = 1:4)) class(data1) <- 's2dv_cube' expect_equal( any(is.na(CST_WeatherRegimes(data = data1, ncenters = 3, EOFs = FALSE)$data)), - TRUE) + TRUE + ) expect_equal( names(dim(CST_WeatherRegimes(data = data1, ncenters = 3, EOFs = FALSE)$data)), - c('lat', 'lon', 'cluster')) + c('lat', 'lon', 'cluster') + ) }) - +############################################## diff --git a/tests/testthat/test-as.s2dv_cube.R b/tests/testthat/test-as.s2dv_cube.R new file mode 100644 index 0000000000000000000000000000000000000000..36a24738f0d791b2b031af637b5b5f4db024340b --- /dev/null +++ b/tests/testthat/test-as.s2dv_cube.R @@ -0,0 +1,341 @@ +context("CSTools::as.s2dv_cube tests") + +############################################## +library(startR) +library(s2dv) +############################################## + +test_that("1. Input checks", { + expect_error( + as.s2dv_cube(object = array(1:10, dim = c(sdate = 2, lat = 5))), + paste0("The class of parameter 'object' is not implemented", + " to be converted into 's2dv_cube' class yet.") + ) + expect_error( + as.s2dv_cube(object = as.list(1:11)), + paste0("The s2dv::Load call did not return any data.") + ) +}) + +############################################## + +# test_that("2. Tests from Load()", { +# startDates <- c('20001101', '20011101') +# suppressWarnings( +# ob1 <- Load(var = 'tas', exp = 'system5c3s', +# nmember = 2, sdates = startDates, +# leadtimemax = 3, latmin = 30, latmax = 35, +# lonmin = 10, lonmax = 20, output = 'lonlat') +# ) +# res1 <- as.s2dv_cube(ob1) + +# # dimensions +# expect_equal( +# dim(res1$data), +# c(dataset = 1, member = 2, sdate = 2, ftime = 3, lat = 6, lon = 11) +# ) +# # elements +# expect_equal( +# names(res1), +# c("data", "dims", "coords", "attrs") +# ) +# expect_equal( +# names(res1$attrs), +# c("Variable", "Datasets", "Dates", "when", "source_files", +# "not_found_files", "load_parameters") +# ) +# # coordinates +# expect_equal( +# attributes(res1$coords$sdate), +# list(indices = FALSE) +# ) +# expect_equal( +# attributes(res1$coords$ftime), +# list(indices = TRUE) +# ) +# # Dates +# expect_equal( +# dim(res1$attrs$Dates), +# c(ftime = 3, sdate = 2) +# ) +# }) + +############################################## + +# test_that("3. Tests from Load()", { +# obs_path <- list(name = "ERA5", +# path = "/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h/$VAR_NAME$_$YEAR$$MONTH$.nc") +# ob2 <- Load(var = 'windagl100', obs = list(obs_path), +# sdates = '20180301', nmember = 1, +# leadtimemin = 1, leadtimemax = 1, +# storefreq = "monthly", sampleperiod = 1, +# latmin = 36, latmax = 38, lonmin = 0, lonmax = 4, +# output = 'lonlat', nprocs = 1, grid = 'r360x181') + +# res2 <- as.s2dv_cube(ob2) + +# # dimensions +# expect_equal( +# dim(res2$data), +# c(dataset = 1, member = 1, sdate = 1, ftime = 1, lat = 3, lon = 5) +# ) +# # elements +# expect_equal( +# names(res2$attrs), +# c("Variable", "Datasets", "Dates", "when", "source_files", +# "not_found_files", "load_parameters") +# ) +# # coordinates +# expect_equal( +# attributes(res2$coords$sdate), +# list(indices = FALSE) +# ) +# expect_equal( +# unlist(res2$coords)[1:4], +# c(dataset = "1", member = "1", sdate = "20180301", ftime = "1") +# ) +# # Dates +# expect_equal( +# dim(res2$attrs$Dates), +# c(ftime = 1, sdate = 1) +# ) +# }) + +############################################## + +# test_that("4. Tests from Load()", { +# exp <- list(name = 'ecmwfS5', +# path = "/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_s0-24h/$VAR_NAME$_$START_DATE$.nc") +# obs <- list(name = 'era5', +# path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') +# suppressWarnings( +# ob3 <- Load(var = 'prlr', exp = list(exp), obs = list(obs), +# sdates = paste0(1993:1995, '1101'), nmember = 1, +# storefreq = "monthly", sampleperiod = 1, +# latmin = 42, latmax = 45, lonmin = 4, lonmax = 6, +# output = 'lonlat', nprocs = 1) +# ) +# expect_warning( +# as.s2dv_cube(ob3), +# "The output is a list of two 's2dv_cube' objects corresponding to 'exp' and 'obs'." +# ) +# suppressWarnings( +# res3 <- as.s2dv_cube(ob3) +# ) + +# # dimensions +# expect_equal( +# dim(res3[[1]]$data), +# c(dataset = 1, member = 1, sdate = 3, ftime = 8, lat = 4, lon = 3) +# ) +# expect_equal( +# unlist(res3[[1]]$coords)[1:4], +# c(dataset = "1", member = "1", sdate1 = "19931101", sdate2 = "19941101") +# ) +# # Dates +# expect_equal( +# dim(res3[[1]]$attrs$Dates), +# dim(res3[[2]]$attrs$Dates) +# ) +# }) + +############################################## + +test_that("5. Tests from Start()", { + repos <- '/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc' + suppressWarnings( + data1 <- Start(dat = repos, + var = 'tas', + sdate = c('20170101', '20180101'), + ensemble = indices(1:3), + time = 'all', + latitude = indices(1:10), + longitude = indices(1:10), + return_vars = list(latitude = 'dat', longitude = 'dat', time = 'sdate'), + retrieve = TRUE) + ) + + res4 <- as.s2dv_cube(data1) + + # dimensions + expect_equal( + dim(res4$data), + c(dat = 1, var = 1, sdate = 2, ensemble = 3, time = 7, latitude = 10, longitude = 10) + ) + # elements + expect_equal( + names(res4), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + names(res4$attrs), + c("Dates", "Variable", "Datasets", "when", "source_files", "load_parameters") + ) + # coordinates + expect_equal( + names(res4$coords), + c("dat", "var", "sdate", "ensemble", "time", "latitude", "longitude") + ) + # Dates + expect_equal( + dim(res4$attrs$Dates), + c(sdate = 2, time = 7) + ) +}) + +############################################## + +test_that("6. Tests from Start()", { + vari <- "rsds" + anlgs <- paste0("/esarchive/oper/VITIGEOSS","/output/cfsv2/weekly_mean/", + "$var$/$var$-vitigeoss-cat","_1999-2018_", "$file_date$.nc") + + file_date_array <- array(dim = c(sweek = 2, sday = 3)) + file_date_array[, 1] <- c(paste0('04', c('04', '07'))) + file_date_array[, 2] <- c(paste0('04', c('07', '11'))) + file_date_array[, 3] <- c(paste0('04', c('11', '14'))) + + suppressWarnings( + hcst <- Start(dat = anlgs, + var = vari, + latitude = indices(1:4), #'all', + longitude= indices(1:4), #'all', + member= indices(1), #'all', + time = 'all', + syear = indices(1:4), + file_date = file_date_array, + split_multiselected_dims = TRUE, + retrieve = T, + return_vars = list(leadtimes = 'file_date', longitude = 'dat', latitude = 'dat'), + synonims = list(longitude = c('lon', 'longitude'), + latitude = c('lat', 'latitude'), + syear = c('sdate','syear'), + member = c('ensemble','member'))) + ) + + res5 <- as.s2dv_cube(hcst) + + # dimensions + expect_equal( + dim(res5$data), + c(dat = 1, var = 1, latitude = 4, longitude = 4, member = 1, time = 4, + syear = 4, sweek = 2, sday = 3) + ) + # elements + expect_equal( + names(res5), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + names(res5$attrs), + c("Variable", "Dates", "Datasets", "when", "source_files", "load_parameters") + ) + # coordinates + expect_equal( + names(res5$coords), + c('dat', 'var', 'latitude', 'longitude', 'member', 'time', 'syear', 'sweek', 'sday') + ) + # Dates + expect_equal( + dim(res5$attrs$Dates), + c(sweek = 2, sday = 3, syear = 20, time = 4) + ) +}) + +############################################## + +test_that("7. Tests from Start()", { + repos <- "/esarchive/exp/ecmwf/system5_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" + repos2 <- "/esarchive/exp/ecmwf/system4_m1/monthly_mean/$var$_f6h/$var$_$sdate$.nc" + + suppressWarnings( + data6 <- Start(dat = list(list(name = 'system4_m1', path = repos2), + list(name = 'system5_m1', path = repos)), + var = c('tas', 'sfcWind'), + sdate = '20170101', + ensemble = indices(1), + time = indices(1), + lat = indices(1:5), + lon = indices(1:5), + synonims = list(lat = c('lat', 'latitude'), + lon = c('lon', 'longitude')), + return_vars = list(time = 'sdate', + longitude = 'dat', + latitude = 'dat'), + metadata_dims = c('dat', 'var'), + retrieve = T) + ) + + suppressWarnings( + res6 <- as.s2dv_cube(data6) + ) + + # dimensions + expect_equal( + dim(res6$data), + c(dat = 2, var = 2, sdate = 1, ensemble = 1, time = 1, lat = 5, lon = 5) + ) + # elements + expect_equal( + names(res6), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + res6$attrs$Variable$varName, + c('tas', 'sfcWind') + ) + # coordinates + expect_equal( + names(res6$coords), + c('dat', 'var', 'sdate', 'ensemble', 'time', 'lat', 'lon') + ) + # Dates + expect_equal( + dim(res6$attrs$Dates), + c(sdate = 1, time = 1) + ) +}) + +############################################## + +test_that("8. Tests from Start()", { + path <- paste0('/esarchive/exp/ecearth/a3t4/diags/CMIP/EC-Earth-Consortium/EC-Earth3-LR/piControl/$memb$/Omon/$var$/gn/', + 'v*/$var$_Omon_EC-Earth3-LR_piControl_$memb$_gn_$chunk$.nc') + suppressWarnings( + data7 <- Start(dat = list(list(name = 'a3t4', path = path)), + var = 'tosmean', + memb = paste0('r', 1:5, 'i1p1f1'), + region = c("ATL3", "Global_Ocean", "Nino3.4"), + time = indices(1:10), + chunk = 'all', + time_across = 'chunk', + merge_across_dims = TRUE, + return_vars = list(time = 'chunk', region = NULL), + num_procs = 8, + retrieve = T) + ) + + res7 <- as.s2dv_cube(data7) + + # dimensions + expect_equal( + dim(res7$data), + c(dat = 1, var = 1, memb = 5, region = 3, time = 10) + ) + # elements + expect_equal( + names(res7), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + res7$attrs$Variable$varName, + c('tosmean') + ) + # Dates + expect_equal( + dim(res7$attrs$Dates), + c(time = 10) + ) +}) + +############################################## \ No newline at end of file diff --git a/tests/testthat/test-s2dv_cube.R b/tests/testthat/test-s2dv_cube.R new file mode 100644 index 0000000000000000000000000000000000000000..5737486ce4637670d829241c1a19a2e6114d414e --- /dev/null +++ b/tests/testthat/test-s2dv_cube.R @@ -0,0 +1,135 @@ +context("CSTools::s2dv_cube tests") + +############################################## + +# dat1 +dat1 <- array(1:5, dim = c(var = 1, sdate = 5)) +coords1 <- list(sdate = c('20000101', '20010102', '20020103', '20030104', '20040105'), + var = 'tas') +dates1 <- as.POSIXct(coords1[[1]], format = "%Y%m%d", tz = "UTC") +dim(dates1) <- c(sdate = 5) + +############################################## + +test_that("1. Input checks", { + # data + expect_error( + s2dv_cube(data = 1:10), + "Parameter 'data' must be an array with named dimensions." + ) + # coords + expect_warning( + s2dv_cube(data = dat1, coords = list(sdate = c('20000102', '20010202'), var = 'tas'), + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = dates1), + "Coordinate 'sdate' has different lenght as its dimension and it will not be used." + ) + expect_warning( + s2dv_cube(data = dat1, coords = list(sdate = coords1[[1]]), + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = dates1), + "Coordinate 'var' is not provided and it will be set as index in element coords." + ) + # Dates + expect_warning( + s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m'))), + paste0("Parameter 'Dates' is not provided so the metadata ", + "of 's2dv_cube' object will be incomplete.") + ) + expect_warning( + s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = c('20000101', '20010102', '20020103', '20030104', '20040105')), + paste0("Parameter 'Dates' must be an array with named time dimensions.") + ) + expect_warning( + s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = array(c('20000101', '20010102', '20020103', '20030104', '20040105'))), + paste0("Parameter 'Dates' must have dimension names.") + ) + expect_warning( + s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = array(c('20000101', '20010102', '20020103', '20030104', '20040105'), + dim = c(time = 5))), + paste0("Parameter 'Dates' must have the corresponding time dimension names in 'data'.") + ) + expect_warning( + s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = array(c('20000101', '20010102', '20020103', '20030104', '20040105'), + dim = c(sdate = 5))), + paste0("Parameter 'Dates' must be of class 'POSIXct'.") + ) + # varName + expect_warning( + s2dv_cube(data = dat1, coords = coords1, + metadata = list(tas = list(level = '2m')), + Dates = dates1), + paste0("Parameter 'varName' is not provided so the metadata ", + "of 's2dv_cube' object will be incomplete.") + ) + expect_warning( + s2dv_cube(data = dat1, coords = coords1, varName = 1, + metadata = list(tas = list(level = '2m')), + Dates = dates1), + "Parameter 'varName' must be a character." + ) + # metadata + expect_warning( + s2dv_cube(data = dat1, coords = coords1, varName = 'tas', + Dates = dates1), + "Parameter 'metadata' is not provided so the metadata of 's2dv_cube' object will be incomplete." + ) +}) + +############################################## + +test_that("2. Output checks", { + expect_equal( + names(s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = dates1)), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + names(s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = dates1)$coords), + c("sdate", "var") + ) + expect_equal( + names(s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = dates1)$attrs), + c("Dates", "Variable") + ) + expect_equal( + names(s2dv_cube(data = dat1, coords = coords1, + varName = 'tas', metadata = list(tas = list(level = '2m')), + Dates = dates1, Datasets = 'dat1', + when = as.POSIXct("2022-12-21 17:13"), + source_files = "/home/R")$attrs), + c("Dates", "Variable", "Datasets", "when", "source_files") + ) + suppressWarnings( + object <- s2dv_cube(data = dat1, coords = list(sdate = coords1[[1]]), varName = 'tas', + metadata = list(tas = list(level = '2m')), + Dates = dates1) + ) + expect_equal( + attributes(object$coords$sdate), + list(indices = FALSE) + ) + expect_equal( + attributes(object$coords$var), + list(indices = TRUE) + ) + +}) + +############################################## + + diff --git a/vignettes/Analogs_vignette.Rmd b/vignettes/Analogs_vignette.Rmd index b6a52f895d0a4308358d27823e7f3e952a11b10f..674dccac5e42d414b1b611b83c705fa06d4c39ab 100644 --- a/vignettes/Analogs_vignette.Rmd +++ b/vignettes/Analogs_vignette.Rmd @@ -54,29 +54,26 @@ class(lonlat_temp$exp) names(lonlat_temp$obs) dim(lonlat_temp$obs$data) dim(lonlat_temp$exp$data) -head(lonlat_temp$exp$Dates$start) +head(lonlat_temp$exp$attrs$Dates) ``` There are 15 ensemble members available in the `exp` data set, 6 starting dates and 3 forecast times, which refer to monthly values during 3 months following starting dates on November 1st in the years 2000, 2001, 2002, 2003, 2004 and 2005. ``` exp1 <- lonlat_temp$exp exp1$data <- exp1$data[, , 1, 1, , , drop = FALSE] -exp1$Dates$start <- exp1$Dates$start[1] -exp1$Dates$end <- exp1$Dates$end[1] +exp1$attrs$Dates <- exp1$attrs$Dates[1] down_1 <- CST_Analogs(expL = exp1, obsL = lonlat_temp$obs) exp2 <- lonlat_temp$exp exp2$data <- exp2$data[, , 1, 2, , , drop = FALSE] -exp2$Dates$start <- exp2$Dates$start[2] -exp2$Dates$end <- exp2$Dates$end[2] +exp2$attrs$Dates <- exp2$attrs$Dates[2] down_2 <- CST_Analogs(expL = exp2, obsL = lonlat_temp$obs) -exp3 = lonlat_temp$exp +exp3 <- lonlat_temp$exp exp3$data <- exp3$data[, , 1, 3, , , drop = FALSE] -exp3$Dates$start <- exp3$Dates$start[3] -exp3$Dates$end <- exp3$Dates$end[3] +exp3$attrs$Dates <- exp3$attrs$Dates[3] down_3 <- CST_Analogs(expL = exp3, obsL = lonlat_temp$obs) ``` @@ -92,7 +89,9 @@ var = list(MeanDims(down_1$data, 'member'), PlotLayout(PlotEquiMap, c('lat', 'lon'), var = var, nrow = 1, ncol = 3, - lon = down_1$lon, lat = down_1$lat, filled.continents = FALSE, + lon = down_1$coords$lon, + lat = down_1$coords$lat, + filled.continents = FALSE, titles = c("2000-11-01", "2000-12-01", "2001-01-01"), units = 'T(K)', toptitle = 'Analogs sdate November 2000', width = 10, height = 4) @@ -123,7 +122,7 @@ The last command run concludes that the best analog of the ensemble 15 correspon ``` PlotLayout(PlotEquiMap, c('lat', 'lon'), var = list(down$data$fields[1, , , 15], lonlat_temp$obs$data[1, 1, 5, 1, , ]), nrow = 1, ncol = 2, - lon = down$lon, lat = down$lat, filled.continents = FALSE, + lon = down$coords$lon, lat = down$coords$lat, filled.continents = FALSE, titles = c("Downscaled 2000-11-01", "Observed 2004-11-01"), units = 'T(K)', width = 7, height = 4) ``` @@ -156,7 +155,7 @@ obs <- list(name = 'ERA5', expTAS <- CST_Load(var = 'tas', exp = list(exp), obs = NULL, sdates = '20001001', latmin = 22, latmax = 70, - lonmin = -80, lonmax = 50, output ='lonlat', + lonmin = -80, lonmax = 50, output = 'lonlat', storefreq = 'daily', nmember = 15, leadtimemin = 15, leadtimemax = 15, method = "bilinear", grid = 'r1440x721', nprocs = 1) @@ -168,7 +167,7 @@ obsTAS <- CST_Load(var = 'tas', exp = NULL, obs = list(obs), expPSL <- CST_Load(var = 'psl', exp = list(exp), obs = NULL, sdates = '20001001', latmin = 22, latmax = 70, - lonmin = -80, lonmax = 50, output ='lonlat', + lonmin = -80, lonmax = 50, output = 'lonlat', storefreq = 'daily', nmember = 15, leadtimemin = 15, leadtimemax = 15, method = "bilinear", grid = 'r1440x721', nprocs = 1) @@ -217,22 +216,22 @@ dim(down1$data$dates) # nAnalogs member time # 3 15 1 down1$data$dates[1,1] -# "2005-10-07 UTC" +# "07-10-2005" ``` Now, we can visualize the output: ``` PlotLayout(PlotEquiMap, c('lat', 'lon'), var = list(expPSL$data[1, 1, 1, 1, , ], obsPSL$data[1, 1, 1, 15, , ], - obsPSL$data[1, 1, 6, 7, , ]), - lon = obsPSL$lon, lat = obsPSL$lat, filled.continents = FALSE, + obsPSL$data[1, 1, 6, 7, , ]), lon = obsPSL$coords$lon, + lat = obsPSL$coords$lat, filled.continents = FALSE, titles = c('Exp PSL 15-10-2000','Obs PSL 15-10-2000', 'Obs PSL 7-10-2005'), toptitle = 'First member', ncol = 3, nrow = 1, width = 10, height = 4) PlotLayout(PlotEquiMap, c('lat', 'lon'), var = list( expTAS$data[1, 1, 1, 1, , ], obsTAS$data[1, 1, 1, 15, , ], down1$data$field[1, , , 1], obsTAS$data[1, 1, 6, 7, , ]), - lon = obsTAS$lon, lat = obsTAS$lat, filled.continents = FALSE, + lon = obsTAS$coords$lon, lat = obsTAS$coords$lat, filled.continents = FALSE, titles = c('Exp TAS 15-10-2000', 'Obs TAS 15-10-2000', 'Analog TAS 15-10-2000', 'Obs TAS 7-10-2005'), ncol = 2, nrow = 2) @@ -275,14 +274,15 @@ library(ClimProjDiags) var = list(expTAS$data, obsTAS$data[1, 1, 1, 15, , ], down2$data$field[1, , ], SelBox(obsTAS$data[1, 1, 2, 13, , ], - lon = as.vector(obsTAS$lon), lat = as.vector(obsTAS$lat), + lon = as.vector(obsTAS$coords$lon), + lat = as.vector(obsTAS$coords$lat), region)$data) PlotLayout(PlotEquiMap, c('lat', 'lon'), var = var, - special_args = list(list(lon = expTAS$lon, lat = expTAS$lat), - list(lon = obsTAS$lon, lat = obsTAS$lat), - list(lon = down2$lon, down2$lat), - list(lon = down2$lon, down2$lat)), + special_args = list(list(lon = expTAS$coords$lon, lat = expTAS$coords$lat), + list(lon = obsTAS$coords$lon, lat = obsTAS$coords$lat), + list(lon = down2$coords$lon, down2$coords$lat), + list(lon = down2$coords$lon, down2$coords$lat)), filled.continents = FALSE, titles = c('Exp TAS 15-10-2000', 'Obs TAS 15-10-2000', 'Analog TAS 15-10-2000', 'Obs TAS 13-10-2001'), @@ -311,10 +311,12 @@ down3$data$dates[3] ``` ``` -PlotLayout(PlotEquiMap, c('lat', 'lon'), var = list( - down3$data$field[1, , ], SelBox(obsTAS$data[1, 1, 2, 10, , ], - lon = as.vector(obsTAS$lon), lat = as.vector(obsTAS$lat), - region)$data), lon = down3$lon, lat = down3$lat, +var = list(down3$data$field[1, , ], SelBox(obsTAS$data[1, 1, 2, 10, , ], + lon = as.vector(obsTAS$coords$lon), lat = as.vector(obsTAS$coords$lat), + region)$data) + +PlotLayout(PlotEquiMap, c('lat', 'lon'), var = var, + lon = down3$coords$lon, lat = down3$coords$lat, filled.continents = FALSE, titles = c('Analog TAS 15-10-2000', 'Obs TAS 10-10-2001'), ncol = 2, nrow = 1) @@ -332,7 +334,7 @@ Previous figure shows that the best Analog field corrspond to the observed field down4 <- CST_Analogs(expL = expPSL, obsL = obsPSL, AnalogsInfo = TRUE, criteria = "Large_dist", nAnalogs = 20, obsVar = obsTAS, expVar = expTAS, - region = region, excludeTime = obsPSL$Dates$start[10:20]) + region = region, excludeTime = obsPSL$attrs$Dates[10:20]) ``` In this case, the best analog is still being 7th of October, 2005. diff --git a/vignettes/BestEstimateIndex_vignette.Rmd b/vignettes/BestEstimateIndex_vignette.Rmd index 213499ee67e67ffba713f63e7e918e7e24508ac9..b7dfce685db029532898931300d4e82109f80a61 100644 --- a/vignettes/BestEstimateIndex_vignette.Rmd +++ b/vignettes/BestEstimateIndex_vignette.Rmd @@ -38,24 +38,24 @@ The synthetic data is created by running the following lines: ``` # observations -NAO_obs <- rnorm(20, sd=3) +NAO_obs <- rnorm(20, sd = 3) dim(NAO_obs) <- c(time = 20) # hindcast and forecast of a dynamical SFS 1 -NAO_hind1 <- rnorm(20 * 2 * 25, sd=2.5) +NAO_hind1 <- rnorm(20 * 2 * 25, sd = 2.5) dim(NAO_hind1) <- c(time = 20, member = 50) -NAO_fcst1 <- rnorm(2*51, sd=2.5) +NAO_fcst1 <- rnorm(2*51, sd = 2.5) dim(NAO_fcst1) <- c(time = 1, member = 102) # hindcast and forecast of an empirical SFS 2 -NAO_hind2_mean <- rnorm(20, sd=3) -NAO_hind2_sd <- rnorm(20, mean=5, sd=1) +NAO_hind2_mean <- rnorm(20, sd = 3) +NAO_hind2_sd <- rnorm(20, mean = 5, sd = 1) NAO_hind2 <- cbind(NAO_hind2_mean, NAO_hind2_sd) -dim(NAO_hind2) <- c(time=20, statistic=2) -NAO_fcst2_mean <- rnorm(1, sd=3) -NAO_fcst2_sd <- rnorm(1, mean=5, sd=1) +dim(NAO_hind2) <- c(time = 20, statistic = 2) +NAO_fcst2_mean <- rnorm(1, sd = 3) +NAO_fcst2_sd <- rnorm(1, mean = 5, sd = 1) NAO_fcst2 <- cbind(NAO_fcst2_mean, NAO_fcst2_sd) -dim(NAO_fcst2) <- c(time=1, statistic=2) +dim(NAO_fcst2) <- c(time = 1, statistic = 2) ``` @@ -63,17 +63,17 @@ The winter index NAO and the acumulated precipiation field from the dynamical SF ``` # NAO index of a SFS to compute weights for each ensemble's member -NAO_hind <- rnorm(20 * 25, sd=2.5) +NAO_hind <- rnorm(20 * 25, sd = 2.5) dim(NAO_hind) <- c(time = 20, member = 25) -NAO_fcst <- rnorm(51, sd=2.5) +NAO_fcst <- rnorm(51, sd = 2.5) dim(NAO_fcst) <- c(time = 1, member = 51) # The acumulated precipiation field -prec_hind <- rnorm(20 * 25 * 21 * 31, mean=30, sd=10) +prec_hind <- rnorm(20 * 25 * 21 * 31, mean = 30, sd = 10) dim(prec_hind) <- c(time = 20, member = 25, lat = 21, lon = 31) prec_hind <- list(data = prec_hind) class(prec_hind) <- 's2dv_cube' -prec_fcst <- rnorm(51 * 21 * 31, mean=25,sd=8) +prec_fcst <- rnorm(51 * 21 * 31, mean = 25,sd = 8) dim(prec_fcst) <- c(time = 1, member = 51, lat = 21, lon = 31) prec_fcst <- list(data = prec_fcst) class(prec_fcst) <- 's2dv_cube' @@ -95,7 +95,7 @@ pdf_hind_best <- BEI_PDFBest(NAO_obs, NAO_hind1, NAO_hind2, index_fcst1 = NULL, index_fcst2 = NULL, method_BC = 'none', time_dim_name = 'time', na.rm = FALSE) # for forecast -pdf_fcst_best <- BEI_PDFBest (NAO_obs, NAO_hind1, NAO_hind2, index_fcst1 = NAO_fcst1, +pdf_fcst_best <- BEI_PDFBest(NAO_obs, NAO_hind1, NAO_hind2, index_fcst1 = NAO_fcst1, index_fcst2 = NAO_fcst2, method_BC = 'none', time_dim_name = 'time', na.rm = FALSE) ``` diff --git a/vignettes/Data_Considerations.Rmd b/vignettes/Data_Considerations.Rmd index bd51b7d2f8f3acb1cfbef89dc887d4c5be7ff4ed..979e1c751727edfab63b9c767ca098170986f926 100644 --- a/vignettes/Data_Considerations.Rmd +++ b/vignettes/Data_Considerations.Rmd @@ -49,9 +49,11 @@ All CSTools functions have been developed following the same guidelines. The mai A reasonable important doubt that a new user may have at this point is: what 's2dv_cube' object is? 's2dv_cube' is a class of an object storing the data and metadata in several elements: + $data element is an N-dimensional array with named dimensions containing the data (e.g.: temperature values), - + $lat($lon) element is a vector indicating the latitudinal(longitudinal) values of the region in $data, - + $Variable describes the variable name and its units - + other elements for extra metadata information + + $coords is a named list with elements of the coordinates vectors corresponding to the dimensions of the $data, + + $attrs is a named list with elements corresponding to attributes of the object. It has the following elements: + + $Variable is a list with the variable name in element $varName and with the metadata of all the variables in the $metadata element, + + $Dates is an array of dates of the $data element, + + other elements for extra metadata information It is possible to visualize an example of the structure of 's2dv_cube' object by opening an R session and running: @@ -84,12 +86,8 @@ Independently of the tool used to read the data from your local storage to your - this function creates one NetCDF file per start date with the name of the variable and the start date: `$VARNAME$_$YEAR$$MONTH$.nc` - each file has dimensions: lon, lat, ensemble and time. - - ### 4. CST_Load example - - ``` library(CSTools) library(zeallot) @@ -120,7 +118,7 @@ object_size(exp) object_size(obs) # 3.09 MB library(s2dv) -PlotEquiMap(exp$data[1,1,1,1,,], lon = exp$lon, lat= exp$lat, +PlotEquiMap(exp$data[1,1,1,1,,], lon = exp$coords$lon, lat= exp$coords$lat, filled.continents = FALSE, fileout = "Meteofrance_r360x180.png") ``` diff --git a/vignettes/ENSclustering_vignette.Rmd b/vignettes/ENSclustering_vignette.Rmd index 3994db0077a6ef872b2d81a8670a59da1fc9c205..073a32100d71cf19991b1081eaa7a88ac5ce7d04 100644 --- a/vignettes/ENSclustering_vignette.Rmd +++ b/vignettes/ENSclustering_vignette.Rmd @@ -42,7 +42,7 @@ For our example we will use the sample seasonal temperature data provided within Data can be loaded as follows: ```r -datalist <- CSTools::lonlat_temp$exp +datalist <- lonlat_temp$exp ``` The data will has the following dimension: @@ -67,7 +67,7 @@ Let's launch the clustering using 4 clusters (numclus), 4 EOFs (numpcs), 'mean' ```r results <- CST_EnsClustering(datalist, numclus = numcl, numpcs = 4, - time_moment = 'mean', cluster_dim = c('member', 'sdate')) + time_moment = 'mean', cluster_dim = c('member', 'sdate')) ``` The EnsClustering produces the following outputs saved in object results: @@ -75,7 +75,7 @@ The EnsClustering produces the following outputs saved in object results: ```r names(results) #[1] "cluster" "freq" "closest_member" "repr_field" -#[5] "composites" "lat" "on" +#[5] "composites" "lon" "lat" ``` diff --git a/vignettes/Figures/Analogs1.png b/vignettes/Figures/Analogs1.png index 08ecfcfa4e3dad68c06df6579c6e4c10c2240924..5b4f05a94584422a6e58a638888be481a197b3b0 100644 Binary files a/vignettes/Figures/Analogs1.png and b/vignettes/Figures/Analogs1.png differ diff --git a/vignettes/Figures/Analogs2.png b/vignettes/Figures/Analogs2.png index 9026ffa74a437eaf00e7621ff22fff6247d53573..eb67ce3f2b5a3b405a1c36cfbf5ec466d170e73d 100644 Binary files a/vignettes/Figures/Analogs2.png and b/vignettes/Figures/Analogs2.png differ diff --git a/vignettes/Figures/Analogs6.png b/vignettes/Figures/Analogs6.png index 6c48efd67482b67d4249da36978d0b4473629223..abbc0d7a93988ffd4f2350ba746474188896214e 100644 Binary files a/vignettes/Figures/Analogs6.png and b/vignettes/Figures/Analogs6.png differ diff --git a/vignettes/Figures/MostLikelyTercile_fig1.png b/vignettes/Figures/MostLikelyTercile_fig1.png index 86ba94a2c47762e182e936848a2529a305143434..bd282ed25fda569eaca3c29616e0e5c9d471eda5 100644 Binary files a/vignettes/Figures/MostLikelyTercile_fig1.png and b/vignettes/Figures/MostLikelyTercile_fig1.png differ diff --git a/vignettes/Figures/MostLikelyTercile_fig2.png b/vignettes/Figures/MostLikelyTercile_fig2.png index 342877bc82a89d4f355d3133332dd3b477c10296..b96854ad8a9a3ded41e0d3be2a148eda4b2c47b5 100644 Binary files a/vignettes/Figures/MostLikelyTercile_fig2.png and b/vignettes/Figures/MostLikelyTercile_fig2.png differ diff --git a/vignettes/MostLikelyTercile_vignette.Rmd b/vignettes/MostLikelyTercile_vignette.Rmd index b9e6b6e6e95c535b01659f21027857d6519a4b93..aa9e998e1465afb5d9f9cdafb00c28e09d3de370 100644 --- a/vignettes/MostLikelyTercile_vignette.Rmd +++ b/vignettes/MostLikelyTercile_vignette.Rmd @@ -81,13 +81,13 @@ Finally, the data are loaded using `CST_Load`: ```r -c(exp,obs) %<-% CST_Load(var = clim_var, exp = forecastsys, obs = obs, - sdates = dateseq, leadtimemin = mon1, leadtimemax = monf, - lonmin = lon_min, lonmax = lon_max, - latmin = lat_min, latmax = lat_max, - storefreq = "monthly", sampleperiod = 1, nmember = 10, - output = "lonlat", method = "bilinear", - grid = paste("r", grid, sep = "")) +c(exp, obs) %<-% CST_Load(var = clim_var, exp = forecastsys, obs = obs, + sdates = dateseq, leadtimemin = mon1, leadtimemax = monf, + lonmin = lon_min, lonmax = lon_max, + latmin = lat_min, latmax = lat_max, + storefreq = "monthly", sampleperiod = 1, nmember = 10, + output = "lonlat", method = "bilinear", + grid = paste("r", grid, sep = "")) ``` Loading the data using CST_Load returns two objects, one for the experimental data and another one for the observe data, with the same elements and compatible dimensions of the data element: @@ -107,38 +107,32 @@ The latitude and longitude are saved for later use: ```r -Lat <- exp$lat -Lon <- exp$lon +Lat <- exp$coords$lat +Lon <- exp$coords$lon ``` ### 3. Computing probabilities First, anomalies of forecast and observations are computed using cross-validation on individual members: - ``` c(Ano_Exp, Ano_Obs) %<-% CST_Anomaly(exp = exp, obs = obs, cross = TRUE, memb = TRUE) ``` - The seasonal mean of both forecasts and observations are computed by averaging over the ftime dimension. - ```r Ano_Exp$data <- MeanDims(Ano_Exp$data, 'ftime') Ano_Obs$data <- MeanDims(Ano_Obs$data, 'ftime') ``` - Finally, the probabilities of each tercile are computed by evaluating which tercile is forecasted by each ensemble member for the latest forecast (2020) using the function `ProbBins` in **s2dv** and then averaging the results along the member dimension to obtain the probability of each tercile. - ```r PB <- ProbBins(Ano_Exp$data, fcyr = numyears, thr = c(1/3, 2/3), compPeriod = "Without fcyr") prob_map <- MeanDims(PB, c('sdate', 'member', 'dataset')) ``` - ### 4. Visualization with PlotMostLikelyQuantileMap @@ -177,7 +171,6 @@ PlotEquiMap(RPSS$data[[1]], lat = Lat, lon = Lon, brks = seq(-1, 1, by = 0.1), filled.continents = FALSE) ``` - ![](./Figures/MostLikelyTercile_fig2.png) diff --git a/vignettes/MultiModelSkill_vignette.Rmd b/vignettes/MultiModelSkill_vignette.Rmd index fb66f94ff09199834a87e6b7d6c5d28a658e5015..3c043b3ada5ee550a8e799982cbde7ad31425687 100644 --- a/vignettes/MultiModelSkill_vignette.Rmd +++ b/vignettes/MultiModelSkill_vignette.Rmd @@ -20,7 +20,6 @@ The R package s2dv should be loaded by running: library(s2dv) ``` - Library *CSTools*, should be installed from CRAN and loaded: @@ -29,7 +28,6 @@ install.packages("CSTools") library(CSTools) ``` - ### 1.- Load data In this case, the seasonal temperature forecasted, initialized in November, will be used to assess the EUROSIP multi-model seasonal forecasting system consists of a number of independent coupled seasonal forecasting systems integrated into a common framework. From September 2012, the systems include those from ECMWF, the Met Office, Meteo-France and NCEP. @@ -69,7 +67,7 @@ Ask nuria.perez at bsc.es to achieve the data to run the recipe. ```r require(zeallot) -glosea5 <- '/esarchive/exp/glosea5/glosea5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$START_DATE$.nc' +glosea5 <- '/esarchive/exp/glosea5/glosea5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$YEAR$$MONTH$.nc' c(exp, obs) %<-% CST_Load(var = clim_var, exp = list(list(name = 'glosea5', path = glosea5), @@ -80,13 +78,13 @@ c(exp, obs) %<-% storefreq = "monthly", sampleperiod = 1, nmember = 9, output = "lonlat", method = "bilinear", grid = paste("r", grid, sep = "")) -#save(exp, obs, file = "../tas_toydata.RData") +# save(exp, obs, file = "../tas_toydata.RData") # Or use the following line to load the file provided in .RData format: -load(file = "./tas_toydata.RData") +# load(file = "./tas_toydata.RData") ``` -There should be two new elements loaded in the R working environment: `exp` and `obs`, containing the experimental and the observed data for temperature. It's possible to check that they are of class `sd2v_cube` by running: +There should be two new elements loaded in the R working environment: `exp` and `obs`, containing the experimental and the observed data for temperature. It is possible to check that they are of class `sd2v_cube` by running: ``` @@ -103,16 +101,14 @@ dataset member sdate ftime lat lon > dim(obs$data) dataset member sdate ftime lat lon 1 1 21 3 35 64 -Lat <- exp$lat -Lon <- exp$lon +Lat <- exp$coords$lat +Lon <- exp$coords$lon ``` - ### 2.- Computing and plotting Anomaly Correlation Coefficient The Anomaly Correlation Coefficient (ACC) is the most widely used skill metric for Seasonal Climate Forecast quality (Mishra et al., 2018). - First step is to compute the anomalies over the loaded data applying cross validation technique on individual members by running: ``` @@ -123,11 +119,11 @@ The dimensions are preserved: ``` > str(ano_exp$data) - num [1:3, 1:9, 1:21, 1:3, 1:35, 1:64] -1.647 -0.478 -0.096 1.575 1.086 ... - - attr(*, "dimensions")= chr [1:6] "dataset" "member" "sdate" "ftime" ... + num [1:21, 1, 1, 1:3, 1:35, 1:64] 0.0235 1.5511 1.3932 -0.3437 -5.9858 ... + - attr(*, "dimensions")= chr [1:6] "sdate" "dataset" "member" "ftime" ... > str(ano_obs$data) - num [1, 1, 1:21, 1:3, 1:35, 1:64] 0.0235 1.546 1.3885 -0.344 -5.972 ... - - attr(*, "dimensions")= chr [1:6] "dataset" "member" "sdate" "ftime" ... + num [1:21, 1, 1, 1:3, 1:35, 1:64] 0.0235 1.5511 1.3932 -0.3437 -5.9858 ... + - attr(*, "dimensions")= chr [1:6] "sdate" "dataset" "member" "ftime" ... ``` The ACC is obtained by running the `CST_MultiMetric` function defining the parameter 'metric' as correlation. The function also includes the option of computing the Multi-Model Mean ensemble (MMM). @@ -135,10 +131,9 @@ The ACC is obtained by running the `CST_MultiMetric` function defining the param ```r AnomDJF <- CST_MultiMetric(exp = ano_exp, obs = ano_obs, metric = 'correlation', - multimodel = TRUE) + multimodel = TRUE) ``` - The output of the function `CST_MultiMetric` is a object of class `s2dv_cube`, it contains the result of the metric, in this case correlation, in the `data` element (including the correlation for the MMM in the latest position). While other relevant data is being stored in the corresponding element of the object: @@ -146,14 +141,13 @@ While other relevant data is being stored in the corresponding element of the ob ```r > str(AnomDJF$data) List of 4 - $ corr : num [1:4, 1, 1:35, 1:64] 0.586 0.614 0.143 0.501 0.419 ... - $ p.val : num [1:4, 1, 1:35, 1:64] 0.0026 0.00153 0.26805 0.01036 0.02931 ... - $ conf.lower: num [1:4, 1, 1:35, 1:64] 0.2073 0.2485 -0.3076 0.0883 -0.0154 ... - $ conf.upper: num [1:4, 1, 1:35, 1:64] 0.812 0.827 0.541 0.767 0.72 ... + $ corr : num [1:4, 1, 1:35, 1:64] 0.576 0.649 0.142 0.535 0.459 ... + $ p.val : num [1:4, 1, 1:35, 1:64] 0.003146 0.000735 0.269773 0.00624 0.01825 ... + $ conf.lower: num [1:4, 1, 1:35, 1:64] 0.192 0.3013 -0.3087 0.1342 0.0336 ... + $ conf.upper: num [1:4, 1, 1:35, 1:64] 0.807 0.844 0.54 0.785 0.743 ... > names(AnomDJF) -[1] "data" "lon" "lat" "Variable" "Datasets" "Dates" -[7] "when" "source_files" "load_parameters" -> names(AnomDJF$Datasets) +[1] "data" "dims" "coords" "attrs" +> names(AnomDJF$attrs$Datasets) [1] "glosea5" "ecmwf/system4_m1" "meteofrance/system5_m1" "erainterim" ``` @@ -169,8 +163,7 @@ PlotCombinedMap(AnomDJF$data$corr[,1,,], lon = Lon, lat = Lat, map_select_fun = c('white', 'darkblue'), c('white', 'darkred'), c('white', 'darkorange')), - bar_titles = c("MMM", names(AnomDJF$Datasets)), - fileout = "./vignettes/Figures/MultiModelSkill_cor_tas_1992-2012.png", + bar_titles = c("MMM", names(AnomDJF$attrs$Datasets)), width = 14, height = 8) ``` @@ -201,8 +194,7 @@ PlotCombinedMap(AnomDJF$data$rms[,1,,], lon = Lon, lat = Lat, map_select_fun = m c('darkblue', 'white'), c('darkred', 'white'), c('darkorange', 'white')), - bar_titles = c("MMM", names(AnomDJF$Datasets)), - fileout = "./vignettes/Figures/MultiModelSkill_rms_tas_1992-2012.png", + bar_titles = c("MMM", names(AnomDJF$attrs$Datasets)), width = 14, height = 8) ``` @@ -230,8 +222,7 @@ PlotCombinedMap(AnomDJF$data$rmsss[,1,,], lon = Lon, lat = Lat, c('white', 'darkblue'), c('white', 'darkred'), c('white', 'darkorange')), - bar_titles = c("MMM", names(AnomDJF$Datasets)), - fileout = "./vignettes/Figures/MultiModelSkill_rmsss_tas_1992-2012.png", + bar_titles = c("MMM", names(AnomDJF$attrs$Datasets)), width = 14, height = 8) ``` diff --git a/vignettes/MultivarRMSE_vignette.Rmd b/vignettes/MultivarRMSE_vignette.Rmd index edfbe0b8a5b95507dadac736943146ef7cf3bb07..3571972fb86be9d1973fc7a6e2c3c73db3899882 100644 --- a/vignettes/MultivarRMSE_vignette.Rmd +++ b/vignettes/MultivarRMSE_vignette.Rmd @@ -20,10 +20,8 @@ library(s2dv) library(RColorBrewer) ``` - Library *CSTools*, should be installed from CRAN and loaded: - ```r install.packages("CSTools") library(CSTools) @@ -36,14 +34,12 @@ In this example, the seasonal temperature and precipitation forecasts, initializ The parameters defined are the initializing month and the variables: - ```{r cars} mth = '11' temp = 'tas' precip = 'prlr' ``` - The simulations available for this model cover the period 1992-2012. So, the starting and ending dates can be defined by running the following lines: @@ -55,7 +51,6 @@ end <- as.Date(paste(fin, mth, "01", sep = ""), "%Y%m%d") dateseq <- format(seq(start, end, by = "year"), "%Y%m%d") ``` - The grid in which all data will be interpolated should be also specified. The observational dataset used in this example is the EraInterim. @@ -70,28 +65,30 @@ Ask nuria.perez at bsc.es for the data to run the recipe. ```r require(zeallot) -glosea5 <- list(name = 'glosea5', path = '/esarchive/exp/glosea5/glosea5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$START_DATE$.nc') +glosea5 <- '/esarchive/exp/glosea5/glosea5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$YEAR$$MONTH$.nc' + +c(exp_T, obs_T) %<-% + CST_Load(var = temp, exp = list(list(name = 'glosea5', path = glosea5)), + obs = obs, sdates = dateseq, leadtimemin = 2, leadtimemax = 4, + latmin = 25, latmax = 75, lonmin = -20, lonmax = 70, output = 'lonlat', + nprocs = 1, storefreq = "monthly", sampleperiod = 1, nmember = 9, + method = "bilinear", grid = paste("r", grid, sep = "")) - c(exp_T, obs_T) %<-% - CST_Load(var = temp, exp = list(glosea5), - obs = obs, sdates = dateseq, leadtimemin = 2, leadtimemax = 4, - latmin = 25, latmax = 75, lonmin = -20, lonmax = 70, output = 'lonlat', - nprocs = 1, storefreq = "monthly", sampleperiod = 1, nmember = 9, - method = "bilinear", grid = paste("r", grid, sep = "")) +glosea5 <- '/esarchive/exp/glosea5/glosea5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f24h/$VAR_NAME$_$YEAR$$MONTH$.nc' c(exp_P, obs_P) %<-% - CST_Load(var = precip, exp = list(glosea5), - obs = obs, sdates = dateseq, leadtimemin = 2, leadtimemax = 4, - latmin = 25, latmax = 75, lonmin = -20, lonmax = 70, output = 'lonlat', - nprocs = 1, storefreq = "monthly", sampleperiod = 1, nmember = 9, - method = "bilinear", grid = paste("r", grid, sep = "")) -#save(exp_T, obs_T, exp_P, obs_P, file = "./tas_prlr_toydata.RData") + CST_Load(var = precip, exp = list(list(name = 'glosea5', path = glosea5)), + obs = obs, sdates = dateseq, leadtimemin = 2, leadtimemax = 4, + latmin = 25, latmax = 75, lonmin = -20, lonmax = 70, output = 'lonlat', + nprocs = 1, storefreq = "monthly", sampleperiod = 1, nmember = 9, + method = "bilinear", grid = paste("r", grid, sep = "")) +# save(exp_T, obs_T, exp_P, obs_P, file = "./tas_prlr_toydata.RData") # Or use the following line to load the file provided in .RData format: -load(file = "./tas_prlr_toydata.RData") +# load(file = "./tas_prlr_toydata.RData") ``` -There should be four new elements loaded in the R working environment: `exp_T`, `obs_T`, `exp_P` and `obs_P`. The first two elements correspond to the experimental and observed data for temperature and the other are the equivalent for the precipitation data. It's possible to check that they are of class `sd2v_cube` by running: +There should be four new elements loaded in the R working environment: `exp_T`, `obs_T`, `exp_P` and `obs_P`. The first two elements correspond to the experimental and observed data for temperature and the other are the equivalent for the precipitation data. It is possible to check that they are of class `sd2v_cube` by running: ``` @@ -117,8 +114,8 @@ Latitudes and longitudes of the common grid can be saved: ```r -Lat <- exp_T$lat -Lon <- exp_T$lon +Lat <- exp_T$coords$lat +Lon <- exp_T$coords$lon ``` The next step is to compute the anomalies of the experimental and observational data using `CST_Anomaly` function, which could be applied over data from each variable, and in this case it's compute applying cross validation technique over individual members: @@ -132,11 +129,11 @@ The original dimensions are preserved and the anomalies are stored in the `data` ``` > str(ano_exp_T$data) - num [1, 1:9, 1:21, 1:3, 1:35, 1:64] -1.647 1.575 2.77 0.048 -1.886 ... - - attr(*, "dimensions")= chr [1:6] "dataset" "member" "sdate" "ftime" ... + num [1:21, 1, 1:9, 1:3, 1:35, 1:64] NA -1.3958 -0.0484 -0.1326 0.3621 ... + - attr(*, "dimensions")= chr [1:6] "sdate" "dataset" "member" "ftime" ... > str(ano_obs_T$data) - num [1, 1, 1:21, 1:3, 1:35, 1:64] 0.0235 1.546 1.3885 -0.344 -5.972 ... - - attr(*, "dimensions")= chr [1:6] "dataset" "member" "sdate" "ftime" ... + num [1:21, 1, 1, 1:3, 1:35, 1:64] 0.0235 1.5511 1.3932 -0.3437 -5.9858 ... + - attr(*, "dimensions")= chr [1:6] "sdate" "dataset" "member" "ftime" ... ``` Two lists containing the experiment ,`ano_exp`, and the observation, `ano_obs`, lists should be put together to serve as input of the function to compute multivariate RMSEs. @@ -160,28 +157,42 @@ It is obtained by running the `CST_MultivarRMSE` function: mvrmse <- CST_MultivarRMSE(exp = ano_exp, obs = ano_obs, weight) ``` - The function `CST_MultivarRMSE` returns the multivariate RMSE value for 2 or more variables. The output is a CSTool object containing the RMSE values in the `data` element and other relevant information: ```r > class(mvrmse) > str(mvrmse$data) - num [1, 1, 1, 1:35, 1:64] 0.764 0.8 0.67 0.662 0.615 ... -> str(mvrmse$Variable) - Named chr [1:2] "tas" "prlr" - - attr(*, "names")= chr [1:2] "varName" "varName" +num [1, 1, 1:35, 1:64] 985671 1017234 1023947 1017777 1217653 ... +> str(mvrmse$attrs$Variable) +List of 2 + $ varName : chr [1:2] "tas" "prlr" + $ metadata:List of 2 + ..$ tas :List of 7 + .. ..$ use_dictionary : logi FALSE + .. ..$ units : chr "K" + .. ..$ longname : chr "2 metre temperature" + .. ..$ description : chr "none" + .. ..$ daily_agg_cellfun : chr "none" + .. ..$ monthly_agg_cellfun: chr "none" + .. ..$ verification_time : chr "none" + ..$ prlr:List of 7 + .. ..$ use_dictionary : logi FALSE + .. ..$ units : chr "m s-1" + .. ..$ longname : chr "Total precipitation" + .. ..$ description : chr "none" + .. ..$ daily_agg_cellfun : chr "none" + .. ..$ monthly_agg_cellfun: chr "none" + .. ..$ verification_time : chr "none" ``` - The following lines plot the multivariate RMSE ```r PlotEquiMap(mvrmse$data, lon = Lon, lat = Lat, filled.continents = FALSE, toptitle = "Multivariate RMSE tas, prlr 1992 - 2012", colNA = "white", - bar_limits = c(0,2.5), cols = brewer.pal(n=5,name='Reds'), - fileout = "./MultivarRMSE_gloseas5_tas_prlr_1992-2012.png") + bar_limits = c(0,2.5), cols = brewer.pal(n = 5, name = 'Reds')) ``` diff --git a/vignettes/PlotForecastPDF.Rmd b/vignettes/PlotForecastPDF.Rmd index 457e7d29a328e8fbccdf6999c11bdd89854558a7..bafbe7d6d001f804329b9219eb5aa823e71e1d9b 100644 --- a/vignettes/PlotForecastPDF.Rmd +++ b/vignettes/PlotForecastPDF.Rmd @@ -24,7 +24,7 @@ The first step is to put your forecasts in an appropriate format. For this vigne ```{r,fig.show = 'hide',warning=F} fcst <- data.frame(fcst1 = rnorm(mean = 25, sd = 3, n = 30), - fcst2 = rnorm(mean = 23, sd = 4.5, n = 30)) + fcst2 = rnorm(mean = 23, sd = 4.5, n = 30)) PlotForecastPDF(fcst, tercile.limits = c(20, 26)) ``` @@ -42,11 +42,11 @@ Some parameters allow to customize your plot by changing the title, the forecast ```{r,fig.show = 'hide',warning=F} fcst <- data.frame(fcst1 = rnorm(mean = 25, sd = 3, n = 30), - fcst2 = rnorm(mean = 23, sd = 4.5, n = 30)) + fcst2 = rnorm(mean = 23, sd = 4.5, n = 30)) PlotForecastPDF(fcst, tercile.limits = c(20, 26), var.name = "Temperature (ºC)", - title = "Forecasts valid for 2019-01-01 at Sunny Hills", - fcst.names = c("model a", "model b"), - color.set = "s2s4e") + title = "Forecasts valid for 2019-01-01 at Sunny Hills", + fcst.names = c("model a", "model b"), + color.set = "s2s4e") ``` ![Example 2](./Figures/PlotForecastPDF_ex2.png) @@ -55,12 +55,12 @@ Optionally, we can include the probability of extreme values or the actually obs ```{r,fig.show = 'hide',warning=F} fcst <- data.frame(fcst1 = rnorm(mean = 25, sd = 3, n = 30), - fcst2 = rnorm(mean = 28, sd = 4.5, n = 30), fcst3 = rnorm(mean = 17, sd = 3, n = 30)) + fcst2 = rnorm(mean = 28, sd = 4.5, n = 30), fcst3 = rnorm(mean = 17, sd = 3, n = 30)) PlotForecastPDF(fcst, tercile.limits = rbind(c(20, 26), c(22, 28), c(15, 22)), - var.name = "Temperature (ºC)", title = "Forecasts at Sunny Hills", - fcst.names = c("January", "February", "March"), obs = c(21, 24, 17), - extreme.limits = rbind(c(18, 28), c(20, 30), c(12, 24)), - color.set="s2s4e") + var.name = "Temperature (ºC)", title = "Forecasts at Sunny Hills", + fcst.names = c("January", "February", "March"), obs = c(21, 24, 17), + extreme.limits = rbind(c(18, 28), c(20, 30), c(12, 24)), + color.set = "s2s4e") ``` ![Example 3](./Figures/PlotForecastPDF_ex3.png) @@ -71,8 +71,8 @@ PlotForecastPDF uses ggplot2, so you can save the output of the function to a va ``` library(ggplot2) fcst <- array(rnorm(mean = 25, sd = 2, n = 90), dim = c(member = 30, 3)) -plot <-PlotForecastPDF(fcst, tercile.limits = c(23, 27)) -ggsave("outfile.pdf", plot, width=7, height=5) +plot <- PlotForecastPDF(fcst, tercile.limits = c(23, 27)) +ggsave("outfile.pdf", plot, width = 7, height = 5) ``` ### 5.- A reproducible example using lonlat_temp @@ -82,9 +82,9 @@ This final example uses the sample lonlat data from CSTools. It is suitable for fcst <- data.frame(fcst1 = lonlat_temp$exp$data[1,,1,1,1,1] - 273.15, fcst2 = lonlat_temp$exp$data[1,,1,2,1,1] - 273.15) PlotForecastPDF(fcst, tercile.limits = c(5, 7), extreme.limits = c(4, 8), - var.name = "Temperature (ºC)", - title = "Forecasts initialized on Nov 2000 at sample Mediterranean region", - fcst.names = c("November", "December")) + var.name = "Temperature (ºC)", + title = "Forecasts initialized on Nov 2000 at sample Mediterranean region", + fcst.names = c("November", "December")) ``` ![Example 4](./Figures/PlotForecastPDF_ex4.png) diff --git a/vignettes/RainFARM_vignette.Rmd b/vignettes/RainFARM_vignette.Rmd index 5fe249f3ab7888babb68c592df3d41a1d460f7dd..070b38a18b7efcec3f721d293224dd4e4f577235 100644 --- a/vignettes/RainFARM_vignette.Rmd +++ b/vignettes/RainFARM_vignette.Rmd @@ -45,25 +45,25 @@ exp <- lonlat_prec This gives us a CSTools object `exp`, containing an element `exp$data` with dimensions: ```{r} dim(exp$data) -#dataset member sdate ftime lat lon -# 1 6 3 31 4 4 +# dataset member sdate ftime lat lon +# 1 6 3 31 4 4 ``` There are 6 ensemble members available in the data set, 3 starting dates and 31 forecast times, which refer to daily values in the month of March following starting dates on November 1st in the years 2010, 2011, 2012. Please notice that RainFARM (in this version) only accepts square domains, possibly with an even number of pixels on each side, so we always need to select an appropriate cutout. Also, there are time and memory limitations when a large ensemble of downscaled realizations is generated with RainFARM, so that selecting a smaller target area is advised. On the other hand, if spectral slopes are to be determined from the large scales we will still need enough resolution to allow this estimation. In this example we have preselected a 4x4 pixel cutout at resolution 1 degree in a smaller area lon=[6,9], lat=[44,47] covering Northern Italy. ```{r} -ilon <- which ( exp$lon %in% 5:12 ) -ilat <- which ( exp$lat %in% 40:47 ) -exp$data <- exp$data[ , , , , ilon, ilat, drop=FALSE] +ilon <- which(exp$coords$lon %in% 5:12) +ilat <- which(exp$coords$lat %in% 40:47 ) +exp$data <- exp$data[ , , , , ilon, ilat, drop = FALSE] names(dim(exp$data)) <- names(dim(lonlat_prec$data)) -exp$lon <- exp$lon[ilon] -exp$lat <- exp$lat[ilat] +exp$coords$lon <- exp$coords$lon[ilon] +exp$coords$lat <- exp$coords$lat[ilat] ``` ### Standard downscaling without climatological weights Our goal is to downscale with RainFARM these data from the resolution of 1 degree (about 100 km at these latitudes) to 0.05 degrees (about 5 km) using the `CST_RainFARM()` function. This means that we need to increase resolution by a factor `nf = 20`. RainFARM can compute automatically its only free parameter, i.e. the spatial spectral slope, from the large-scale field (here only with size 4x4 pixel, but in general we reccomend selecting at least 8x8 pixels). -In this example we would like to compute this slope as an average over the _member_ and _ftime_ dimensions, while we will use different slopes for the remaining _dataset_ and _sdate_ dimensions (a different choice may be more appropriate in a real application). To obtain this we specify the parameter `time_dim = c("member", "ftime")`. The slope is computed starting from the wavenumber corresponding to the box, `kmin=1`. We create 3 stochastic realizations for each dataset, member, starting date and forecast time with `nens=5`. The command to donwscale and the resulting fields are: +In this example we would like to compute this slope as an average over the _member_ and _ftime_ dimensions, while we will use different slopes for the remaining _dataset_ and _sdate_ dimensions (a different choice may be more appropriate in a real application). To obtain this we specify the parameter `time_dim = c("member", "ftime")`. The slope is computed starting from the wavenumber corresponding to the box, `kmin = 1`. We create 3 stochastic realizations for each dataset, member, starting date and forecast time with `nens = 5`. The command to donwscale and the resulting fields are: ```{r} exp_down <- CST_RainFARM(exp, nf = 20, kmin = 1, nens = 3, @@ -71,10 +71,10 @@ exp_down <- CST_RainFARM(exp, nf = 20, kmin = 1, nens = 3, dim(exp_down$data) # dataset member realization sdate ftime lat lon -# 1 6 3 3 31 80 80 -str(exp_down$lon) +# 1 6 3 3 31 80 80 +str(exp_down$coords$lon) # num [1:80] 5.53 5.58 5.62 5.67 5.72 ... -str(exp_down$lat) +str(exp_down$coords$lat) # num [1:80] 47.5 47.4 47.4 47.3 47.3 ... ``` The function returns an array `exp_down$data` with the additional "realization" dimension for the stochastic ensemble with 3 members. The longitudes and latitudes have been correspondingly interpolated to the finer resolution. @@ -82,7 +82,7 @@ The function returns an array `exp_down$data` with the additional "realization" Alternatively we could have used the "reduced" function `RainFARM` which accepts directly a data array (with arbitrary dimensions, provided a longitude, a latitude and a "time" dimension exist) and two arrays to describe longitudes and latitudes: ```{r} -downscaled <- RainFARM(exp$data, exp$lon, exp$lat, +downscaled <- RainFARM(exp$data, exp$coords$lon, exp$coords$lat, nf = 20, kmin = 1, nens = 3, time_dim = c("member", "ftime")) ``` @@ -92,18 +92,18 @@ Each instant and each realization will of course be different, but let's plot an ```{r} a <- exp$data[1, 1, 1, 17, , ] * 86400 * 1000 a[a > 60] <- 60 -image(exp$lon, rev(exp$lat), t(apply(a, 2, rev)), xlab = "lon", ylab = "lat", +image(exp$coords$lon, rev(exp$coords$lat), t(apply(a, 2, rev)), xlab = "lon", ylab = "lat", col = rev(terrain.colors(20)), zlim = c(0,60)) map("world", add = TRUE) title(main = "pr 17/03/2010 original") a <- exp_down$data[1, 1, 1, 1, 17, , ] * 86400 * 1000 a[a > 60] <- 60 -image(exp_down$lon, rev(exp_down$lat), t(apply(a, 2, rev)), xlab = "lon", ylab = "lat", +image(exp_down$coords$lon, rev(exp_down$coords$lat), t(apply(a, 2, rev)), xlab = "lon", ylab = "lat", col = rev(terrain.colors(20)), zlim = c(0, 60)) map("world", add = TRUE) title(main = "pr 17/03/2010 downscaled") @@ -121,7 +121,7 @@ The area of interest in our example presents a complex orography, but the basic Suitable climatology files could be for example a fine-scale precipitation climatology from a high-resolution regional climate model (see e.g. Terzago et al. 2018), a local high-resolution gridded climatology from observations, or a reconstruction such as those which can be downloaded from the WORLDCLIM (https://www.worldclim.org) or CHELSA (chelsa-climate.org) websites. The latter data will need to be converted to NetCDF format before being used (see for example the GDAL tools (https://gdal.org). We will assume that a copy of the WORLDCLIM precipitation climatology at 30 arcseconds (about 1km resolution) is available in the local file `medscope.nc`. From this file we can derive suitable weights to be used with RainFARM using the `CST_RFWeights` functions as follows: ```{r} -ww <- CST_RFWeights("./worldclim.nc", nf = 20, lon = exp$lon, lat = exp$lat) +ww <- CST_RFWeights("./worldclim.nc", nf = 20, lon = exp$coords$lon, lat = exp$coords$lat) ``` The result is a two-dimensional weights matrix with the same `lon`and `lat` dimensions as requested. The weights (varying around an average value of 1) encode how to distribute differently precipitation in each stochastic realization of RainFARM. @@ -148,19 +148,19 @@ png("Figures/RainFARM_fig2.png", width = 640, height = 243) par(mfrow = c(1,3)) a <- exp_down_weights$data[1, 1, 1, 1, 17, , ] * 86400 * 1000 a[a > 60] <- 60 -image(exp_down$lon, rev(exp_down$lat), t(apply(a, 2, rev)), xlab = "lon", +image(exp_down$coords$lon, rev(exp_down$coords$lat), t(apply(a, 2, rev)), xlab = "lon", ylab = "lat", col = rev(terrain.colors(20)), zlim = c(0, 60)) map("world", add = TRUE) title(main = "pr 17/03/2010 with weights") a <- ad * 86400 * 1000 a[a > 5] <- 5 -image(exp_down$lon, rev(exp_down$lat), t(apply(a, 2, rev)), xlab = "lon", - ylab="lat", col = rev(terrain.colors(20)), zlim = c(0, 5)) +image(exp_down$coords$lon, rev(exp_down$coords$lat), t(apply(a, 2, rev)), xlab = "lon", + ylab = "lat", col = rev(terrain.colors(20)), zlim = c(0, 5)) map("world", add = TRUE) title(main = "climatology no weights") a <- adw * 86400 * 1000 a[a > 5] <- 5 -image(exp_down$lon, rev(exp_down$lat), t(apply(a, 2, rev)), xlab = "lon", +image(exp_down$coords$lon, rev(exp_down$coords$lat), t(apply(a, 2, rev)), xlab = "lon", ylab = "lat", col = rev(terrain.colors(20)), zlim = c(0, 5)) map("world", add = TRUE) title(main = "climatology with weights") diff --git a/vignettes/WeatherRegimes_vignette.Rmd b/vignettes/WeatherRegimes_vignette.Rmd index 788b25761eaac40a729cd90132b2d2abf5335a23..899067c556ab846bb6170122e0f0b7cb462b622d 100644 --- a/vignettes/WeatherRegimes_vignette.Rmd +++ b/vignettes/WeatherRegimes_vignette.Rmd @@ -45,12 +45,10 @@ c(exp, obs) %<-% CST_Load(var = 'psl', exp = 'system4_m1', lonmin = 274.5, lonmax = 45, output = 'lonlat') ``` - Notice that you need the files to be stored locally in your computer or server with correct configuration file. If you are interested into run this vignette, contact nuria.perez at bsc.es to get a data sample. The objects returned by `CST_Load()` are s2v_cube class. They contains among others, the array with the requested data. - ```r > dim(exp$data) dataset member sdate ftime lat lon @@ -59,13 +57,10 @@ dataset member sdate ftime lat lon dataset member sdate ftime lat lon 1 1 20 31 77 186 ``` - - ### 3- Daily anomalies based on a smoothed climatology) The weather regimes classification is based on daily anomalies, which have been computed by following these steps: - ```r c(ano_exp, ano_obs) %<-% CST_Anomaly(exp = exp, obs = obs, filter_span = 1) ``` @@ -78,25 +73,19 @@ The LOESS filter has been applied to the climatology to remove the short-term va `CST_WeatherRegimes()` function is used to define the clusters based on the sea level pressure anomalies from ERA-Interim. This function is based on the [*kmeans function*](https://stat.ethz.ch/R-manual/R-devel/library/stats/html/kmeans.html) from the stats R package. In this example we have made different assumptions: four clusters (`ncenters=4`) will be produced and the Empirical orthogonal functions are not used to filter the data (`EOFS=FALSE`) just to take into account the extreme values. More details about the methodology can be found in Cortesi et al. 2018 (submitted). - ```r WR_obs <- CST_WeatherRegimes(data = ano_obs, EOFs = FALSE, ncenters = 4) ``` - `CST_WeatherRegime()` provides a s2dv_cube object with several elements. `$data` the 4 weather regimes composites are stored while `$statistics` contains extra information (`$pvalue`, `$cluster`, `$persistence` and `$frequency`) which are the needed parameters for the weather regimes assessment. Further details about the outputs provided by the `CST_WeatherRegime()` function can be found in the package documentation or typing `?CST_WeatherRegimes` in the R session. - - ### 5- Visualisation of the observed weather regimes - To plot the composite maps of each regime and the mean frequencies of each cluster, we have employed the `PlotLayout()` and `PlotEquiMap()` functions available in s2dv. The object `WR_obs$data` is divided by 100 to change from Pa to hPa. As the `WR_obs$statistics$frequency` provides the monthly frequencies, the climatological frequencies are obtained as the average across the 20 years of the monthly frequencies. Note that these frequencies could slightly change as a consequence of the randomness inherent to the iterative processes involved in the k-means. ```r -clim_frequencies <- paste0('freq = ', - round(Mean1Dim(WR_obs$statistics$frequency, 1), 1), '%') -PlotLayout(PlotEquiMap, c(1, 2), lon = obs$lon, lat = obs$lat, +clim_frequencies <- paste0('freq = ', round(Mean1Dim(WR_obs$statistics$frequency, 1), 1), '%') +PlotLayout(PlotEquiMap, c(1, 2), lon = obs$coords$lon, lat = obs$coords$lat, var = WR_obs$data / 100, titles = paste0(paste0('Cluster ', 1:4), ' (', clim_frequencies,' )'), filled.continents = FALSE, @@ -117,21 +106,19 @@ freq_obs[is.na(freq_obs)] <- 0 dim(freq_obs) <- c(dimy = 20, dimcat = 4, dimx = 1) PlotTriangles4Categories(freq_obs, toptitle = 'Persistence', - xtitle = 'Start Dates', ytitle = '', xlab = FALSE, - ylabels = substr(sdates, 1, 4), cex_leg = 0.6, - lab_legend = c('AR', 'NAO-', 'BL', 'NAO+'), figure.width = .7) + xtitle = 'Start Dates', ytitle = '', xlab = FALSE, + ylabels = substr(sdates, 1, 4), cex_leg = 0.6, + lab_legend = c('AR', 'NAO-', 'BL', 'NAO+'), figure.width = .7) ``` - ### 7- Weather regimes in the predictions Predicted anomalies for each day, month, member and lead time are matched with the observed clusters (obtained in step 4). The assignment of the anomalies to a pre-defined set of clusters guarantees that the predicted weather regimes have very similar spatial structures to the observed regimes, which is an essential requirement for the verification of weather regimes. This is an example of how to produce a set of weather regimes based on the predictions that can be verified with the observational dataset, but this approach can be also used in an operational context for which the probability of occurence of each cluster could be estimated. - The matching is based on the minimization of Eucledian distance `method='distance'`, but it can also be also done in terms of spatial correlation `method='ACC'`. However the computational efficiency is superior for the distance method. @@ -149,7 +136,7 @@ The outputs of `RegimesAssign()` have been represented to be compared with those ```r -PlotLayout(PlotEquiMap, c(1, 2),lon = exp$lon, lat = exp$lat, +PlotLayout(PlotEquiMap, c(1, 2),lon = exp$coords$lon, lat = exp$coords$lat, var = WR_exp$data/100, titles = paste0(paste0('Cluster ',1:4), ' (',paste0('freq = ', round(WR_exp$statistics$frequency,1),'%'),' )'), @@ -160,5 +147,4 @@ PlotLayout(PlotEquiMap, c(1, 2),lon = exp$lon, lat = exp$lat, ``` - Observed and predicted weather regimes are very similar although their frequencies are slightly different. Cluster 1 is the Atlantic Ridge and cluster 3 the Blocking pattern, while cluster 4 and 2 are the positive and negative phases of the NAO. This patterns can change depending on the period analyzed.