From 41dbbcf5a2728a5a48d17250ae839a8edd853c7d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 3 Oct 2023 12:36:43 +0200 Subject: [PATCH] Add sdate_dim parameter in analogs; improve initial checks and update test and examples --- R/CST_Analogs.R | 112 +++++++++++++++++++++++------- man/Analogs.Rd | 11 ++- man/CST_Analogs.Rd | 8 ++- tests/testthat/test-CST_Analogs.R | 4 +- 4 files changed, 106 insertions(+), 29 deletions(-) diff --git a/R/CST_Analogs.R b/R/CST_Analogs.R index 53706d17..402ee316 100644 --- a/R/CST_Analogs.R +++ b/R/CST_Analogs.R @@ -54,6 +54,8 @@ #' analog of parameter 'expVar'. #'@param obsVar An 's2dv_cube' containing the field of the same variable as the #' passed in parameter 'expVar' for the same region. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. By default, it is set to 'sdate'. #'@param region A vector of length four indicating the minimum longitude, the #' maximum longitude, the minimum latitude and the maximum latitude. #'@param criteria A character string indicating the criteria to be used for the @@ -77,7 +79,8 @@ #' 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{$attrs$Dates} from obsL. +#' taken from element \code{$attrs$Dates} from obsL. It must have time +#' dimensions. #'@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 @@ -117,6 +120,7 @@ #' format = "%d-%m-%y") #'dim(time_obsL) <- c(time = 10) #'time_expL <- time_obsL[1] +#'dim(time_expL) <- c(time = 1) #'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)) @@ -131,9 +135,11 @@ #' #'@import multiApply #'@import abind +#'@import s2dv #'@importFrom ClimProjDiags SelBox Subset #'@export -CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, +CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, + sdate_dim = 'sdate', region = NULL, criteria = 'Large_dist', excludeTime = NULL, time_expL = NULL, time_obsL = NULL, nAnalogs = NULL, AnalogsInfo = FALSE, @@ -215,7 +221,8 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, lonL = as.vector(obsL$coords[[lon_name]]), latL = as.vector(obsL$coords[[lat_name]]), expVar = expVar$data, - obsVar = obsVar$data, criteria = criteria, + obsVar = obsVar$data, sdate_dim = sdate_dim, + criteria = criteria, excludeTime = excludeTime, region = region, lonVar = as.vector(lonVar), latVar = as.vector(latVar), nAnalogs = nAnalogs, AnalogsInfo = AnalogsInfo, @@ -228,6 +235,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, } expL$data <- res + expL$dims <- dim(res) if (!is.null(obsL$coords[[lon_name]]) | !is.null(obsL$coords[[lat_name]])) { if (is.null(region)) { @@ -308,10 +316,12 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' the same latitudinal and longitudinal dimensions as parameter 'expL' and a #' single temporal dimension with the maximum number of available observations. #'@param time_obsL A character string indicating the date of the observations -#' in the format "dd-mm-yyyy". Reference time to search for analogs. +#' in the format "dd-mm-yyyy". Reference time to search for analogs. It must +#' have time dimensions. #'@param time_expL An array of N named dimensions (coinciding with time #' dimensions in expL) of character string(s) indicating the date(s) of the -#' experiment in the format "dd-mm-yyyy". Time(s) to find the analogs. +#' experiment in the format "dd-mm-yyyy". Time(s) to find the analogs. If it +#' is not an scalar it must have named dimensions. #'@param lonL A vector containing the longitude of parameter 'expL'. #'@param latL A vector containing the latitude of parameter 'expL'. #'@param excludeTime An array of N named dimensions (coinciding with time @@ -326,6 +336,8 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' function will be the analog of parameter 'expVar'. #'@param obsVar An array of N named dimensions containing the field of the #' same variable as the passed in parameter 'expVar' for the same region. +#'@param sdate_dim A character string indicating the name of the start date +#' dimension. By default, it is set to 'sdate'. #'@param AnalogsInfo A logical value. If it is TRUE it returns a list #' with two elements: 1) the downscaled field and #' 2) the AnalogsInfo which contains: a) the number of the best @@ -372,6 +384,7 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #'obsSLP <- c(rnorm(1:180), expSLP * 1.2) #'dim(obsSLP) <- c(time = 10, lat = 4, lon = 5) #'time_obsSLP <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-") +#'dim(time_obsSLP) <- c(time = 10) #'downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, #' time_obsL = time_obsSLP,time_expL = "01-01-1994") #' @@ -417,11 +430,12 @@ CST_Analogs <- function(expL, obsL, expVar = NULL, obsVar = NULL, region = NULL, #' AnalogsInfo = TRUE) #'@import multiApply #'@import abind +#'@import s2dv #'@importFrom ClimProjDiags SelBox Subset #'@export Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, - lonL = NULL, latL = NULL, expVar = NULL, - obsVar = NULL, criteria = "Large_dist", + lonL = NULL, latL = NULL, expVar = NULL, obsVar = NULL, + sdate_dim = 'sdate', criteria = "Large_dist", excludeTime = NULL, lonVar = NULL, latVar = NULL, region = NULL, nAnalogs = NULL, AnalogsInfo = FALSE, ncores = NULL) { @@ -536,12 +550,61 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, } if (!inherits(time_obsL, "character")) { warning('imposing time_obsL to be a character') + dims_time_obsL <- dim(time_obsL) time_obsL <- format(as.Date(time_obsL), '%d-%m-%Y') + dim(time_obsL) <- dims_time_obsL } if (!inherits(time_expL, "character")) { warning('imposing time_expL to be a character') + dims_time_expL <- dim(time_expL) time_expL <- format(as.Date(time_expL), '%d-%m-%Y') + dim(time_expL) <- dims_time_expL } + # time_obsL, time_expL (2) + if (is.null(names(dim(time_obsL)))) { + stop("Parameter 'time_obsL' must have named dimensions.") + } + if (!is.character(sdate_dim)) { + stop("Parameter 'sdate_dim' must be a character string.") + } + if (!sdate_dim %in% names(dim(time_obsL))) { + if (length(dim(time_obsL)) == 1) { + dim(time_obsL) <- c(dim(time_obsL), sdate = 1) + } else { + stop("Parameters 'time_obsL' must have 'sdate_dim' dimension name. ", + "If it has multiple time dimensions.") + } + } + if (length(time_expL) != 1) { + if (is.null(names(dim(time_expL)))) { + stop("Parameter 'time_expL' must have named dimensions.") + } + } else { + dim(time_expL) <- 1 + } + if (!sdate_dim %in% names(dim(time_expL))) { + if (length(dim(time_expL)) == 1) { + dim(time_expL) <- c(dim(time_expL), sdate = 1) + } else { + stop("Parameters 'time_expL' must have 'sdate_dim' dimension name. ", + "If it has multiple time dimensions.") + } + } + if (length(dim(time_obsL)) == 2) { + if (which(sdate_dim %in% names(dim(time_obsL))) == 1) { + time_obsL <- Reorder(time_obsL, c(2,1)) + } + } else { + warning("Parameter 'time_obsL' should have forecast time and start date dimension in this order.") + } + if (length(dim(time_expL)) == 2) { + if (which(sdate_dim %in% names(dim(time_expL))) == 1) { + time_expL <- Reorder(time_expL, c(2,1)) + } + } else { + warning("Parameter 'time_expL' should have forecast time and start date dimension in this order.") + } + # excludeTime if (!is.null(excludeTime)) { if (!inherits(excludeTime, "character")) { @@ -549,23 +612,7 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, excludeTime <- format(as.Date(excludeTime),'%d-%m-%Y') } } - # time_obsL - if (is.null(time_obsL)) { - stop("Parameter 'time_obsL' cannot be NULL") - } - if (any(names(dim(obsL)) %in% 'ftime')) { - if (any(names(dim(obsL)) %in% 'time')) { - stop("Multiple temporal dimensions ('ftime' and 'time') found", - "in parameter 'obsL'.") - } else { - time_pos_obsL <- which(names(dim(obsL)) == 'ftime') - names(dim(obsL))[time_pos_obsL] <- 'time' - if (any(names(dim(expL)) %in% 'ftime')) { - time_pos_expL <- which(names(dim(expL)) == 'ftime') - names(dim(expL))[time_pos_expL] <- 'time' - } - } - } + # obsVar, expVar if (!is.null(obsVar)) { if (any(names(dim(obsVar)) %in% 'ftime')) { if (any(names(dim(obsVar)) %in% 'time')) { @@ -581,6 +628,20 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, } } } + # obsL + if (any(names(dim(obsL)) %in% 'ftime')) { + if (any(names(dim(obsL)) %in% 'time')) { + stop("Multiple temporal dimensions ('ftime' and 'time') found", + "in parameter 'obsL'.") + } else { + time_pos_obsL <- which(names(dim(obsL)) == 'ftime') + names(dim(obsL))[time_pos_obsL] <- 'time' + if (any(names(dim(expL)) %in% 'ftime')) { + time_pos_expL <- which(names(dim(expL)) == 'ftime') + names(dim(expL))[time_pos_expL] <- 'time' + } + } + } if ((any(names(dim(obsL)) %in% 'sdate')) && (any(names(dim(obsL)) %in% 'time'))) { dims_obsL <- dim(obsL) @@ -604,7 +665,7 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, if (any(names(dim(obsL)) %in% 'time')) { dims_obsL <- dim(obsL) pos_time <- which(names(dim(obsL)) == 'time') - if(length(time_obsL) != dim(obsL)[pos_time]) { + if (length(time_obsL) != dim(obsL)[pos_time]) { stop("'time_obsL' and 'obsL' must have same length in the temporal dimension.") } @@ -618,6 +679,7 @@ Analogs <- function(expL, obsL, time_obsL, time_expL = NULL, } } } + # obsVar if (!is.null(obsVar)) { if (any(names(dim(obsVar)) %in% 'sdate')) { if (any(names(dim(obsVar)) %in% 'time')) { diff --git a/man/Analogs.Rd b/man/Analogs.Rd index 6cf62ad4..f5a89ae6 100644 --- a/man/Analogs.Rd +++ b/man/Analogs.Rd @@ -13,6 +13,7 @@ Analogs( latL = NULL, expVar = NULL, obsVar = NULL, + sdate_dim = "sdate", criteria = "Large_dist", excludeTime = NULL, lonVar = NULL, @@ -40,11 +41,13 @@ the same latitudinal and longitudinal dimensions as parameter 'expL' and a single temporal dimension with the maximum number of available observations.} \item{time_obsL}{A character string indicating the date of the observations -in the format "dd-mm-yyyy". Reference time to search for analogs.} +in the format "dd-mm-yyyy". Reference time to search for analogs. It must +have time dimensions.} \item{time_expL}{An array of N named dimensions (coinciding with time dimensions in expL) of character string(s) indicating the date(s) of the -experiment in the format "dd-mm-yyyy". Time(s) to find the analogs.} +experiment in the format "dd-mm-yyyy". Time(s) to find the analogs. If it +is not an scalar it must have named dimensions.} \item{lonL}{A vector containing the longitude of parameter 'expL'.} @@ -58,6 +61,9 @@ function will be the analog of parameter 'expVar'.} \item{obsVar}{An array of N named dimensions containing the field of the same variable as the passed in parameter 'expVar' for the same region.} +\item{sdate_dim}{A character string indicating the name of the start date +dimension. By default, it is set to 'sdate'.} + \item{criteria}{A character string indicating the criteria to be used for the selection of analogs: \itemize{\item{Large_dist} minimum Euclidean distance in the large scale pattern; @@ -148,6 +154,7 @@ dim(expSLP) <- c(lat = 4, lon = 5) obsSLP <- c(rnorm(1:180), expSLP * 1.2) dim(obsSLP) <- c(time = 10, lat = 4, lon = 5) time_obsSLP <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-") +dim(time_obsSLP) <- c(time = 10) downscale_field <- Analogs(expL = expSLP, obsL = obsSLP, time_obsL = time_obsSLP,time_expL = "01-01-1994") diff --git a/man/CST_Analogs.Rd b/man/CST_Analogs.Rd index cac70cdc..aa1e4d01 100644 --- a/man/CST_Analogs.Rd +++ b/man/CST_Analogs.Rd @@ -9,6 +9,7 @@ CST_Analogs( obsL, expVar = NULL, obsVar = NULL, + sdate_dim = "sdate", region = NULL, criteria = "Large_dist", excludeTime = NULL, @@ -42,6 +43,9 @@ analog of parameter 'expVar'.} \item{obsVar}{An 's2dv_cube' containing the field of the same variable as the passed in parameter 'expVar' for the same region.} +\item{sdate_dim}{A character string indicating the name of the start date +dimension. By default, it is set to 'sdate'.} + \item{region}{A vector of length four indicating the minimum longitude, the maximum longitude, the minimum latitude and the maximum latitude.} @@ -69,7 +73,8 @@ 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{$attrs$Dates} from obsL.} +taken from element \code{$attrs$Dates} from obsL. It must have time +dimensions.} \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 @@ -135,6 +140,7 @@ 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] +dim(time_expL) <- c(time = 1) 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)) diff --git a/tests/testthat/test-CST_Analogs.R b/tests/testthat/test-CST_Analogs.R index 80e5da86..b94e993b 100644 --- a/tests/testthat/test-CST_Analogs.R +++ b/tests/testthat/test-CST_Analogs.R @@ -8,7 +8,9 @@ obs1 <- c(rnorm(1:180), exp1 * 1.2) dim(obs1) <- c(time = 10, lat = 4, lon = 5) time_obsL1 <- paste(rep("01", 10), rep("01", 10), 1994 : 2003, sep = "-") +dim(time_obsL1) <- c(time = 10) time_expL1 <- "01-01-1994" +dim(time_expL1) <- c(time = 1) lon1 <- seq(0, 20, 5) lat1 <- seq(0, 15, 4) coords = list(lat = lat1, lon = lon1) @@ -144,7 +146,7 @@ test_that("3. Output checks" , { ) expect_equal( names(res), - c('data', 'coords', 'attrs') + c('data', 'coords', 'attrs', 'dims') ) expect_equal( dim(res$data), -- GitLab