From 95e6464a82a28d40b00fa55c5bf8e2582a32a7e7 Mon Sep 17 00:00:00 2001 From: allabres Date: Mon, 17 Apr 2023 20:13:07 +0200 Subject: [PATCH 01/87] first version of SPEI function, but it has several known issues --- R/PeriodSPEI.R | 509 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 509 insertions(+) create mode 100644 R/PeriodSPEI.R diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R new file mode 100644 index 0000000..d56916b --- /dev/null +++ b/R/PeriodSPEI.R @@ -0,0 +1,509 @@ +PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prlr, # s2dv_cubes (with coordinates lat = prlr$coords$latitude and Dates) + time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lon_dim = 'longitude', lat_dim = 'latitude', + accum = 1, start = NULL, end = NULL, + pet_method = NULL, + standardization = TRUE, + param_error = -9999, + handle_infinity = FALSE, + cross_validation = FALSE, + method = 'parametric', distribution = 'log-Logistic', fit='ub-pwm', + n_procs = 4){ + + # check provided data and parameters: + if (!is.null(pet) & !is.null(pet_method)){ + print ('WARNING: pet data is provided and also a pet estimation method, the provided pet data will be used and NOT estimated') + pet_method <- NULL + } + if (is.null(pet_method) & is.null(pet)){ + stop ('variable pet needs to be provided or a pet_method selected') + } + if ((pet_method == 'hargreaves' | pet_method == 'hargreaves_modified') & (is.null(tasmax) | is.null(tasmin))){ + stop (paste0('Need to provide tasmax and tasmin for the selected method ', pet_method)) + } + if (pet_method == 'thornthwaite' & is.null(tas)){ + stop (paste0('Need to provide tas for the selected method ', pet_method)) + } + print('WARNING: temperature needs to be in C and precipitation in mm/month') # there is no check + + # check if accumulation period is possible + if(accum > dim(prlr$data)[leadtime_dim][[1]]){ + stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', dim(prlr$data)[leadtime_dim][[1]], ' months.')) + } + + # complete dates + dates <- prlr$attrs$Dates + dates_complete_daily <- as.Date(as.Date(paste(lubridate::year(min(dates)), 01, 01, sep='-')):as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-'))) + dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) + dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] + dates_monthly <- array(0, dim=length(dates_complete_monthly)) + for (dd in 1:length(dates)){ + ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), lubridate::month(dates[dd]), 01, sep = '-'))) + dates_monthly[ii] <- 1 + } + + # Evapotranspiration estimation (unless pet is already provided) + if (is.null(pet)){ + if (pet_method == 'hargreaves'){ + data <- list(tasmax = tasmax$data, tasmin = tasmin$data, lat = prlr$coords$latitude) + } else if (pet_method == 'hargreaves_modified'){ + data <- list(tasmax = tasmax$data, tasmin = tasmin$data, prlr = prlr$data, lat = prlr$coords$latitude) + } else if (pet_method == 'thornthwaite'){ + data <- list(tas = tas$data, lat = prlr$coords$latitude) + } + pet <- evapotranspiration(data, dates_monthly, pet_method, time_dim, leadtime_dim, memb_dim, lon_dim, lat_dim, n_procs) + } + + # Accumulation + diff_P_PET <- prlr$data - pet + data_accum <- accumulation(diff_P_PET, dates_monthly, accum, time_dim, leadtime_dim, memb_dim, n_procs) + + # Standardization: + if (standardization == TRUE){ + spei_dat <- spei_standardization(data_accum = data_accum, + leadtime_dim = leadtime_dim, + time_dim = time_dim, + memb_dim = memb_dim, + cross_validation = cross_validation, + handle_infinity = handle_infinity, + n_procs = n_procs, + accum = accum, + param_error = param_error, + method = method, distribution = distribution, fit = fit) + } else { + spei_dat <- data_accum + } + + return(spei_dat) +} + + + +## functions + +evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', + time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', + lon_dim = 'longitude', lat_dim = 'latitude', + n_procs = 4){ + + lat_mask <- InsertDim(InsertDim(data$lat,pos = 1, len = 1, name = 'dat'),pos = 3, len = dim(data[[1]])[lon_dim], name = lon_dim) + + # extract mask of NA locations to return to NA the final result + mask_NA <- array(1, dim = dim(data[[1]])) + if (pet_method == 'hargreaves'){ + mask_NA[which(is.na(data$tasmax))] <- 0 + mask_NA[which(is.na(data$tasmin))] <- 0 + } + if (pet_method == 'hargreaves_modified'){ + mask_NA[which(is.na(data$tasmax))] <- 0 + mask_NA[which(is.na(data$tasmin))] <- 0 + mask_NA[which(is.na(data$prlr))] <- 0 + } + if (pet_method == 'thornthwaite'){ + mask_NA[which(is.na(tas$data))] <- 0 + } + + # replace NA with 0 + for (dd in 1:length(data)){ + data[[dd]][which(is.na(data[[dd]]))] <- 0 + } + + # prepare data + if (pet_method == 'hargreaves'){ + data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin) + targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim)) + } else if (pet_method == 'hargreaves_modified'){ + data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin, prlr = data$prlr) + targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim), prlr = c(leadtime_dim, time_dim)) + } else if (pet_method == 'thornthwaite'){ + data_input <- list(lat_mask = lat_mask, tas = data$tas) + targetdim_input <- list(lat_mask = c('dat'), tas = c(leadtime_dim, time_dim)) + } else { + stop (paste0('Unknown pet_method ', pet_method)) + } + + PET_estimated <- Apply(data = data_input, + target_dims = targetdim_input, + output_dims = c(leadtime_dim, time_dim), + pet_method = pet_method, + dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered + dim_month = leadtime_dim, dim_year = time_dim, + fun = atomic_pet, ncores = n_procs) + + # reorder dims in PET_estimated + dims_order <- array(NA, length(dim(data[[1]]))) + for (ord in 1:length(dim(data[[1]]))){ + dims_order[ord] <- which(names(dim(PET_estimated$output1)) == names(dim(data[[1]]))[ord]) + } + data_pet <- aperm(PET_estimated$output1, dims_order) + + # restore original NAs from mask_NA + data_pet[which(mask_NA == 0 )] <- NA + + return(data_pet) + +} + +accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', n_procs = 4){ + + if(!time_dim %in% names(dim(diff_P_PET))){ + diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = time_dim) + } + if(!leadtime_dim %in% names(dim(diff_P_PET))){ + diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = leadtime_dim) + } + + accum_result <- Apply(data = list(diff_P_PET), + target_dims = list(diff_P_PET = c(leadtime_dim,time_dim)), + dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered + accum = accum, + output_dims = c(leadtime_dim, time_dim), #c('time','sdate'), + dim_month = leadtime_dim, dim_year = time_dim, + fun = atomic_accum, ncores = n_procs) + + # recover essential lost dims (if they had length 1 they'd have been dropped in previous step): + for (d in c(time_dim, leadtime_dim, 'latitude', 'longitude', memb_dim)){ + if(!d %in% names(dim(accum_result$output1))){ + accum_result$output1 <- InsertDim(data = accum_result$output1, posdim = length(names(dim(accum_result$output1))) + 1, lendim = 1, name = d) + } + } + + # reorder dims in accum_result + dims_order <- array(NA, length(dim(diff_P_PET))) + for (ord in 1:length(dim(diff_P_PET))){ + dims_order[ord] <- which(names(dim(accum_result$output1)) == names(dim(diff_P_PET))[ord]) + } + data_accum <- aperm(accum_result$output1, dims_order) + + return(data_accum) + +} + +spei_standardization <- function(data_accum, + leadtime_dim, time_dim, memb_dim, handle_infinity, cross_validation, + n_procs, accum, param_error, + method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ + data_spei <- data_accum + + data_spei <- Apply(data = list(data_accum), + target_dims = list(data = c(leadtime_dim,time_dim, memb_dim)), + output_dims = c(leadtime_dim,time_dim, memb_dim), + dim_month = leadtime_dim, + dim_year = time_dim, + dim_memb = memb_dim, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, fit = fit, + ref_period = NULL, + param_error = param_error, + fun = atomic_spei, + ncores = n_procs)$output1 + + return(data_spei) + +} + +### Atomic functions + +atomic_pet <- function(pet_method, dates_monthly, dim_month, dim_year, lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL){ + + ftime = as.numeric(dim(data2)[leadtime_dim]) + n_sdates = as.numeric(dim(data2)[time_dim]) + + # create a vector from data but adding 0 to achive complete time series of the considered period + #(starting in January of the first year) so that the solar radiation estimation is computed + # in each case for the correct month + if (!is.null(data2)){ + data_tmp <- as.vector(data2) + data2 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)){ + if (dates_monthly[dd] == 1){ + data2[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (!is.null(data3)){ + data_tmp <- as.vector(data3) + data3 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)){ + if (dates_monthly[dd] == 1){ + data3[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (!is.null(data4)){ + data_tmp <- as.vector(data4) + data4 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)){ + if (dates_monthly[dd] == 1){ + data4[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (pet_method == 'hargreaves'){ + x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, na.rm = FALSE) + x_PET <- x_PET[which(dates_monthly == 1)] # line to return the vector to the size of the actual original data + PET <- array(x_PET, dim = c(ftime,n_sdates)) + } + + if (pet_method == 'hargreaves_modified'){ # not sure this works properly + PET <- array(NA, dim = c(ftime,n_sdates)) + for(ns in 1:n_sdates){ + tmax_mod_temp <- data2[12*(ns-1)+(1:12)] #data2[,ns] + tmin_mod_temp <- data3[12*(ns-1)+(1:12)] #data3[,ns] + pre_mod_temp <- data4[12*(ns-1)+(1:12)] #data4[,ns] + + # Computation of PET + x_PET <- hargreaves(Tmin = tmin_mod_temp, Tmax = tmax_mod_temp, lat = lat_mask, Pre = pre_mod_temp, na.rm = FALSE) + PET[1:ftime,ns] <- x_PET #dim <- (lon lat ft sd memb) + } + } + + if (pet_method == 'thornthwaite'){ + x_PET <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE) + x_PET <- x_PET[which(dates_monthly == 1)] # line to return the vector to the size of the actual original data + PET <- array(x_PET, dim = c(ftime,n_sdates)) + } + + return(PET) + +} + +atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ + # data:[time, syear] + + ftime = as.numeric(dim(data)[dim_month]) + n_sdates = as.numeric(dim(data)[dim_year]) + + data_vector <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)){ + if (dates_monthly[dd] == 1){ + data_vector[dd] <- as.vector(data)[count] + count <- count + 1 + } + } + + # Accumulation at different timescales + data_sum_x <- rollapply(data_vector, accum, sum) # rollapply {zoo} A generic function for applying a function to rolling margins of an array. + data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added (depends on accu) and so that the position in the vector corresponds to the accumulated of the previous months (instead of the accumulated of the next months) + data_sum_x <- data_sum_x[which(dates_monthly == 1)] # discard the months that don't appear in the original data + accum_result <- array(data_sum_x, dim = c(ftime,n_sdates)) # return to matrix form + if (accum > 1){ + accum_result[1:(accum-1),] <- NA # replace by NA when the accumulation corresponds to months that where not present in the original data + } + + return(accum_result) + +} + +atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_infinity, cross_validation, param_error, + method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ + # data: [time, sdate, memb] + if (is.null(ref_period)){ + ref.start <- NULL + ref.end <- NULL + } else { + ref.start <- ref_period[[1]] + ref.end <- ref_period[[2]] + } + + if (all(is.na(data))) { + speiX <- array(NA, dim(data)) + } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, so we assign a value to the result and skip the step + speiX <- array(param_error, dim(data)) + } else { + speiX <- spX(data, ref.start=ref.start, ref.end=ref.end, + method = method, distribution = distribution, fit = fit, + dim_month = dim_month, dim_year = dim_year, dim_memb = dim_memb, + handle_infinity = handle_infinity, cross_validation = cross_validation) + } + return(speiX) + +} + +### Support functions + +spX <- function(acc_data, ref.start, ref.end, na.rm = TRUE, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', dim_month, dim_year, dim_memb, handle_infinity, cross_validation){ + + # acc_data: [ftime, syear, nmemb] + + if (!(method %in% c('parametric', 'non-parametric'))) { + stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') + } + + ftime <- as.numeric(dim(acc_data)[dim_month]) + n_sdates <- as.numeric(dim(acc_data)[dim_year]) + nmemb <- as.numeric(dim(acc_data)[dim_memb]) + + spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) + names(dim(spei_mod)) <- c(dim_month, dim_year, dim_memb) + + for(ff in 1:ftime){ # treat months independently + Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = dim_month, indices = ff, drop = FALSE) + x_spei_mod <- spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, fit = fit, ref.start = ref.start, ref.end = ref.end, n_sdates = n_sdates, nmemb = nmemb, handle_infinity = handle_infinity, cross_validation = cross_validation) + spei_mod[ff,,] <- x_spei_mod + } + + return(spei_mod) +} + +# HandleInfinity: +spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = TRUE, method = 'parametric', n_sdates, nmemb, + ref.start = NULL, ref.end = NULL, params = NULL, handle_infinity = FALSE, cross_validation = FALSE) { + + # data:[ftime = 1, syear, ensemble] + + if (!(method %in% c('parametric', 'non-parametric'))) { + stop('SPEI can be only computed using the following approach: parametric or non-parametric') + } + + if (method == 'non-parametric'){ + + if (anyNA(data) && na.rm == FALSE) { + stop('Error: Data must not contain NAs') + } + + bp = matrix(0, length(data), 1) + for (i in 1:length(data)) { + bp[i,1] = sum(data[] <= data[i]); # Writes the rank of the data + } + + SPEI = qnorm((bp-0.44)/(length(data)+0.12)) + + return(SPEI) + + } else { + + std_index <- array(NA, c(n_sdates, nmemb)) + + if (anyNA(data) && na.rm==FALSE) { + stop('Error: Data must not contain NAs') + } + if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { + stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') + } + if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { + stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') + } + + coef = switch(distribution, + "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha','beta'))), + "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi','alpha','kappa'))), + "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu','sigma','gamma'))) + ) + + dim_one <- length(coef) + + if (!is.null(params)) { + if (length(params)!=dim_one) { + stop(paste0('parameters array should have dimensions [', dim_one, ']')) + } + } + + # Select window if necessary + if (!is.null(ref.start) && !is.null(ref.end)) { + data.fit <- window(data,ref.start,ref.end) + } else { + data.fit <- data + } + + if(cross_validation == "TRUE") { + loop_years <- n_sdates + } else { + loop_years <- 1 + } + + for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) + # Cumulative series (acu) + if (cross_validation == TRUE){ + acu <- as.vector(data.fit[,-nsd,]) + } else { + acu <- as.vector(data.fit) + } + + acu.sorted <- sort.default(acu, method = "quick") + acu.sorted <- acu.sorted[!is.na(acu.sorted)] # remove NAs (no need if(na.rm) because if there are NA and na.rm=F we don't get to this point) + if (length(acu.sorted)!=0){ # else all acu was NA and we don't need to continue with this case + acu_sd = sd(acu.sorted) + if (!is.na(acu_sd)){ + if (acu_sd != 0){ + if(distribution != "log-Logistic"){ + pze <- sum(acu==0)/length(acu) + acu.sorted = acu.sorted[acu.sorted > 0] + } + if (!is.null(params)) { + f_params = as.vector(params) + } else { + if (length(acu.sorted) >= 4){ # else coef will be NA + # Calculate probability weighted moments based on fit with lmomco or TLMoments + pwm = switch(fit, + "pp-pwm" = pwm.pp(acu.sorted,-0.35,0, nmom=3), + pwm.ub(acu.sorted, nmom=3) + #TLMoments::PWM(acu.sorted, order=0:2) + ) + + # Check L-moments validity + lmom <- pwm2lmom(pwm) + if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))){ + + # lmom fortran functions need specific inputs L1, L2, T3 + # this is handled by lmomco internally with lmorph + fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) + + # Calculate parameters based on distribution with lmom then lmomco + f_params = switch(distribution, + "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), error = function(e){ parglo(lmom)$para }), + "Gamma" = tryCatch(lmom::pelgam(fortran_vec), error = function(e){ pargam(lmom)$para }), + "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), error = function(e){ parpe3(lmom)$para }) + ) + + # Adjust if user chose log-Logistic and max-lik + if(distribution == 'log-Logistic' && fit == 'max-lik'){ + f_params = parglo.maxlik(acu.sorted, f_params)$para + } + } # end if dor the case the L-moments are not valid (std_index will be NA) + } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) + } # end estimation of f_param + # Calculate cdf based on distribution with lmom + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data, f_params), + "Gamma" = lmom::cdfgam(data, f_params), + "PearsonIII" = lmom::cdfpe3(data, f_params) + ) + + std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) + + # Adjust if user chose Gamma or PearsonIII - Not tested: For future development + #if(distribution != 'log-Logistic'){ + # std_index[ff,s] = qnorm(pze + (1-pze)*pnorm(std_index[ff,s])) # ff doesn't exist at this point + #} + if (cross_validation == TRUE){ + std_index[nsd,] <- std_index_cv[nsd,] + } else { + std_index <- std_index_cv + } + } + } # end if for the case there is no variability + } # end if for the case all NA in acu + } # next year (in case of cross_validation or all done if cross_validation == F) + + if(handle_infinity == 'TRUE'){ # could also use "param_error" ?; we are giving it the min/max value of the grid point + std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) + std_index[is.infinite(std_index) & std_index > 0] <- max(std_index[!is.infinite(std_index)]) + } + + } # end parametric + + return(std_index) # fitted is the only thing used after calling this function + +} + -- GitLab From bc82389d1aa70ce237850ddfeba1775fcf6af2ab Mon Sep 17 00:00:00 2001 From: allabres Date: Tue, 9 May 2023 15:37:03 +0200 Subject: [PATCH 02/87] SPEI working version --- R/PeriodSPEI.R | 246 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 194 insertions(+), 52 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index d56916b..43fdb56 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -1,12 +1,97 @@ -PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prlr, # s2dv_cubes (with coordinates lat = prlr$coords$latitude and Dates) + +## libraries + library(s2dv) # InsertDim, ... + library(multiApply) # Apply + library(ClimProjDiags) # Subset + library(zeallot) # multiple assignment %<-% + library(SPEI) # estimation of evapotranspiration (e.g. hargreaves function) + library(zoo) # rollapply, as.Date + library(TLMoments) # pwd (Calculate probability weighted moments based on fit) + library(lmomco) # pwm2lmom (probability weighted moments to L-Moments) + library(lubridate) # year(), month(),... + +CST_PeriodSPEI <- function(exp, exp_cor = NULL, # lists of s2dv_cubes time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lon_dim = 'longitude', lat_dim = 'latitude', accum = 1, start = NULL, end = NULL, - pet_method = NULL, + pet_method_exp = 'hargreaves', + pet_method_cor = 'hargreaves', standardization = TRUE, param_error = -9999, handle_infinity = FALSE, - cross_validation = FALSE, - method = 'parametric', distribution = 'log-Logistic', fit='ub-pwm', + cross_validation = FALSE, # forced to FALSE if exp_cor is NOT NULL + method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', + n_procs = 4){ + + # obtain variables from exp (which is a list of s2dv_cubes); some of them can be NULL (if they are NULL or not on the list) + tas_exp <- exp$tas + tasmax_exp <- exp$tasmax + tasmin_exp <- exp$tasmin + pet_exp <- exp$pet + prlr_exp <- exp$prlr + + if (!is.null(exp_cor)){ + cross_validation_call <- FALSE # forced to FALSE otherwise we cannot get the params needed to standardize exp_cor + } else { + cross_validation_call <- cross_validation + } + + # call PeriodSPEI for exp (and also obtain params of the standardization, in case standardization == TRUE; + # if it's FALSE, it's not a problem because we won't need to standardize exp_cor either) + spei_exp <- PeriodSPEI(tas = tas_exp, tasmax = tasmax_exp, tasmin = tasmin_exp, pet = pet_exp, prlr = prlr_exp, + # line above need to be s2dv_cubes (with coordinates lat = prlr$coords$latitude and Dates); prlr is always needed + time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, lon_dim = lon_dim, lat_dim = lat_dim, + accum = accum, start = start, end = end, + pet_method = pet_method_exp, + standardization = standardization, + params = NULL, # not used if standardization is FALSE + param_error = param_error, # not used if standardization is FALSE + handle_infinity = handle_infinity, # not used if standardization is FALSE + cross_validation = cross_validation_call, # not used if standardization is FALSE + method = method, # not used if standardization is FALSE + distribution = distribution, # not used if standardization is FALSE or method is non-parametric + fit = fit, # not used if standardization is FALSE or method is non-parametric + n_procs = n_procs) + + # obtain variables from exp_cor (in case it is not NULL) + if (!is.null(exp_cor)){ + tas_cor <- exp_cor$tas + tasmax_cor <- exp_cor$tasmax + tasmin_cor <- exp_cor$tasmin + pet_cor <- exp_cor$pet + prlr_cor <- exp_cor$prlr + + # obtain spei of exp_cor with parameters of exp for the standardization + spei_cor <- PeriodSPEI(tas = tas_cor, tasmax = tasmax_cor, tasmin = tasmin_cor, pet = pet_cor, prlr = prlr_cor, + time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, lon_dim = lon_dim, lat_dim = lat_dim, + accum = accum, start = start, end = end, + pet_method = pet_method_cor, + standardization = standardization, + params = spei_exp$params, # not used if standardization is FALSE + param_error = param_error, # not used if standardization is FALSE + handle_infinity = handle_infinity, # not used if standardization is FALSE + cross_validation = cross_validation_call, # not used if standardization is FALSE + method = method, # not used if standardization is FALSE + distribution = distribution, # not used if standardization is FALSE or method is non-parametric + fit = fit, # not used if standardization is FALSE or method is non-parametric + n_procs = n_procs) + + return(list(spei_exp = spei_exp, spei_cor = spei_cor)) + } else { + return(spei_exp) + } + +} + +PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prlr, + time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lon_dim = 'longitude', lat_dim = 'latitude', + accum = 1, start = NULL, end = NULL, + pet_method = NULL, + standardization = TRUE, + params = NULL, # not used if standardization is FALSE + param_error = -9999, # not used if standardization is FALSE + handle_infinity = FALSE, # not used if standardization is FALSE + cross_validation = FALSE, # not used if standardization is FALSE + method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', # not used if standardization is FALSE n_procs = 4){ # check provided data and parameters: @@ -27,12 +112,14 @@ PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prl # check if accumulation period is possible if(accum > dim(prlr$data)[leadtime_dim][[1]]){ - stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', dim(prlr$data)[leadtime_dim][[1]], ' months.')) + stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', + dim(prlr$data)[leadtime_dim][[1]], ' months.')) } # complete dates dates <- prlr$attrs$Dates - dates_complete_daily <- as.Date(as.Date(paste(lubridate::year(min(dates)), 01, 01, sep='-')):as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-'))) + dates_complete_daily <- as.Date(as.Date(paste(lubridate::year(min(dates)), 01, 01, sep='-')):as.Date(paste(lubridate::year(max(dates)), + 12, 31, sep='-'))) dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] dates_monthly <- array(0, dim=length(dates_complete_monthly)) @@ -68,7 +155,7 @@ PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prl n_procs = n_procs, accum = accum, param_error = param_error, - method = method, distribution = distribution, fit = fit) + params = params, method = method, distribution = distribution, fit = fit) } else { spei_dat <- data_accum } @@ -85,7 +172,8 @@ evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', lon_dim = 'longitude', lat_dim = 'latitude', n_procs = 4){ - lat_mask <- InsertDim(InsertDim(data$lat,pos = 1, len = 1, name = 'dat'),pos = 3, len = dim(data[[1]])[lon_dim], name = lon_dim) + lat_mask <- InsertDim(InsertDim(data$lat,pos = 1, len = 1, name = 'dat'), pos = 3, len = dim(data[[1]])[lon_dim], name = lon_dim) + if(names(dim(lat_mask)[2]) == ""){names(dim(lat_mask))[2] <- 'latitude'} # extract mask of NA locations to return to NA the final result mask_NA <- array(1, dim = dim(data[[1]])) @@ -113,7 +201,8 @@ evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim)) } else if (pet_method == 'hargreaves_modified'){ data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin, prlr = data$prlr) - targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim), prlr = c(leadtime_dim, time_dim)) + targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), + tasmin = c(leadtime_dim, time_dim), prlr = c(leadtime_dim, time_dim)) } else if (pet_method == 'thornthwaite'){ data_input <- list(lat_mask = lat_mask, tas = data$tas) targetdim_input <- list(lat_mask = c('dat'), tas = c(leadtime_dim, time_dim)) @@ -125,7 +214,7 @@ evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', target_dims = targetdim_input, output_dims = c(leadtime_dim, time_dim), pet_method = pet_method, - dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered + dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to complete array of the full years dim_month = leadtime_dim, dim_year = time_dim, fun = atomic_pet, ncores = n_procs) @@ -154,7 +243,7 @@ accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear accum_result <- Apply(data = list(diff_P_PET), target_dims = list(diff_P_PET = c(leadtime_dim,time_dim)), - dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered + dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to complete array of the full years accum = accum, output_dims = c(leadtime_dim, time_dim), #c('time','sdate'), dim_month = leadtime_dim, dim_year = time_dim, @@ -181,24 +270,38 @@ accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear spei_standardization <- function(data_accum, leadtime_dim, time_dim, memb_dim, handle_infinity, cross_validation, n_procs, accum, param_error, - method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ - data_spei <- data_accum - - data_spei <- Apply(data = list(data_accum), - target_dims = list(data = c(leadtime_dim,time_dim, memb_dim)), - output_dims = c(leadtime_dim,time_dim, memb_dim), - dim_month = leadtime_dim, - dim_year = time_dim, - dim_memb = memb_dim, - handle_infinity = handle_infinity, - cross_validation = cross_validation, - method = method, distribution = distribution, fit = fit, - ref_period = NULL, - param_error = param_error, - fun = atomic_spei, - ncores = n_procs)$output1 + params = NULL, method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ - return(data_spei) + n_leadtimes <- dim(data_accum)[leadtime_dim] + n_sdates_params <- dim(data_accum)[time_dim] + if (!cross_validation){ + n_sdates_params <- 1 + } + + if (is.null(params)){ + params <- array(NA, dim = c(n_sdates_params, n_leadtimes, coef = 3)) + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } else if (length(dim(params)) < 2) { + params <- array(params, dim = c(length(params), n_sdates_params, n_leadtimes)) + params <- aperm(params, c(2,3,1)) # dim(params): [time_dim, leadtime_dim, coef] with the values repeated each time_dim and leadtime_dim + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } + + spei <- Apply(data = list(data = data_accum, params = params), + target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), params = c(time_dim, leadtime_dim, 'coef')), + output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), params = c(time_dim, leadtime_dim, 'coef')), + dim_month = leadtime_dim, + dim_year = time_dim, + dim_memb = memb_dim, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, fit = fit, + ref_period = NULL, + param_error = param_error, + fun = atomic_spei, + ncores = n_procs) + + return(spei) # spei is a list of data_spei and params } @@ -294,7 +397,9 @@ atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ # Accumulation at different timescales data_sum_x <- rollapply(data_vector, accum, sum) # rollapply {zoo} A generic function for applying a function to rolling margins of an array. - data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added (depends on accu) and so that the position in the vector corresponds to the accumulated of the previous months (instead of the accumulated of the next months) + data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added + # (depends on accu) and so that the position in the vector corresponds to the accumulated + # of the previous months (instead of the accumulated of the next months) data_sum_x <- data_sum_x[which(dates_monthly == 1)] # discard the months that don't appear in the original data accum_result <- array(data_sum_x, dim = c(ftime,n_sdates)) # return to matrix form if (accum > 1){ @@ -305,8 +410,8 @@ atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ } -atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_infinity, cross_validation, param_error, - method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ +atomic_spei <- function(data, params, dim_month, dim_year, dim_memb, ref_period, handle_infinity, cross_validation, + param_error, method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ # data: [time, sdate, memb] if (is.null(ref_period)){ ref.start <- NULL @@ -318,23 +423,30 @@ atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_ if (all(is.na(data))) { speiX <- array(NA, dim(data)) - } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, so we assign a value to the result and skip the step + } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, + # so we assign a value to the result and skip the step speiX <- array(param_error, dim(data)) } else { - speiX <- spX(data, ref.start=ref.start, ref.end=ref.end, - method = method, distribution = distribution, fit = fit, - dim_month = dim_month, dim_year = dim_year, dim_memb = dim_memb, - handle_infinity = handle_infinity, cross_validation = cross_validation) + c(speiX, params) %<-% spX(data, ref.start=ref.start, ref.end=ref.end, params = params, + method = method, distribution = distribution, fit = fit, + dim_month = dim_month, dim_year = dim_year, dim_memb = dim_memb, + handle_infinity = handle_infinity, cross_validation = cross_validation) } - return(speiX) + + return(list(speiX, params)) } ### Support functions -spX <- function(acc_data, ref.start, ref.end, na.rm = TRUE, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', dim_month, dim_year, dim_memb, handle_infinity, cross_validation){ - +spX <- function(acc_data, ref.start, ref.end, params = params, na.rm = TRUE, + method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', + dim_month, dim_year, dim_memb, handle_infinity, cross_validation){ + # acc_data: [ftime, syear, nmemb] + # params: [syear, ftime, coef] + + n_coef_max <- dim(params)['coef'] # maximum number of parameters needed to define any of the considered distributions if (!(method %in% c('parametric', 'non-parametric'))) { stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') @@ -346,14 +458,31 @@ spX <- function(acc_data, ref.start, ref.end, na.rm = TRUE, method = 'parametric spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) names(dim(spei_mod)) <- c(dim_month, dim_year, dim_memb) + if (cross_validation){ + params_result <- array(data = NA, dim = c(n_sdates, ftime, n_coef_max)) + } else { + params_result <- array(data = NA, dim = c(1, ftime, n_coef_max)) + } - for(ff in 1:ftime){ # treat months independently + for(ff in 1:ftime){ # treat months independently Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = dim_month, indices = ff, drop = FALSE) - x_spei_mod <- spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, fit = fit, ref.start = ref.start, ref.end = ref.end, n_sdates = n_sdates, nmemb = nmemb, handle_infinity = handle_infinity, cross_validation = cross_validation) + c(x_spei_mod, params_ff) %<-% spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, + fit = fit, ref.start = ref.start, ref.end = ref.end, + params = if(all(is.na(params))){NULL}else{params[,ff,]}, n_sdates = n_sdates, nmemb = nmemb, + handle_infinity = handle_infinity, cross_validation = cross_validation) spei_mod[ff,,] <- x_spei_mod + coef_names <- names(params_ff) + if (length(params_ff) < n_coef_max){ # lengthen dimension coef of params_ff in case it doesn't match the corresponding dimension of parms_months + params_ff <- append(params_ff, array(NA, dim = n_coef_max - length(params_ff))) + coef_names <- append(coef_names, '') + } + params_result[,ff,] <- params_ff } + + colnames(params_result) <- coef_names + names(dim(params_result)) <- c(dim_year, dim_month, 'coef') - return(spei_mod) + return(list(spei = spei_mod, params = params_result)) } # HandleInfinity: @@ -379,7 +508,7 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm SPEI = qnorm((bp-0.44)/(length(data)+0.12)) - return(SPEI) + return(SPEI) # it won't return params to be used in exp_cor; also it is not using handle_infinity nor cross_validation } else { @@ -421,6 +550,9 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm } else { loop_years <- 1 } + + params_result <- array(NA, dim = c(loop_years, dim_one)) + colnames(params_result) <- names(coef) for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) # Cumulative series (acu) @@ -442,6 +574,7 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm } if (!is.null(params)) { f_params = as.vector(params) + params_result[nsd,] <- f_params } else { if (length(acu.sorted) >= 4){ # else coef will be NA # Calculate probability weighted moments based on fit with lmomco or TLMoments @@ -470,16 +603,23 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm if(distribution == 'log-Logistic' && fit == 'max-lik'){ f_params = parglo.maxlik(acu.sorted, f_params)$para } + params_result[nsd,] <- f_params } # end if dor the case the L-moments are not valid (std_index will be NA) } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) } # end estimation of f_param # Calculate cdf based on distribution with lmom - cdf_res = switch(distribution, + if (all(is.na(params_result[nsd,]))){ + cdf_res <- NA + } else { + f_params <- params_result[nsd,] + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, "log-Logistic" = lmom::cdfglo(data, f_params), "Gamma" = lmom::cdfgam(data, f_params), "PearsonIII" = lmom::cdfpe3(data, f_params) - ) - + ) + } + std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) # Adjust if user chose Gamma or PearsonIII - Not tested: For future development @@ -490,20 +630,22 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm std_index[nsd,] <- std_index_cv[nsd,] } else { std_index <- std_index_cv - } + } } } # end if for the case there is no variability } # end if for the case all NA in acu } # next year (in case of cross_validation or all done if cross_validation == F) - + if(handle_infinity == 'TRUE'){ # could also use "param_error" ?; we are giving it the min/max value of the grid point std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) std_index[is.infinite(std_index) & std_index > 0] <- max(std_index[!is.infinite(std_index)]) } - - } # end parametric - return(std_index) # fitted is the only thing used after calling this function + return(list(std_index = std_index, params = params_result)) # f_params will be params only if cross_validation is FALSE + # (otherwise there will be one f_params per year; + # but the output params will be read only in the case that + # it is called with cross_validation FALSE) + + } # end parametric } - -- GitLab From f4f75caec0005b4e9d5969b791416c39c03182ac Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 25 May 2023 17:20:51 +0200 Subject: [PATCH 03/87] Develop PeriodSPEI within the package csindicators from Alba's code --- R/PeriodSPEI.R | 740 +++++++++++++++++++++++++++++++------------------ 1 file changed, 475 insertions(+), 265 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index d56916b..1eef63d 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -1,167 +1,334 @@ -PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prlr, # s2dv_cubes (with coordinates lat = prlr$coords$latitude and Dates) - time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lon_dim = 'longitude', lat_dim = 'latitude', - accum = 1, start = NULL, end = NULL, - pet_method = NULL, - standardization = TRUE, - param_error = -9999, - handle_infinity = FALSE, - cross_validation = FALSE, - method = 'parametric', distribution = 'log-Logistic', fit='ub-pwm', - n_procs = 4){ - - # check provided data and parameters: - if (!is.null(pet) & !is.null(pet_method)){ - print ('WARNING: pet data is provided and also a pet estimation method, the provided pet data will be used and NOT estimated') - pet_method <- NULL - } - if (is.null(pet_method) & is.null(pet)){ - stop ('variable pet needs to be provided or a pet_method selected') - } - if ((pet_method == 'hargreaves' | pet_method == 'hargreaves_modified') & (is.null(tasmax) | is.null(tasmin))){ - stop (paste0('Need to provide tasmax and tasmin for the selected method ', pet_method)) - } - if (pet_method == 'thornthwaite' & is.null(tas)){ - stop (paste0('Need to provide tas for the selected method ', pet_method)) - } - print('WARNING: temperature needs to be in C and precipitation in mm/month') # there is no check - # check if accumulation period is possible - if(accum > dim(prlr$data)[leadtime_dim][[1]]){ - stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', dim(prlr$data)[leadtime_dim][[1]], ' months.')) - } +#------------------------------------------------------------------------------- +# To DO: Add documentation of same dimensions exp and exp_cor +# To DO: Add documentation for units +# TO DO: Write Documentation + +# library(s2dv) # InsertDim, ... +# library(multiApply) # Apply +# library(ClimProjDiags) # Subset +# library(zeallot) # multiple assignment %<-% +# library(SPEI) # estimation of evapotranspiration (e.g. hargreaves function) +# library(zoo) # rollapply, as.Date +# library(TLMoments) # pwd (Calculate probability weighted moments based on fit) +# library(lmomco) # pwm2lmom (probability weighted moments to L-Moments) +# library(lubridate) # year(), month(),... + +# library(CSTools) +#------------------------------------------------------------------------------- +#'@param exp A list with the 's2dv_cube' object class containing the seasonal +#' forecast experiment in the data element. +#'@param exp_cor An object of class \code{s2dv_cube} in which the quantile +#' PeriodSPEI should be applied. If it is not specified, the PeriodSPEI +#' is calculated from object 'exp'. +#'@param pet Multidimensional array containing the Potential EvapoTranspiration +#' data. If it is NULL it is calculated using pet_method. It is NULL by default. +#'@param time_dim +#'@param leadtime_dim +#'@param memb_dim +#'@param lat_dim +#--- other params from CSIndicators +#'@param accum +#'@param start +#'@param end +#' +# --- other params +#'@param pet_method +#'@param standardization +#'@param params +#'@param param_error +#'@param handle_infinity +#'@param cross_validation +#'@param method +#'@param distribution +#'@param fit +#'@param ncores +CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', lat_dim = 'latitude', + accum = 1, start = NULL, end = NULL, + pet_method = c('hargreaves', 'hargreaves'), + standardization = TRUE, + params = NULL, # not used if standardization is FALSE + param_error = -9999, # not used if standardization is FALSE + handle_infinity = FALSE, # not used if standardization is FALSE + cross_validation = FALSE, # not used if standardization is FALSE + method = 'parametric', distribution = 'log-Logistic', + fit = 'ub-pwm', # not used if standardization is FALSE + ncores = 4) { + + #----------------------------------------------------------------------------- + # Part (1): Initial structure checks + # coordinates + .KnownLatNames <- CSTools:::.KnownLatNames() + + if (!any(names(exp[[1]]$coords) %in% .KnownLatNames)) { + stop("Spatial coordinate names of parameter 'obsL' do not match any ", + "of the names accepted by the package.") + } + lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames)]] + + #----------------------------------------------------------------------------- + # Part (2): Call to PeriodSPEI + + res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), + dates = exp[[1]]$attrs$Dates, + lat = exp[[1]]$coords[[lat_name]], + exp_cor = lapply(exp_cor, function(x) x$data), + pet = pet, + time_dim = time_dim, leadtime_dim = leadtime_dim, + memb_dim = memb_dim, lat_dim = lat_dim, + accum = accum, start = start, end = end, + pet_method = pet_method, standardization = standardization, + params = params, param_error = param_error, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, + fit = fit, ncores = ncores) + return(res) - # complete dates - dates <- prlr$attrs$Dates - dates_complete_daily <- as.Date(as.Date(paste(lubridate::year(min(dates)), 01, 01, sep='-')):as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-'))) - dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) - dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] - dates_monthly <- array(0, dim=length(dates_complete_monthly)) - for (dd in 1:length(dates)){ - ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), lubridate::month(dates[dd]), 01, sep = '-'))) - dates_monthly[ii] <- 1 - } +} - # Evapotranspiration estimation (unless pet is already provided) - if (is.null(pet)){ - if (pet_method == 'hargreaves'){ - data <- list(tasmax = tasmax$data, tasmin = tasmin$data, lat = prlr$coords$latitude) - } else if (pet_method == 'hargreaves_modified'){ - data <- list(tasmax = tasmax$data, tasmin = tasmin$data, prlr = prlr$data, lat = prlr$coords$latitude) - } else if (pet_method == 'thornthwaite'){ - data <- list(tas = tas$data, lat = prlr$coords$latitude) - } - pet <- evapotranspiration(data, dates_monthly, pet_method, time_dim, leadtime_dim, memb_dim, lon_dim, lat_dim, n_procs) - } - # Accumulation - diff_P_PET <- prlr$data - pet - data_accum <- accumulation(diff_P_PET, dates_monthly, accum, time_dim, leadtime_dim, memb_dim, n_procs) - - # Standardization: - if (standardization == TRUE){ - spei_dat <- spei_standardization(data_accum = data_accum, - leadtime_dim = leadtime_dim, - time_dim = time_dim, - memb_dim = memb_dim, - cross_validation = cross_validation, - handle_infinity = handle_infinity, - n_procs = n_procs, - accum = accum, - param_error = param_error, - method = method, distribution = distribution, fit = fit) - } else { - spei_dat <- data_accum - } - return(spei_dat) +PeriodSPEI <- function(exp, dates, lat, + exp_cor = NULL, pet = NULL, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', lat_dim = 'latitude', + accum = 1, start = NULL, end = NULL, + pet_method = c('hargreaves', 'hargreaves'), + standardization = TRUE, + params = NULL, param_error = -9999, + handle_infinity = FALSE, cross_validation = FALSE, + method = 'parametric', distribution = 'log-Logistic', + fit = 'ub-pwm', ncores = 4) { + + #----------------------------------------------------------------------------- + + # Part (1): Initial checks + + ## pet and pet_method + if (is.null(pet_method) & is.null(pet)) { + warning("Parameter 'pet_method' cannot be NULL if pet is not provided.") + } + if (!is.null(exp_cor)) { + if (length(pet_method) == 1) { + pet_method <- rep(pet_method, 2) + } + if (length(exp_cor) < 1) { + exp_cor <- NULL + } + } else { + if (lenght(pet_method) > 1) { + warning("Parameter 'pet_method' is of length 2, only first value will be used.") + pet_method <- pet_method[1] + } + } + ## exp + ## TO DO: Check order: tasmax, tasmin, prlr + if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { + # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' + if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + warning("Parameter 'pet_method' needs to be 'hargreaves_modified' or 'hargreaves'.") + pet_method[1] <- 'hargreaves_modified' + } + } else if (all(c('tasmin', 'tasmax') %in% names(exp))) { + # hargreaves: 'tasmin', 'tasmax' and 'lat' + if (pet_method != c('hargreaves')) { + warning("Parameter 'pet_method' needs to be 'hargreaves'.") + pet_method[1] <- 'hargreaves' + } + + } else if ('tas' %in% names(exp)) { + # thornthwaite: 'tas' (mean), 'lat' + pet_method[1] <- 'thornthwaite' + + } else { + stop("Parameter 'exp' needs to be a list with the needed variables.") + } + + # warning(' needs to be in C and precipitation in mm/month') # there is no check + + # check if accumulation period is possible + if (accum > dim(exp[[1]])[leadtime_dim]) { + stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', + dim(exp[[1]])[leadtime_dim], ' months.')) + } + # method + if (!(method %in% c('parametric', 'non-parametric'))) { + stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') + } + # distribution + if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { + stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') + } + # fit + if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { + stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') + } + + #----------------------------------------------------------------------------- + # Part (2): preparation + + # complete dates + ini_date <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep= '-')) + end_date <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-')) + dates_complete_daily <- as.Date(ini_date:end_date) + + dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) + dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] + dates_monthly <- array(0, dim=length(dates_complete_monthly)) + for (dd in 1:length(dates)) { + ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), lubridate::month(dates[dd]), 01, sep = '-'))) + dates_monthly[ii] <- 1 + } + + #----------------------------------------------------------------------------- + # Part (3): Compute PeriodSPEI + k = 0 + spei_res <- NULL + computed_pet <- FALSE + + for (data in .return2list(exp, exp_cor)) { + k = k + 1 + # Evapotranspiration estimation (unless pet is already provided) + if (is.null(pet) | computed_pet) { + pet <- evapotranspiration(data, dates_monthly, pet_method = pet_method[k], time_dim, + leadtime_dim, memb_dim, lat_dim, ncores) + computed_pet <- TRUE + } + # Accumulation + diff_P_PET <- data$prlr - pet + data_accum <- accumulation(diff_P_PET, dates_monthly, accum, time_dim, + leadtime_dim, memb_dim, ncores) + # Standardization: + if (standardization == TRUE) { + spei_dat <- spei_standardization(data_accum = data_accum, + leadtime_dim = leadtime_dim, + time_dim = time_dim, + memb_dim = memb_dim, + cross_validation = cross_validation, + handle_infinity = handle_infinity, + ncores = ncores, + accum = accum, + param_error = param_error, + params = params, method = method, + distribution = distribution, fit = fit) + params <- spei_dat$params + } else { + spei_dat <- data_accum + } + spei_res[[k]] <- spei_dat[[1]] + } + + if (standardization) { + spei_res[[k+1]] <- params + if (is.null(exp_cor)) { + names(spei_res) <- c('exp', 'params') + } else { + names(spei_res) <- c('exp', 'exp_cor', 'params') + } + } else { + if (is.null(exp_cor)) { + names(spei_res) <- c('exp') + } else { + names(spei_res) <- c('exp', 'exp_cor') + } + } + + return(spei_res) + } - -## functions +.return2list <- function(data1, data2 = NULL) { + if (is.null(data2)) { + return(list(data1)) + } else { + return(list(data1, data2)) + } +} + + + evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', - lon_dim = 'longitude', lat_dim = 'latitude', - n_procs = 4){ + lat_dim = 'latitude', + ncores = 4) { - lat_mask <- InsertDim(InsertDim(data$lat,pos = 1, len = 1, name = 'dat'),pos = 3, len = dim(data[[1]])[lon_dim], name = lon_dim) + ## corrected:: + lat_mask <- array(lat, dim = c(1, length(lat))) + names(dim(lat_mask)) <- c('dat', lat_dim) # extract mask of NA locations to return to NA the final result - mask_NA <- array(1, dim = dim(data[[1]])) - if (pet_method == 'hargreaves'){ - mask_NA[which(is.na(data$tasmax))] <- 0 - mask_NA[which(is.na(data$tasmin))] <- 0 - } - if (pet_method == 'hargreaves_modified'){ - mask_NA[which(is.na(data$tasmax))] <- 0 - mask_NA[which(is.na(data$tasmin))] <- 0 - mask_NA[which(is.na(data$prlr))] <- 0 - } - if (pet_method == 'thornthwaite'){ - mask_NA[which(is.na(tas$data))] <- 0 - } - + + mask_NA <- array(1, dim = dim(data[[1]])) + if (pet_method == 'hargreaves') { + mask_NA[which(is.na(data$tasmax))] <- 0 + mask_NA[which(is.na(data$tasmin))] <- 0 + } else if (pet_method == 'hargreaves_modified') { + mask_NA[which(is.na(data$tasmax))] <- 0 + mask_NA[which(is.na(data$tasmin))] <- 0 + mask_NA[which(is.na(data$prlr))] <- 0 + } else if (pet_method == 'thornthwaite') { + mask_NA[which(is.na(data$tas))] <- 0 + } + # replace NA with 0 - for (dd in 1:length(data)){ + for (dd in 1:length(data)) { data[[dd]][which(is.na(data[[dd]]))] <- 0 } # prepare data - if (pet_method == 'hargreaves'){ - data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin) - targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim)) - } else if (pet_method == 'hargreaves_modified'){ - data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin, prlr = data$prlr) - targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim), prlr = c(leadtime_dim, time_dim)) - } else if (pet_method == 'thornthwaite'){ - data_input <- list(lat_mask = lat_mask, tas = data$tas) - targetdim_input <- list(lat_mask = c('dat'), tas = c(leadtime_dim, time_dim)) - } else { - stop (paste0('Unknown pet_method ', pet_method)) - } - - PET_estimated <- Apply(data = data_input, - target_dims = targetdim_input, + target_dims_data <- lapply(data, function(x) rep(c(leadtime_dim, time_dim), 1)) + # file <- tempfile() + # file = 'out.txt' + # sink(file) + PET_estimated <- Apply(data = c(list(lat_mask = lat_mask), data), + target_dims = c(list(lat_mask = 'dat'), target_dims_data), output_dims = c(leadtime_dim, time_dim), pet_method = pet_method, - dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered - dim_month = leadtime_dim, dim_year = time_dim, - fun = atomic_pet, ncores = n_procs) - + dates_monthly = dates_monthly, + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = atomic_pet, ncores = ncores)$output1 + # sink(NULL) + # captured_message <- readLines(file) + # print(paste0('Length captured!!', length(captured_message))) + # print(paste0('unique(captured_message)', length(unique(captured_message)))) + # reorder dims in PET_estimated - dims_order <- array(NA, length(dim(data[[1]]))) - for (ord in 1:length(dim(data[[1]]))){ - dims_order[ord] <- which(names(dim(PET_estimated$output1)) == names(dim(data[[1]]))[ord]) - } - data_pet <- aperm(PET_estimated$output1, dims_order) + pos <- match(names(dim(data[[1]])),names(dim(PET_estimated))) + PET_estimated <- aperm(PET_estimated, pos) # restore original NAs from mask_NA - data_pet[which(mask_NA == 0 )] <- NA + PET_estimated[which(mask_NA == 0 )] <- NA - return(data_pet) + return(PET_estimated) } -accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', n_procs = 4){ +accumulation <- function(diff_P_PET, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', ncores = 4) { - if(!time_dim %in% names(dim(diff_P_PET))){ + if (!time_dim %in% names(dim(diff_P_PET))) { diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = time_dim) } - if(!leadtime_dim %in% names(dim(diff_P_PET))){ + if (!leadtime_dim %in% names(dim(diff_P_PET))) { diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = leadtime_dim) } accum_result <- Apply(data = list(diff_P_PET), target_dims = list(diff_P_PET = c(leadtime_dim,time_dim)), - dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered + dates_monthly = dates_monthly, accum = accum, output_dims = c(leadtime_dim, time_dim), #c('time','sdate'), - dim_month = leadtime_dim, dim_year = time_dim, - fun = atomic_accum, ncores = n_procs) + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = atomic_accum, ncores = ncores) # recover essential lost dims (if they had length 1 they'd have been dropped in previous step): - for (d in c(time_dim, leadtime_dim, 'latitude', 'longitude', memb_dim)){ + for (d in c(time_dim, leadtime_dim, 'latitude', 'longitude', memb_dim)) { if(!d %in% names(dim(accum_result$output1))){ accum_result$output1 <- InsertDim(data = accum_result$output1, posdim = length(names(dim(accum_result$output1))) + 1, lendim = 1, name = d) } @@ -179,113 +346,126 @@ accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear } spei_standardization <- function(data_accum, - leadtime_dim, time_dim, memb_dim, handle_infinity, cross_validation, - n_procs, accum, param_error, - method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ - data_spei <- data_accum - - data_spei <- Apply(data = list(data_accum), - target_dims = list(data = c(leadtime_dim,time_dim, memb_dim)), - output_dims = c(leadtime_dim,time_dim, memb_dim), - dim_month = leadtime_dim, - dim_year = time_dim, - dim_memb = memb_dim, - handle_infinity = handle_infinity, - cross_validation = cross_validation, - method = method, distribution = distribution, fit = fit, - ref_period = NULL, - param_error = param_error, - fun = atomic_spei, - ncores = n_procs)$output1 - - return(data_spei) + leadtime_dim, time_dim, memb_dim, handle_infinity, + cross_validation, ncores, accum, param_error, + params = NULL, method ='parametric', + distribution = 'log-Logistic', fit='ub-pwm') { -} + n_leadtimes <- dim(data_accum)[leadtime_dim] + n_sdates_params <- dim(data_accum)[time_dim] + + if (!cross_validation) { + n_sdates_params <- 1 + } -### Atomic functions + if (is.null(params)) { + params <- array(NA, dim = c(n_sdates_params, n_leadtimes, coef = 3)) + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } else if (length(dim(params)) < 2) { + params <- array(params, dim = c(length(params), n_sdates_params, n_leadtimes)) + params <- aperm(params, c(2,3,1)) # dim(params): [time_dim, leadtime_dim, coef] with the values repeated each time_dim and leadtime_dim + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } + + spei <- Apply(data = list(data = data_accum, params = params), + target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), + output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), + leadtime_dim = leadtime_dim, + time_dim = time_dim, + dim_memb = memb_dim, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, fit = fit, + ref_period = NULL, + param_error = param_error, + fun = atomic_spei, + ncores = ncores) + + return(spei) # spei is a list of data_spei and params +} -atomic_pet <- function(pet_method, dates_monthly, dim_month, dim_year, lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL){ +atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL, + pet_method, dates_monthly, leadtime_dim, time_dim) { - ftime = as.numeric(dim(data2)[leadtime_dim]) - n_sdates = as.numeric(dim(data2)[time_dim]) - - # create a vector from data but adding 0 to achive complete time series of the considered period - #(starting in January of the first year) so that the solar radiation estimation is computed - # in each case for the correct month - if (!is.null(data2)){ - data_tmp <- as.vector(data2) - data2 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)){ - if (dates_monthly[dd] == 1){ - data2[dd] <- data_tmp[count] - count <- count + 1 - } + dims <- dim(data2) + + # create a vector from data but adding 0 to achive complete time series + # of the considered period + # (starting in January of the first year) so that the solar radiation + # estimation is computed in each case for the correct month + + if (!is.null(data2)) { + data_tmp <- as.vector(data2) + data2 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data2[dd] <- data_tmp[count] + count <- count + 1 } - rm(data_tmp) } - if (!is.null(data3)){ - data_tmp <- as.vector(data3) - data3 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)){ - if (dates_monthly[dd] == 1){ - data3[dd] <- data_tmp[count] - count <- count + 1 - } + rm(data_tmp) + } + if (!is.null(data3)) { + data_tmp <- as.vector(data3) + data3 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data3[dd] <- data_tmp[count] + count <- count + 1 } - rm(data_tmp) } - if (!is.null(data4)){ - data_tmp <- as.vector(data4) - data4 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)){ - if (dates_monthly[dd] == 1){ - data4[dd] <- data_tmp[count] - count <- count + 1 - } + rm(data_tmp) + } + if (!is.null(data4)) { + data_tmp <- as.vector(data4) + data4 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data4[dd] <- data_tmp[count] + count <- count + 1 } - rm(data_tmp) } - if (pet_method == 'hargreaves'){ - x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, na.rm = FALSE) - x_PET <- x_PET[which(dates_monthly == 1)] # line to return the vector to the size of the actual original data - PET <- array(x_PET, dim = c(ftime,n_sdates)) + rm(data_tmp) + } + if (pet_method == 'hargreaves') { + # NOTE EVA: if NA.RM is FALSE this gives error + x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = TRUE) + # line to return the vector to the size of the actual original data + x_PET <- x_PET[which(dates_monthly == 1)] + PET <- array(x_PET, dim = dims) } - if (pet_method == 'hargreaves_modified'){ # not sure this works properly - PET <- array(NA, dim = c(ftime,n_sdates)) - for(ns in 1:n_sdates){ - tmax_mod_temp <- data2[12*(ns-1)+(1:12)] #data2[,ns] - tmin_mod_temp <- data3[12*(ns-1)+(1:12)] #data3[,ns] - pre_mod_temp <- data4[12*(ns-1)+(1:12)] #data4[,ns] - - # Computation of PET - x_PET <- hargreaves(Tmin = tmin_mod_temp, Tmax = tmax_mod_temp, lat = lat_mask, Pre = pre_mod_temp, na.rm = FALSE) - PET[1:ftime,ns] <- x_PET #dim <- (lon lat ft sd memb) - } + if (pet_method == 'hargreaves_modified') { + x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = TRUE) + x_PET <- x_PET[which(dates_monthly == 1)] + PET <- array(x_PET, dim = dims) } - if (pet_method == 'thornthwaite'){ + if (pet_method == 'thornthwaite') { x_PET <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE) - x_PET <- x_PET[which(dates_monthly == 1)] # line to return the vector to the size of the actual original data - PET <- array(x_PET, dim = c(ftime,n_sdates)) + # line to return the vector to the size of the actual original data + x_PET <- x_PET[which(dates_monthly == 1)] + PET <- array(x_PET, dim = dims) } - return(PET) - } -atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ - # data:[time, syear] +atomic_accum <- function(data, dates_monthly, accum, leadtime_dim, time_dim) { - ftime = as.numeric(dim(data)[dim_month]) - n_sdates = as.numeric(dim(data)[dim_year]) + # data:[time, syear] + ftime <- dim(data)[1] + n_sdates <- dim(data)[2] data_vector <- array(0, dim = length(dates_monthly)) count <- 1 - for (dd in 1:length(dates_monthly)){ + for (dd in 1:length(dates_monthly)) { if (dates_monthly[dd] == 1){ data_vector[dd] <- as.vector(data)[count] count <- count + 1 @@ -294,21 +474,23 @@ atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ # Accumulation at different timescales data_sum_x <- rollapply(data_vector, accum, sum) # rollapply {zoo} A generic function for applying a function to rolling margins of an array. - data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added (depends on accu) and so that the position in the vector corresponds to the accumulated of the previous months (instead of the accumulated of the next months) + data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added + # (depends on accu) and so that the position in the vector corresponds to the accumulated + # of the previous months (instead of the accumulated of the next months) data_sum_x <- data_sum_x[which(dates_monthly == 1)] # discard the months that don't appear in the original data accum_result <- array(data_sum_x, dim = c(ftime,n_sdates)) # return to matrix form - if (accum > 1){ + if (accum > 1) { accum_result[1:(accum-1),] <- NA # replace by NA when the accumulation corresponds to months that where not present in the original data } return(accum_result) } - -atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_infinity, cross_validation, param_error, - method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ +atomic_spei <- function(data, params, leadtime_dim, time_dim, dim_memb, ref_period, + handle_infinity, cross_validation, param_error, method = 'parametric', + distribution = 'log-Logistic', fit = 'ub-pwm') { # data: [time, sdate, memb] - if (is.null(ref_period)){ + if (is.null(ref_period)) { ref.start <- NULL ref.end <- NULL } else { @@ -318,55 +500,76 @@ atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_ if (all(is.na(data))) { speiX <- array(NA, dim(data)) - } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, so we assign a value to the result and skip the step + } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, + # so we assign a value to the result and skip the step speiX <- array(param_error, dim(data)) } else { - speiX <- spX(data, ref.start=ref.start, ref.end=ref.end, - method = method, distribution = distribution, fit = fit, - dim_month = dim_month, dim_year = dim_year, dim_memb = dim_memb, - handle_infinity = handle_infinity, cross_validation = cross_validation) + c(speiX, params) %<-% spX(data, ref.start=ref.start, ref.end=ref.end, params = params, + method = method, distribution = distribution, fit = fit, + leadtime_dim = leadtime_dim, time_dim = time_dim, dim_memb = dim_memb, + handle_infinity = handle_infinity, cross_validation = cross_validation) } - return(speiX) + + return(list(speiX, params)) } +#------------------------------------------------------------------------------- + ### Support functions -spX <- function(acc_data, ref.start, ref.end, na.rm = TRUE, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', dim_month, dim_year, dim_memb, handle_infinity, cross_validation){ - +spX <- function(acc_data, ref.start, ref.end, params = params, na.rm = TRUE, + method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', + leadtime_dim, time_dim, dim_memb, handle_infinity, cross_validation){ + # acc_data: [ftime, syear, nmemb] + # params: [syear, ftime, coef] - if (!(method %in% c('parametric', 'non-parametric'))) { - stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') - } - - ftime <- as.numeric(dim(acc_data)[dim_month]) - n_sdates <- as.numeric(dim(acc_data)[dim_year]) + n_coef_max <- dim(params)['coef'] # maximum number of parameters needed to define any of the considered distributions + + ftime <- as.numeric(dim(acc_data)[leadtime_dim]) + n_sdates <- as.numeric(dim(acc_data)[time_dim]) nmemb <- as.numeric(dim(acc_data)[dim_memb]) spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) - names(dim(spei_mod)) <- c(dim_month, dim_year, dim_memb) + names(dim(spei_mod)) <- c(leadtime_dim, time_dim, dim_memb) + if (cross_validation) { + params_result <- array(data = NA, dim = c(n_sdates, ftime, n_coef_max)) + } else { + params_result <- array(data = NA, dim = c(1, ftime, n_coef_max)) + } - for(ff in 1:ftime){ # treat months independently - Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = dim_month, indices = ff, drop = FALSE) - x_spei_mod <- spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, fit = fit, ref.start = ref.start, ref.end = ref.end, n_sdates = n_sdates, nmemb = nmemb, handle_infinity = handle_infinity, cross_validation = cross_validation) + for (ff in 1:ftime) { # treat months independently + Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = leadtime_dim, indices = ff, drop = FALSE) + params_tmp <- if (all(is.na(params))) {NULL} else {params[,ff,]} + c(x_spei_mod, params_ff) %<-% spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, + fit = fit, ref.start = ref.start, ref.end = ref.end, + params = params_tmp, n_sdates = n_sdates, nmemb = nmemb, + handle_infinity = handle_infinity, cross_validation = cross_validation) spei_mod[ff,,] <- x_spei_mod + coef_names <- names(params_ff) + if (length(params_ff) < n_coef_max){ # lengthen dimension coef of params_ff in case it doesn't match the corresponding dimension of parms_months + params_ff <- append(params_ff, array(NA, dim = n_coef_max - length(params_ff))) + coef_names <- append(coef_names, '') + } + params_result[,ff,] <- params_ff } + + colnames(params_result) <- coef_names + names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') - return(spei_mod) + return(list(spei = spei_mod, params = params_result)) } +#------------------------------------------------------------------------------- + # HandleInfinity: spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = TRUE, method = 'parametric', n_sdates, nmemb, ref.start = NULL, ref.end = NULL, params = NULL, handle_infinity = FALSE, cross_validation = FALSE) { # data:[ftime = 1, syear, ensemble] - - if (!(method %in% c('parametric', 'non-parametric'))) { - stop('SPEI can be only computed using the following approach: parametric or non-parametric') - } - if (method == 'non-parametric'){ + if (method == 'non-parametric') { if (anyNA(data) && na.rm == FALSE) { stop('Error: Data must not contain NAs') @@ -379,48 +582,45 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm SPEI = qnorm((bp-0.44)/(length(data)+0.12)) - return(SPEI) + return(SPEI) # it won't return params to be used in exp_cor; also it is not using handle_infinity nor cross_validation } else { std_index <- array(NA, c(n_sdates, nmemb)) - if (anyNA(data) && na.rm==FALSE) { + if (anyNA(data) && na.rm == FALSE) { stop('Error: Data must not contain NAs') } - if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { - stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') - } - if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { - stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') - } + coef = switch(distribution, "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha','beta'))), "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi','alpha','kappa'))), - "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu','sigma','gamma'))) - ) + "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu','sigma','gamma')))) dim_one <- length(coef) if (!is.null(params)) { - if (length(params)!=dim_one) { + if (length(params) != dim_one) { stop(paste0('parameters array should have dimensions [', dim_one, ']')) } } # Select window if necessary - if (!is.null(ref.start) && !is.null(ref.end)) { - data.fit <- window(data,ref.start,ref.end) - } else { - data.fit <- data - } + if (!is.null(ref.start) && !is.null(ref.end)) { + data.fit <- window(data,ref.start,ref.end) + } else { + data.fit <- data + } - if(cross_validation == "TRUE") { + if (cross_validation == "TRUE") { loop_years <- n_sdates } else { loop_years <- 1 } + + params_result <- array(NA, dim = c(loop_years, dim_one)) + colnames(params_result) <- names(coef) for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) # Cumulative series (acu) @@ -436,12 +636,13 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm acu_sd = sd(acu.sorted) if (!is.na(acu_sd)){ if (acu_sd != 0){ - if(distribution != "log-Logistic"){ + if(distribution != "log-Logistic") { pze <- sum(acu==0)/length(acu) acu.sorted = acu.sorted[acu.sorted > 0] } if (!is.null(params)) { f_params = as.vector(params) + params_result[nsd,] <- f_params } else { if (length(acu.sorted) >= 4){ # else coef will be NA # Calculate probability weighted moments based on fit with lmomco or TLMoments @@ -470,16 +671,23 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm if(distribution == 'log-Logistic' && fit == 'max-lik'){ f_params = parglo.maxlik(acu.sorted, f_params)$para } + params_result[nsd,] <- f_params } # end if dor the case the L-moments are not valid (std_index will be NA) } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) } # end estimation of f_param # Calculate cdf based on distribution with lmom - cdf_res = switch(distribution, + if (all(is.na(params_result[nsd,]))){ + cdf_res <- NA + } else { + f_params <- params_result[nsd,] + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, "log-Logistic" = lmom::cdfglo(data, f_params), "Gamma" = lmom::cdfgam(data, f_params), "PearsonIII" = lmom::cdfpe3(data, f_params) - ) - + ) + } + std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) # Adjust if user chose Gamma or PearsonIII - Not tested: For future development @@ -490,20 +698,22 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm std_index[nsd,] <- std_index_cv[nsd,] } else { std_index <- std_index_cv - } + } } } # end if for the case there is no variability } # end if for the case all NA in acu } # next year (in case of cross_validation or all done if cross_validation == F) - + if(handle_infinity == 'TRUE'){ # could also use "param_error" ?; we are giving it the min/max value of the grid point std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) std_index[is.infinite(std_index) & std_index > 0] <- max(std_index[!is.infinite(std_index)]) } - - } # end parametric - return(std_index) # fitted is the only thing used after calling this function + return(list(std_index = std_index, params = params_result)) # f_params will be params only if cross_validation is FALSE + # (otherwise there will be one f_params per year; + # but the output params will be read only in the case that + # it is called with cross_validation FALSE) + + } # end parametric } - -- GitLab From 4875863e48e8041e167508182d91ef3f744f7a31 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 25 May 2023 17:23:17 +0200 Subject: [PATCH 04/87] Reapply same changes as before resolving the conflicts --- R/PeriodSPEI.R | 740 +++++++++++++++++++++++++++++++------------------ 1 file changed, 475 insertions(+), 265 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index d56916b..1eef63d 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -1,167 +1,334 @@ -PeriodSPEI <- function(tas = NULL, tasmax = NULL, tasmin = NULL, pet = NULL, prlr, # s2dv_cubes (with coordinates lat = prlr$coords$latitude and Dates) - time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lon_dim = 'longitude', lat_dim = 'latitude', - accum = 1, start = NULL, end = NULL, - pet_method = NULL, - standardization = TRUE, - param_error = -9999, - handle_infinity = FALSE, - cross_validation = FALSE, - method = 'parametric', distribution = 'log-Logistic', fit='ub-pwm', - n_procs = 4){ - - # check provided data and parameters: - if (!is.null(pet) & !is.null(pet_method)){ - print ('WARNING: pet data is provided and also a pet estimation method, the provided pet data will be used and NOT estimated') - pet_method <- NULL - } - if (is.null(pet_method) & is.null(pet)){ - stop ('variable pet needs to be provided or a pet_method selected') - } - if ((pet_method == 'hargreaves' | pet_method == 'hargreaves_modified') & (is.null(tasmax) | is.null(tasmin))){ - stop (paste0('Need to provide tasmax and tasmin for the selected method ', pet_method)) - } - if (pet_method == 'thornthwaite' & is.null(tas)){ - stop (paste0('Need to provide tas for the selected method ', pet_method)) - } - print('WARNING: temperature needs to be in C and precipitation in mm/month') # there is no check - # check if accumulation period is possible - if(accum > dim(prlr$data)[leadtime_dim][[1]]){ - stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', dim(prlr$data)[leadtime_dim][[1]], ' months.')) - } +#------------------------------------------------------------------------------- +# To DO: Add documentation of same dimensions exp and exp_cor +# To DO: Add documentation for units +# TO DO: Write Documentation + +# library(s2dv) # InsertDim, ... +# library(multiApply) # Apply +# library(ClimProjDiags) # Subset +# library(zeallot) # multiple assignment %<-% +# library(SPEI) # estimation of evapotranspiration (e.g. hargreaves function) +# library(zoo) # rollapply, as.Date +# library(TLMoments) # pwd (Calculate probability weighted moments based on fit) +# library(lmomco) # pwm2lmom (probability weighted moments to L-Moments) +# library(lubridate) # year(), month(),... + +# library(CSTools) +#------------------------------------------------------------------------------- +#'@param exp A list with the 's2dv_cube' object class containing the seasonal +#' forecast experiment in the data element. +#'@param exp_cor An object of class \code{s2dv_cube} in which the quantile +#' PeriodSPEI should be applied. If it is not specified, the PeriodSPEI +#' is calculated from object 'exp'. +#'@param pet Multidimensional array containing the Potential EvapoTranspiration +#' data. If it is NULL it is calculated using pet_method. It is NULL by default. +#'@param time_dim +#'@param leadtime_dim +#'@param memb_dim +#'@param lat_dim +#--- other params from CSIndicators +#'@param accum +#'@param start +#'@param end +#' +# --- other params +#'@param pet_method +#'@param standardization +#'@param params +#'@param param_error +#'@param handle_infinity +#'@param cross_validation +#'@param method +#'@param distribution +#'@param fit +#'@param ncores +CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', lat_dim = 'latitude', + accum = 1, start = NULL, end = NULL, + pet_method = c('hargreaves', 'hargreaves'), + standardization = TRUE, + params = NULL, # not used if standardization is FALSE + param_error = -9999, # not used if standardization is FALSE + handle_infinity = FALSE, # not used if standardization is FALSE + cross_validation = FALSE, # not used if standardization is FALSE + method = 'parametric', distribution = 'log-Logistic', + fit = 'ub-pwm', # not used if standardization is FALSE + ncores = 4) { + + #----------------------------------------------------------------------------- + # Part (1): Initial structure checks + # coordinates + .KnownLatNames <- CSTools:::.KnownLatNames() + + if (!any(names(exp[[1]]$coords) %in% .KnownLatNames)) { + stop("Spatial coordinate names of parameter 'obsL' do not match any ", + "of the names accepted by the package.") + } + lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames)]] + + #----------------------------------------------------------------------------- + # Part (2): Call to PeriodSPEI + + res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), + dates = exp[[1]]$attrs$Dates, + lat = exp[[1]]$coords[[lat_name]], + exp_cor = lapply(exp_cor, function(x) x$data), + pet = pet, + time_dim = time_dim, leadtime_dim = leadtime_dim, + memb_dim = memb_dim, lat_dim = lat_dim, + accum = accum, start = start, end = end, + pet_method = pet_method, standardization = standardization, + params = params, param_error = param_error, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, + fit = fit, ncores = ncores) + return(res) - # complete dates - dates <- prlr$attrs$Dates - dates_complete_daily <- as.Date(as.Date(paste(lubridate::year(min(dates)), 01, 01, sep='-')):as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-'))) - dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) - dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] - dates_monthly <- array(0, dim=length(dates_complete_monthly)) - for (dd in 1:length(dates)){ - ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), lubridate::month(dates[dd]), 01, sep = '-'))) - dates_monthly[ii] <- 1 - } +} - # Evapotranspiration estimation (unless pet is already provided) - if (is.null(pet)){ - if (pet_method == 'hargreaves'){ - data <- list(tasmax = tasmax$data, tasmin = tasmin$data, lat = prlr$coords$latitude) - } else if (pet_method == 'hargreaves_modified'){ - data <- list(tasmax = tasmax$data, tasmin = tasmin$data, prlr = prlr$data, lat = prlr$coords$latitude) - } else if (pet_method == 'thornthwaite'){ - data <- list(tas = tas$data, lat = prlr$coords$latitude) - } - pet <- evapotranspiration(data, dates_monthly, pet_method, time_dim, leadtime_dim, memb_dim, lon_dim, lat_dim, n_procs) - } - # Accumulation - diff_P_PET <- prlr$data - pet - data_accum <- accumulation(diff_P_PET, dates_monthly, accum, time_dim, leadtime_dim, memb_dim, n_procs) - - # Standardization: - if (standardization == TRUE){ - spei_dat <- spei_standardization(data_accum = data_accum, - leadtime_dim = leadtime_dim, - time_dim = time_dim, - memb_dim = memb_dim, - cross_validation = cross_validation, - handle_infinity = handle_infinity, - n_procs = n_procs, - accum = accum, - param_error = param_error, - method = method, distribution = distribution, fit = fit) - } else { - spei_dat <- data_accum - } - return(spei_dat) +PeriodSPEI <- function(exp, dates, lat, + exp_cor = NULL, pet = NULL, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', lat_dim = 'latitude', + accum = 1, start = NULL, end = NULL, + pet_method = c('hargreaves', 'hargreaves'), + standardization = TRUE, + params = NULL, param_error = -9999, + handle_infinity = FALSE, cross_validation = FALSE, + method = 'parametric', distribution = 'log-Logistic', + fit = 'ub-pwm', ncores = 4) { + + #----------------------------------------------------------------------------- + + # Part (1): Initial checks + + ## pet and pet_method + if (is.null(pet_method) & is.null(pet)) { + warning("Parameter 'pet_method' cannot be NULL if pet is not provided.") + } + if (!is.null(exp_cor)) { + if (length(pet_method) == 1) { + pet_method <- rep(pet_method, 2) + } + if (length(exp_cor) < 1) { + exp_cor <- NULL + } + } else { + if (lenght(pet_method) > 1) { + warning("Parameter 'pet_method' is of length 2, only first value will be used.") + pet_method <- pet_method[1] + } + } + ## exp + ## TO DO: Check order: tasmax, tasmin, prlr + if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { + # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' + if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + warning("Parameter 'pet_method' needs to be 'hargreaves_modified' or 'hargreaves'.") + pet_method[1] <- 'hargreaves_modified' + } + } else if (all(c('tasmin', 'tasmax') %in% names(exp))) { + # hargreaves: 'tasmin', 'tasmax' and 'lat' + if (pet_method != c('hargreaves')) { + warning("Parameter 'pet_method' needs to be 'hargreaves'.") + pet_method[1] <- 'hargreaves' + } + + } else if ('tas' %in% names(exp)) { + # thornthwaite: 'tas' (mean), 'lat' + pet_method[1] <- 'thornthwaite' + + } else { + stop("Parameter 'exp' needs to be a list with the needed variables.") + } + + # warning(' needs to be in C and precipitation in mm/month') # there is no check + + # check if accumulation period is possible + if (accum > dim(exp[[1]])[leadtime_dim]) { + stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', + dim(exp[[1]])[leadtime_dim], ' months.')) + } + # method + if (!(method %in% c('parametric', 'non-parametric'))) { + stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') + } + # distribution + if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { + stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') + } + # fit + if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { + stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') + } + + #----------------------------------------------------------------------------- + # Part (2): preparation + + # complete dates + ini_date <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep= '-')) + end_date <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-')) + dates_complete_daily <- as.Date(ini_date:end_date) + + dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) + dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] + dates_monthly <- array(0, dim=length(dates_complete_monthly)) + for (dd in 1:length(dates)) { + ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), lubridate::month(dates[dd]), 01, sep = '-'))) + dates_monthly[ii] <- 1 + } + + #----------------------------------------------------------------------------- + # Part (3): Compute PeriodSPEI + k = 0 + spei_res <- NULL + computed_pet <- FALSE + + for (data in .return2list(exp, exp_cor)) { + k = k + 1 + # Evapotranspiration estimation (unless pet is already provided) + if (is.null(pet) | computed_pet) { + pet <- evapotranspiration(data, dates_monthly, pet_method = pet_method[k], time_dim, + leadtime_dim, memb_dim, lat_dim, ncores) + computed_pet <- TRUE + } + # Accumulation + diff_P_PET <- data$prlr - pet + data_accum <- accumulation(diff_P_PET, dates_monthly, accum, time_dim, + leadtime_dim, memb_dim, ncores) + # Standardization: + if (standardization == TRUE) { + spei_dat <- spei_standardization(data_accum = data_accum, + leadtime_dim = leadtime_dim, + time_dim = time_dim, + memb_dim = memb_dim, + cross_validation = cross_validation, + handle_infinity = handle_infinity, + ncores = ncores, + accum = accum, + param_error = param_error, + params = params, method = method, + distribution = distribution, fit = fit) + params <- spei_dat$params + } else { + spei_dat <- data_accum + } + spei_res[[k]] <- spei_dat[[1]] + } + + if (standardization) { + spei_res[[k+1]] <- params + if (is.null(exp_cor)) { + names(spei_res) <- c('exp', 'params') + } else { + names(spei_res) <- c('exp', 'exp_cor', 'params') + } + } else { + if (is.null(exp_cor)) { + names(spei_res) <- c('exp') + } else { + names(spei_res) <- c('exp', 'exp_cor') + } + } + + return(spei_res) + } - -## functions +.return2list <- function(data1, data2 = NULL) { + if (is.null(data2)) { + return(list(data1)) + } else { + return(list(data1, data2)) + } +} + + + evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', - lon_dim = 'longitude', lat_dim = 'latitude', - n_procs = 4){ + lat_dim = 'latitude', + ncores = 4) { - lat_mask <- InsertDim(InsertDim(data$lat,pos = 1, len = 1, name = 'dat'),pos = 3, len = dim(data[[1]])[lon_dim], name = lon_dim) + ## corrected:: + lat_mask <- array(lat, dim = c(1, length(lat))) + names(dim(lat_mask)) <- c('dat', lat_dim) # extract mask of NA locations to return to NA the final result - mask_NA <- array(1, dim = dim(data[[1]])) - if (pet_method == 'hargreaves'){ - mask_NA[which(is.na(data$tasmax))] <- 0 - mask_NA[which(is.na(data$tasmin))] <- 0 - } - if (pet_method == 'hargreaves_modified'){ - mask_NA[which(is.na(data$tasmax))] <- 0 - mask_NA[which(is.na(data$tasmin))] <- 0 - mask_NA[which(is.na(data$prlr))] <- 0 - } - if (pet_method == 'thornthwaite'){ - mask_NA[which(is.na(tas$data))] <- 0 - } - + + mask_NA <- array(1, dim = dim(data[[1]])) + if (pet_method == 'hargreaves') { + mask_NA[which(is.na(data$tasmax))] <- 0 + mask_NA[which(is.na(data$tasmin))] <- 0 + } else if (pet_method == 'hargreaves_modified') { + mask_NA[which(is.na(data$tasmax))] <- 0 + mask_NA[which(is.na(data$tasmin))] <- 0 + mask_NA[which(is.na(data$prlr))] <- 0 + } else if (pet_method == 'thornthwaite') { + mask_NA[which(is.na(data$tas))] <- 0 + } + # replace NA with 0 - for (dd in 1:length(data)){ + for (dd in 1:length(data)) { data[[dd]][which(is.na(data[[dd]]))] <- 0 } # prepare data - if (pet_method == 'hargreaves'){ - data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin) - targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim)) - } else if (pet_method == 'hargreaves_modified'){ - data_input <- list(lat_mask = lat_mask, tasmax = data$tasmax, tasmin = data$tasmin, prlr = data$prlr) - targetdim_input <- list(lat_mask = c('dat'), tasmax = c(leadtime_dim, time_dim), tasmin = c(leadtime_dim, time_dim), prlr = c(leadtime_dim, time_dim)) - } else if (pet_method == 'thornthwaite'){ - data_input <- list(lat_mask = lat_mask, tas = data$tas) - targetdim_input <- list(lat_mask = c('dat'), tas = c(leadtime_dim, time_dim)) - } else { - stop (paste0('Unknown pet_method ', pet_method)) - } - - PET_estimated <- Apply(data = data_input, - target_dims = targetdim_input, + target_dims_data <- lapply(data, function(x) rep(c(leadtime_dim, time_dim), 1)) + # file <- tempfile() + # file = 'out.txt' + # sink(file) + PET_estimated <- Apply(data = c(list(lat_mask = lat_mask), data), + target_dims = c(list(lat_mask = 'dat'), target_dims_data), output_dims = c(leadtime_dim, time_dim), pet_method = pet_method, - dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered - dim_month = leadtime_dim, dim_year = time_dim, - fun = atomic_pet, ncores = n_procs) - + dates_monthly = dates_monthly, + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = atomic_pet, ncores = ncores)$output1 + # sink(NULL) + # captured_message <- readLines(file) + # print(paste0('Length captured!!', length(captured_message))) + # print(paste0('unique(captured_message)', length(unique(captured_message)))) + # reorder dims in PET_estimated - dims_order <- array(NA, length(dim(data[[1]]))) - for (ord in 1:length(dim(data[[1]]))){ - dims_order[ord] <- which(names(dim(PET_estimated$output1)) == names(dim(data[[1]]))[ord]) - } - data_pet <- aperm(PET_estimated$output1, dims_order) + pos <- match(names(dim(data[[1]])),names(dim(PET_estimated))) + PET_estimated <- aperm(PET_estimated, pos) # restore original NAs from mask_NA - data_pet[which(mask_NA == 0 )] <- NA + PET_estimated[which(mask_NA == 0 )] <- NA - return(data_pet) + return(PET_estimated) } -accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', n_procs = 4){ +accumulation <- function(diff_P_PET, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', ncores = 4) { - if(!time_dim %in% names(dim(diff_P_PET))){ + if (!time_dim %in% names(dim(diff_P_PET))) { diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = time_dim) } - if(!leadtime_dim %in% names(dim(diff_P_PET))){ + if (!leadtime_dim %in% names(dim(diff_P_PET))) { diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = leadtime_dim) } accum_result <- Apply(data = list(diff_P_PET), target_dims = list(diff_P_PET = c(leadtime_dim,time_dim)), - dates_monthly = dates_monthly, # array of 0 and 1 used to build the data_input to a complete array of the full years that are considered + dates_monthly = dates_monthly, accum = accum, output_dims = c(leadtime_dim, time_dim), #c('time','sdate'), - dim_month = leadtime_dim, dim_year = time_dim, - fun = atomic_accum, ncores = n_procs) + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = atomic_accum, ncores = ncores) # recover essential lost dims (if they had length 1 they'd have been dropped in previous step): - for (d in c(time_dim, leadtime_dim, 'latitude', 'longitude', memb_dim)){ + for (d in c(time_dim, leadtime_dim, 'latitude', 'longitude', memb_dim)) { if(!d %in% names(dim(accum_result$output1))){ accum_result$output1 <- InsertDim(data = accum_result$output1, posdim = length(names(dim(accum_result$output1))) + 1, lendim = 1, name = d) } @@ -179,113 +346,126 @@ accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear } spei_standardization <- function(data_accum, - leadtime_dim, time_dim, memb_dim, handle_infinity, cross_validation, - n_procs, accum, param_error, - method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ - data_spei <- data_accum - - data_spei <- Apply(data = list(data_accum), - target_dims = list(data = c(leadtime_dim,time_dim, memb_dim)), - output_dims = c(leadtime_dim,time_dim, memb_dim), - dim_month = leadtime_dim, - dim_year = time_dim, - dim_memb = memb_dim, - handle_infinity = handle_infinity, - cross_validation = cross_validation, - method = method, distribution = distribution, fit = fit, - ref_period = NULL, - param_error = param_error, - fun = atomic_spei, - ncores = n_procs)$output1 - - return(data_spei) + leadtime_dim, time_dim, memb_dim, handle_infinity, + cross_validation, ncores, accum, param_error, + params = NULL, method ='parametric', + distribution = 'log-Logistic', fit='ub-pwm') { -} + n_leadtimes <- dim(data_accum)[leadtime_dim] + n_sdates_params <- dim(data_accum)[time_dim] + + if (!cross_validation) { + n_sdates_params <- 1 + } -### Atomic functions + if (is.null(params)) { + params <- array(NA, dim = c(n_sdates_params, n_leadtimes, coef = 3)) + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } else if (length(dim(params)) < 2) { + params <- array(params, dim = c(length(params), n_sdates_params, n_leadtimes)) + params <- aperm(params, c(2,3,1)) # dim(params): [time_dim, leadtime_dim, coef] with the values repeated each time_dim and leadtime_dim + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } + + spei <- Apply(data = list(data = data_accum, params = params), + target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), + output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), + leadtime_dim = leadtime_dim, + time_dim = time_dim, + dim_memb = memb_dim, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, fit = fit, + ref_period = NULL, + param_error = param_error, + fun = atomic_spei, + ncores = ncores) + + return(spei) # spei is a list of data_spei and params +} -atomic_pet <- function(pet_method, dates_monthly, dim_month, dim_year, lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL){ +atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL, + pet_method, dates_monthly, leadtime_dim, time_dim) { - ftime = as.numeric(dim(data2)[leadtime_dim]) - n_sdates = as.numeric(dim(data2)[time_dim]) - - # create a vector from data but adding 0 to achive complete time series of the considered period - #(starting in January of the first year) so that the solar radiation estimation is computed - # in each case for the correct month - if (!is.null(data2)){ - data_tmp <- as.vector(data2) - data2 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)){ - if (dates_monthly[dd] == 1){ - data2[dd] <- data_tmp[count] - count <- count + 1 - } + dims <- dim(data2) + + # create a vector from data but adding 0 to achive complete time series + # of the considered period + # (starting in January of the first year) so that the solar radiation + # estimation is computed in each case for the correct month + + if (!is.null(data2)) { + data_tmp <- as.vector(data2) + data2 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data2[dd] <- data_tmp[count] + count <- count + 1 } - rm(data_tmp) } - if (!is.null(data3)){ - data_tmp <- as.vector(data3) - data3 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)){ - if (dates_monthly[dd] == 1){ - data3[dd] <- data_tmp[count] - count <- count + 1 - } + rm(data_tmp) + } + if (!is.null(data3)) { + data_tmp <- as.vector(data3) + data3 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data3[dd] <- data_tmp[count] + count <- count + 1 } - rm(data_tmp) } - if (!is.null(data4)){ - data_tmp <- as.vector(data4) - data4 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)){ - if (dates_monthly[dd] == 1){ - data4[dd] <- data_tmp[count] - count <- count + 1 - } + rm(data_tmp) + } + if (!is.null(data4)) { + data_tmp <- as.vector(data4) + data4 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data4[dd] <- data_tmp[count] + count <- count + 1 } - rm(data_tmp) } - if (pet_method == 'hargreaves'){ - x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, na.rm = FALSE) - x_PET <- x_PET[which(dates_monthly == 1)] # line to return the vector to the size of the actual original data - PET <- array(x_PET, dim = c(ftime,n_sdates)) + rm(data_tmp) + } + if (pet_method == 'hargreaves') { + # NOTE EVA: if NA.RM is FALSE this gives error + x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = TRUE) + # line to return the vector to the size of the actual original data + x_PET <- x_PET[which(dates_monthly == 1)] + PET <- array(x_PET, dim = dims) } - if (pet_method == 'hargreaves_modified'){ # not sure this works properly - PET <- array(NA, dim = c(ftime,n_sdates)) - for(ns in 1:n_sdates){ - tmax_mod_temp <- data2[12*(ns-1)+(1:12)] #data2[,ns] - tmin_mod_temp <- data3[12*(ns-1)+(1:12)] #data3[,ns] - pre_mod_temp <- data4[12*(ns-1)+(1:12)] #data4[,ns] - - # Computation of PET - x_PET <- hargreaves(Tmin = tmin_mod_temp, Tmax = tmax_mod_temp, lat = lat_mask, Pre = pre_mod_temp, na.rm = FALSE) - PET[1:ftime,ns] <- x_PET #dim <- (lon lat ft sd memb) - } + if (pet_method == 'hargreaves_modified') { + x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = TRUE) + x_PET <- x_PET[which(dates_monthly == 1)] + PET <- array(x_PET, dim = dims) } - if (pet_method == 'thornthwaite'){ + if (pet_method == 'thornthwaite') { x_PET <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE) - x_PET <- x_PET[which(dates_monthly == 1)] # line to return the vector to the size of the actual original data - PET <- array(x_PET, dim = c(ftime,n_sdates)) + # line to return the vector to the size of the actual original data + x_PET <- x_PET[which(dates_monthly == 1)] + PET <- array(x_PET, dim = dims) } - return(PET) - } -atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ - # data:[time, syear] +atomic_accum <- function(data, dates_monthly, accum, leadtime_dim, time_dim) { - ftime = as.numeric(dim(data)[dim_month]) - n_sdates = as.numeric(dim(data)[dim_year]) + # data:[time, syear] + ftime <- dim(data)[1] + n_sdates <- dim(data)[2] data_vector <- array(0, dim = length(dates_monthly)) count <- 1 - for (dd in 1:length(dates_monthly)){ + for (dd in 1:length(dates_monthly)) { if (dates_monthly[dd] == 1){ data_vector[dd] <- as.vector(data)[count] count <- count + 1 @@ -294,21 +474,23 @@ atomic_accum <- function(data, dates_monthly, accum, dim_month, dim_year){ # Accumulation at different timescales data_sum_x <- rollapply(data_vector, accum, sum) # rollapply {zoo} A generic function for applying a function to rolling margins of an array. - data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added (depends on accu) and so that the position in the vector corresponds to the accumulated of the previous months (instead of the accumulated of the next months) + data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added + # (depends on accu) and so that the position in the vector corresponds to the accumulated + # of the previous months (instead of the accumulated of the next months) data_sum_x <- data_sum_x[which(dates_monthly == 1)] # discard the months that don't appear in the original data accum_result <- array(data_sum_x, dim = c(ftime,n_sdates)) # return to matrix form - if (accum > 1){ + if (accum > 1) { accum_result[1:(accum-1),] <- NA # replace by NA when the accumulation corresponds to months that where not present in the original data } return(accum_result) } - -atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_infinity, cross_validation, param_error, - method ='parametric', distribution = 'log-Logistic', fit='ub-pwm'){ +atomic_spei <- function(data, params, leadtime_dim, time_dim, dim_memb, ref_period, + handle_infinity, cross_validation, param_error, method = 'parametric', + distribution = 'log-Logistic', fit = 'ub-pwm') { # data: [time, sdate, memb] - if (is.null(ref_period)){ + if (is.null(ref_period)) { ref.start <- NULL ref.end <- NULL } else { @@ -318,55 +500,76 @@ atomic_spei <- function(data, dim_month, dim_year, dim_memb, ref_period, handle_ if (all(is.na(data))) { speiX <- array(NA, dim(data)) - } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, so we assign a value to the result and skip the step + } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, + # so we assign a value to the result and skip the step speiX <- array(param_error, dim(data)) } else { - speiX <- spX(data, ref.start=ref.start, ref.end=ref.end, - method = method, distribution = distribution, fit = fit, - dim_month = dim_month, dim_year = dim_year, dim_memb = dim_memb, - handle_infinity = handle_infinity, cross_validation = cross_validation) + c(speiX, params) %<-% spX(data, ref.start=ref.start, ref.end=ref.end, params = params, + method = method, distribution = distribution, fit = fit, + leadtime_dim = leadtime_dim, time_dim = time_dim, dim_memb = dim_memb, + handle_infinity = handle_infinity, cross_validation = cross_validation) } - return(speiX) + + return(list(speiX, params)) } +#------------------------------------------------------------------------------- + ### Support functions -spX <- function(acc_data, ref.start, ref.end, na.rm = TRUE, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', dim_month, dim_year, dim_memb, handle_infinity, cross_validation){ - +spX <- function(acc_data, ref.start, ref.end, params = params, na.rm = TRUE, + method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', + leadtime_dim, time_dim, dim_memb, handle_infinity, cross_validation){ + # acc_data: [ftime, syear, nmemb] + # params: [syear, ftime, coef] - if (!(method %in% c('parametric', 'non-parametric'))) { - stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') - } - - ftime <- as.numeric(dim(acc_data)[dim_month]) - n_sdates <- as.numeric(dim(acc_data)[dim_year]) + n_coef_max <- dim(params)['coef'] # maximum number of parameters needed to define any of the considered distributions + + ftime <- as.numeric(dim(acc_data)[leadtime_dim]) + n_sdates <- as.numeric(dim(acc_data)[time_dim]) nmemb <- as.numeric(dim(acc_data)[dim_memb]) spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) - names(dim(spei_mod)) <- c(dim_month, dim_year, dim_memb) + names(dim(spei_mod)) <- c(leadtime_dim, time_dim, dim_memb) + if (cross_validation) { + params_result <- array(data = NA, dim = c(n_sdates, ftime, n_coef_max)) + } else { + params_result <- array(data = NA, dim = c(1, ftime, n_coef_max)) + } - for(ff in 1:ftime){ # treat months independently - Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = dim_month, indices = ff, drop = FALSE) - x_spei_mod <- spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, fit = fit, ref.start = ref.start, ref.end = ref.end, n_sdates = n_sdates, nmemb = nmemb, handle_infinity = handle_infinity, cross_validation = cross_validation) + for (ff in 1:ftime) { # treat months independently + Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = leadtime_dim, indices = ff, drop = FALSE) + params_tmp <- if (all(is.na(params))) {NULL} else {params[,ff,]} + c(x_spei_mod, params_ff) %<-% spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, + fit = fit, ref.start = ref.start, ref.end = ref.end, + params = params_tmp, n_sdates = n_sdates, nmemb = nmemb, + handle_infinity = handle_infinity, cross_validation = cross_validation) spei_mod[ff,,] <- x_spei_mod + coef_names <- names(params_ff) + if (length(params_ff) < n_coef_max){ # lengthen dimension coef of params_ff in case it doesn't match the corresponding dimension of parms_months + params_ff <- append(params_ff, array(NA, dim = n_coef_max - length(params_ff))) + coef_names <- append(coef_names, '') + } + params_result[,ff,] <- params_ff } + + colnames(params_result) <- coef_names + names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') - return(spei_mod) + return(list(spei = spei_mod, params = params_result)) } +#------------------------------------------------------------------------------- + # HandleInfinity: spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = TRUE, method = 'parametric', n_sdates, nmemb, ref.start = NULL, ref.end = NULL, params = NULL, handle_infinity = FALSE, cross_validation = FALSE) { # data:[ftime = 1, syear, ensemble] - - if (!(method %in% c('parametric', 'non-parametric'))) { - stop('SPEI can be only computed using the following approach: parametric or non-parametric') - } - if (method == 'non-parametric'){ + if (method == 'non-parametric') { if (anyNA(data) && na.rm == FALSE) { stop('Error: Data must not contain NAs') @@ -379,48 +582,45 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm SPEI = qnorm((bp-0.44)/(length(data)+0.12)) - return(SPEI) + return(SPEI) # it won't return params to be used in exp_cor; also it is not using handle_infinity nor cross_validation } else { std_index <- array(NA, c(n_sdates, nmemb)) - if (anyNA(data) && na.rm==FALSE) { + if (anyNA(data) && na.rm == FALSE) { stop('Error: Data must not contain NAs') } - if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { - stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') - } - if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { - stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') - } + coef = switch(distribution, "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha','beta'))), "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi','alpha','kappa'))), - "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu','sigma','gamma'))) - ) + "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu','sigma','gamma')))) dim_one <- length(coef) if (!is.null(params)) { - if (length(params)!=dim_one) { + if (length(params) != dim_one) { stop(paste0('parameters array should have dimensions [', dim_one, ']')) } } # Select window if necessary - if (!is.null(ref.start) && !is.null(ref.end)) { - data.fit <- window(data,ref.start,ref.end) - } else { - data.fit <- data - } + if (!is.null(ref.start) && !is.null(ref.end)) { + data.fit <- window(data,ref.start,ref.end) + } else { + data.fit <- data + } - if(cross_validation == "TRUE") { + if (cross_validation == "TRUE") { loop_years <- n_sdates } else { loop_years <- 1 } + + params_result <- array(NA, dim = c(loop_years, dim_one)) + colnames(params_result) <- names(coef) for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) # Cumulative series (acu) @@ -436,12 +636,13 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm acu_sd = sd(acu.sorted) if (!is.na(acu_sd)){ if (acu_sd != 0){ - if(distribution != "log-Logistic"){ + if(distribution != "log-Logistic") { pze <- sum(acu==0)/length(acu) acu.sorted = acu.sorted[acu.sorted > 0] } if (!is.null(params)) { f_params = as.vector(params) + params_result[nsd,] <- f_params } else { if (length(acu.sorted) >= 4){ # else coef will be NA # Calculate probability weighted moments based on fit with lmomco or TLMoments @@ -470,16 +671,23 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm if(distribution == 'log-Logistic' && fit == 'max-lik'){ f_params = parglo.maxlik(acu.sorted, f_params)$para } + params_result[nsd,] <- f_params } # end if dor the case the L-moments are not valid (std_index will be NA) } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) } # end estimation of f_param # Calculate cdf based on distribution with lmom - cdf_res = switch(distribution, + if (all(is.na(params_result[nsd,]))){ + cdf_res <- NA + } else { + f_params <- params_result[nsd,] + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, "log-Logistic" = lmom::cdfglo(data, f_params), "Gamma" = lmom::cdfgam(data, f_params), "PearsonIII" = lmom::cdfpe3(data, f_params) - ) - + ) + } + std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) # Adjust if user chose Gamma or PearsonIII - Not tested: For future development @@ -490,20 +698,22 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm std_index[nsd,] <- std_index_cv[nsd,] } else { std_index <- std_index_cv - } + } } } # end if for the case there is no variability } # end if for the case all NA in acu } # next year (in case of cross_validation or all done if cross_validation == F) - + if(handle_infinity == 'TRUE'){ # could also use "param_error" ?; we are giving it the min/max value of the grid point std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) std_index[is.infinite(std_index) & std_index > 0] <- max(std_index[!is.infinite(std_index)]) } - - } # end parametric - return(std_index) # fitted is the only thing used after calling this function + return(list(std_index = std_index, params = params_result)) # f_params will be params only if cross_validation is FALSE + # (otherwise there will be one f_params per year; + # but the output params will be read only in the case that + # it is called with cross_validation FALSE) + + } # end parametric } - -- GitLab From 7de3fdde479d3dd32109e9245e5486151b9d3fc1 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 26 May 2023 17:31:11 +0200 Subject: [PATCH 05/87] Improve code and write documentation --- R/PeriodSPEI.R | 250 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 163 insertions(+), 87 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 1eef63d..b73ef69 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -1,38 +1,36 @@ - -#------------------------------------------------------------------------------- -# To DO: Add documentation of same dimensions exp and exp_cor -# To DO: Add documentation for units -# TO DO: Write Documentation - -# library(s2dv) # InsertDim, ... -# library(multiApply) # Apply -# library(ClimProjDiags) # Subset -# library(zeallot) # multiple assignment %<-% -# library(SPEI) # estimation of evapotranspiration (e.g. hargreaves function) -# library(zoo) # rollapply, as.Date -# library(TLMoments) # pwd (Calculate probability weighted moments based on fit) -# library(lmomco) # pwm2lmom (probability weighted moments to L-Moments) -# library(lubridate) # year(), month(),... - -# library(CSTools) -#------------------------------------------------------------------------------- -#'@param exp A list with the 's2dv_cube' object class containing the seasonal -#' forecast experiment in the data element. -#'@param exp_cor An object of class \code{s2dv_cube} in which the quantile -#' PeriodSPEI should be applied. If it is not specified, the PeriodSPEI -#' is calculated from object 'exp'. -#'@param pet Multidimensional array containing the Potential EvapoTranspiration -#' data. If it is NULL it is calculated using pet_method. It is NULL by default. -#'@param time_dim -#'@param leadtime_dim -#'@param memb_dim -#'@param lat_dim -#--- other params from CSIndicators -#'@param accum +#'Compute the Standardised Precipitation-Evapotranspiration Index +#' +#'The Standardised Precipitation-Evapotranspiration Index (SPEI) is a +#'multiscalar drought index based on climatic data. It can be used for +#'determining the onset, duration and magnitude of drought conditions with +#'respect to normal conditions in a variety of natural and managed systems such +#'as crops, ecosystems, rivers, water resources, etc. The SPI is calculated +#'using monthly (or weekly) precipitation as the input data. The SPEI uses the +#'monthly (or weekly) difference between precipitation and PET. This represents +#'a simple climatic water balance which is calculated at different time scales +#'to obtain the SPEI. +#' +#'@param exp A named list with the needed \code{s2dv_cube} objects containing +#' the seasonal forecast experiment in the data element for each variable. +#'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each +#' variable in which the quantile PeriodSPEI should be applied. If it is not +#' specified, the PeriodSPEI is calculated from object 'exp'. +#'@param pet A multidimensional array containing the Potential +#' EvapoTranspiration data. If it is NULL it is calculated using pet_method. It +#' is NULL by default. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param memb_dim A character string indicating the name of the dimension in +#' which the ensemble members are stored. When set it to NULL, threshold is +#' computed for individual members. +#'@param lat_dim A character string indicating the name of the latitudinal +#' dimension. By default it is set by 'latitude'. +#'@param accum An integer value indicating the number of months for the +#' accumulation for each variable. #'@param start #'@param end -#' -# --- other params #'@param pet_method #'@param standardization #'@param params @@ -43,11 +41,26 @@ #'@param distribution #'@param fit #'@param ncores +#' +#'@examples +#'exp <- 1 +#' +# '@import s2dv +# '@import multiApply +# '@import ClimProjDiags +# '@import zeallot +# '@import SPEI +# '@import zoo +# '@import TLMoments +# '@import lmomco +# '@import lubridate +# '@import CSTools +# '@export CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, start = NULL, end = NULL, - pet_method = c('hargreaves', 'hargreaves'), + pet_method = 'hargreaves', standardization = TRUE, params = NULL, # not used if standardization is FALSE param_error = -9999, # not used if standardization is FALSE @@ -57,9 +70,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, fit = 'ub-pwm', # not used if standardization is FALSE ncores = 4) { - #----------------------------------------------------------------------------- - # Part (1): Initial structure checks - # coordinates + # Check 's2dv_cube' + .KnownLatNames <- CSTools:::.KnownLatNames() if (!any(names(exp[[1]]$coords) %in% .KnownLatNames)) { @@ -86,7 +98,6 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, method = method, distribution = distribution, fit = fit, ncores = ncores) return(res) - } @@ -96,79 +107,135 @@ PeriodSPEI <- function(exp, dates, lat, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, start = NULL, end = NULL, - pet_method = c('hargreaves', 'hargreaves'), + pet_method = 'hargreaves', standardization = TRUE, params = NULL, param_error = -9999, handle_infinity = FALSE, cross_validation = FALSE, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', ncores = 4) { - #----------------------------------------------------------------------------- - - # Part (1): Initial checks + # Initial checks - ## pet and pet_method - if (is.null(pet_method) & is.null(pet)) { - warning("Parameter 'pet_method' cannot be NULL if pet is not provided.") + ## exp + if (!inherits(exp, 'list')) { + stop("Parameter 'exp' needs to be a named list with the needed variables.") + } + if (is.null(names(exp))) { + stop("Parameter 'exp' needs to be a named list with the variable names.") } + + ## exp_cor if (!is.null(exp_cor)) { - if (length(pet_method) == 1) { - pet_method <- rep(pet_method, 2) - } - if (length(exp_cor) < 1) { + if (!inherits(exp_cor, 'list')) { + warning("Parameter 'exp_cor' needs to be a named list with the needed ", + "variables. Only 'exp' will be used.") exp_cor <- NULL } - } else { - if (lenght(pet_method) > 1) { - warning("Parameter 'pet_method' is of length 2, only first value will be used.") - pet_method <- pet_method[1] + if (is.null(names(exp_cor))) { + stop("Parameter 'exp_cor' needs to be a named list with the variable names.") } } - ## exp - ## TO DO: Check order: tasmax, tasmin, prlr - if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { - # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' - if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { - warning("Parameter 'pet_method' needs to be 'hargreaves_modified' or 'hargreaves'.") - pet_method[1] <- 'hargreaves_modified' - } - } else if (all(c('tasmin', 'tasmax') %in% names(exp))) { - # hargreaves: 'tasmin', 'tasmax' and 'lat' - if (pet_method != c('hargreaves')) { - warning("Parameter 'pet_method' needs to be 'hargreaves'.") - pet_method[1] <- 'hargreaves' + + # Variable checks + if (is.null(pet)) { + ## exp (2) + if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { + # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' + if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + warning("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves'.") + pet_method[1] <- 'hargreaves' + } + } else if (all(c('tas', 'prlr') %in% names(exp))) { + # thornthwaite: 'tas' (mean), 'lat' + if (!any(pet_method != 'thornthwaite')) { + warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") + pet_method[1] <- 'thornthwaite' + } + } else { + stop("Parameter 'exp' needs to be a named list with accepted variable names.", + "See documentation.") } - - } else if ('tas' %in% names(exp)) { - # thornthwaite: 'tas' (mean), 'lat' - pet_method[1] <- 'thornthwaite' + ## exp_cor (2) + if (!is.null(exp_cor)) { + if (length(exp_cor) < 1) { + exp_cor <- NULL + } else { + if (length(pet_method) == 1) { + pet_method <- rep(pet_method, 2) + } + } + if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp_cor))) { + # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' + if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + warning("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves'.") + pet_method[2] <- 'hargreaves' + } + } else if (all(c('tas', 'prlr') %in% names(exp_cor))) { + # thornthwaite: 'tas' (mean), 'lat' + if (!any(pet_method != 'thornthwaite')) { + warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") + pet_method[2] <- 'thornthwaite' + } + } else { + stop("Parameter 'exp_cor' needs to be a list with the needed variables.") + } + } } else { - stop("Parameter 'exp' needs to be a list with the needed variables.") + if (!('prlr' %in% names(exp))) { + stop("Variable 'prlr' is not included in 'exp'.") + } + if (!is.null(exp_cor)) { + if (!('prlr' %in% names(exp_cor))) { + stop("Variable 'prlr' is not included in 'exp_cor'.") + } + } } - # warning(' needs to be in C and precipitation in mm/month') # there is no check + ## time_dim + + ## leadtime_dim + + ## memb_dim + + ## lat_dim - # check if accumulation period is possible + ## accum if (accum > dim(exp[[1]])[leadtime_dim]) { stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', dim(exp[[1]])[leadtime_dim], ' months.')) } - # method + + ## start + + ## end + + ## standardization + + ## param_error + + ## handle_infinity + + ## cross_validation + + ## method if (!(method %in% c('parametric', 'non-parametric'))) { stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') } - # distribution + ## distribution if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') } - # fit + ## fit if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') } - #----------------------------------------------------------------------------- - # Part (2): preparation + ## ncores + + # Data preparation # complete dates ini_date <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep= '-')) @@ -183,8 +250,7 @@ PeriodSPEI <- function(exp, dates, lat, dates_monthly[ii] <- 1 } - #----------------------------------------------------------------------------- - # Part (3): Compute PeriodSPEI + # Compute PeriodSPEI k = 0 spei_res <- NULL computed_pet <- FALSE @@ -193,14 +259,21 @@ PeriodSPEI <- function(exp, dates, lat, k = k + 1 # Evapotranspiration estimation (unless pet is already provided) if (is.null(pet) | computed_pet) { - pet <- evapotranspiration(data, dates_monthly, pet_method = pet_method[k], time_dim, - leadtime_dim, memb_dim, lat_dim, ncores) + pet <- evapotranspiration(data = data, dates_monthly = dates_monthly, + lat = lat, pet_method = pet_method[k], + time_dim = time_dim, leadtime_dim = leadtime_dim, + memb_dim = memb_dim, lat_dim = lat_dim, + ncores = ncores) computed_pet <- TRUE } + # Accumulation diff_P_PET <- data$prlr - pet - data_accum <- accumulation(diff_P_PET, dates_monthly, accum, time_dim, - leadtime_dim, memb_dim, ncores) + data_accum <- accumulation(diff_P_PET = diff_P_PET, + dates_monthly = dates_monthly, accum = accum, + time_dim = time_dim, + leadtime_dim = leadtime_dim, + memb_dim = memb_dim, ncores = ncores) # Standardization: if (standardization == TRUE) { spei_dat <- spei_standardization(data_accum = data_accum, @@ -252,7 +325,7 @@ PeriodSPEI <- function(exp, dates, lat, -evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', +evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreaves', time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', ncores = 4) { @@ -265,13 +338,16 @@ evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', mask_NA <- array(1, dim = dim(data[[1]])) if (pet_method == 'hargreaves') { + varnames <- c('tasmax', 'tasmin') mask_NA[which(is.na(data$tasmax))] <- 0 mask_NA[which(is.na(data$tasmin))] <- 0 } else if (pet_method == 'hargreaves_modified') { + varnames <- c('tasmax', 'tasmin', 'prlr') mask_NA[which(is.na(data$tasmax))] <- 0 mask_NA[which(is.na(data$tasmin))] <- 0 mask_NA[which(is.na(data$prlr))] <- 0 } else if (pet_method == 'thornthwaite') { + varnames <- c('tas') mask_NA[which(is.na(data$tas))] <- 0 } @@ -281,11 +357,11 @@ evapotranspiration <- function(data, dates_monthly, pet_method = 'hargreaves', } # prepare data - target_dims_data <- lapply(data, function(x) rep(c(leadtime_dim, time_dim), 1)) + target_dims_data <- lapply(data[varnames], function(x) rep(c(leadtime_dim, time_dim), 1)) # file <- tempfile() # file = 'out.txt' # sink(file) - PET_estimated <- Apply(data = c(list(lat_mask = lat_mask), data), + PET_estimated <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), target_dims = c(list(lat_mask = 'dat'), target_dims_data), output_dims = c(leadtime_dim, time_dim), pet_method = pet_method, -- GitLab From 09753eb01a00265bdcc0480913019349b9cfae5f Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 29 May 2023 17:31:04 +0200 Subject: [PATCH 06/87] Add unit test --- R/PeriodSPEI.R | 135 ++++++++++++++++++++++--------- tests/testthat/test-PeriodSPEI.R | 113 ++++++++++++++++++++++++++ 2 files changed, 212 insertions(+), 36 deletions(-) create mode 100644 tests/testthat/test-PeriodSPEI.R diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index b73ef69..7d419d0 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -71,17 +71,26 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, ncores = 4) { # Check 's2dv_cube' + if (is.null(exp)) { + stop("Parameter 'exp' cannot be NULL.") + } + if (!all(sapply(exp, function(x) inherits(x, 's2dv_cube')))) { + stop("Parameter 'exp' must be a list of 's2dv_cube' class.") + } + if (!is.null(exp_cor)) { + if (!all(sapply(exp_cor, function(x) inherits(x, 's2dv_cube')))) { + stop("Parameter 'exp_cor' must be a list of 's2dv_cube' class.") + } + } .KnownLatNames <- CSTools:::.KnownLatNames() if (!any(names(exp[[1]]$coords) %in% .KnownLatNames)) { - stop("Spatial coordinate names of parameter 'obsL' do not match any ", + stop("Spatial coordinate names of parameter 'exp' do not match any ", "of the names accepted by the package.") } - lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames)]] - #----------------------------------------------------------------------------- - # Part (2): Call to PeriodSPEI + lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames)]] res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), dates = exp[[1]]$attrs$Dates, @@ -115,7 +124,6 @@ PeriodSPEI <- function(exp, dates, lat, fit = 'ub-pwm', ncores = 4) { # Initial checks - ## exp if (!inherits(exp, 'list')) { stop("Parameter 'exp' needs to be a named list with the needed variables.") @@ -123,17 +131,37 @@ PeriodSPEI <- function(exp, dates, lat, if (is.null(names(exp))) { stop("Parameter 'exp' needs to be a named list with the variable names.") } + if (any(sapply(exp, function(x) is.null(names(dim(x)))))) { + stop("Parameter 'exp' needs to be a list of arrays with dimension names.") + } + dims <- lapply(exp, function(x) dim(x)) + first_dims <- dims[[1]] + all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) + if (!all_equal) { + stop("Parameter 'exp' variables needs to have the same dimension names.") + } ## exp_cor if (!is.null(exp_cor)) { if (!inherits(exp_cor, 'list')) { - warning("Parameter 'exp_cor' needs to be a named list with the needed ", - "variables. Only 'exp' will be used.") - exp_cor <- NULL + stop("Parameter 'exp_cor' needs to be a named list with the needed ", + "variables if it is not NULL.") } if (is.null(names(exp_cor))) { stop("Parameter 'exp_cor' needs to be a named list with the variable names.") } + if (any(sapply(exp_cor, function(x) is.null(names(dim(x)))))) { + stop("Parameter 'exp_cor' needs to be a list of arrays with dimension names.") + } + if (!all(names(exp_cor) %in% names(exp))) { + stop("Parameter 'exp_cor' needs to have the same variable names as 'exp'.") + } + dims <- lapply(exp_cor, function(x) dim(x)) + first_dims <- dims[[1]] + all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) + if (!all_equal) { + stop("Parameter 'exp_cor' variables needs to have the same dimension names.") + } } # Variable checks @@ -195,19 +223,58 @@ PeriodSPEI <- function(exp, dates, lat, } ## time_dim - + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!all(sapply(exp, function(x) time_dim %in% names(dim(x))))) { + stop("Parameter 'time_dim' is not found in 'exp' dimension.") + } + if (!is.null(exp_cor)) { + if (!all(sapply(exp_cor, function(x) time_dim %in% names(dim(x))))) { + stop("Parameter 'time_dim' is not found in 'exp_cor' dimension.") + } + } ## leadtime_dim - + if (!is.character(leadtime_dim) | length(leadtime_dim) != 1) { + stop("Parameter 'leadtime_dim' must be a character string.") + } + if (!all(sapply(exp, function(x) leadtime_dim %in% names(dim(x))))) { + stop("Parameter 'leadtime_dim' is not found in 'exp' dimension.") + } + if (!is.null(exp_cor)) { + if (!all(sapply(exp_cor, function(x) leadtime_dim %in% names(dim(x))))) { + stop("Parameter 'leadtime_dim' is not found in 'exp_cor' dimension.") + } + } ## memb_dim - + if (!is.character(memb_dim) | length(memb_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!all(sapply(exp, function(x) memb_dim %in% names(dim(x))))) { + stop("Parameter 'memb_dim' is not found in 'exp' dimension.") + } + if (!is.null(exp_cor)) { + if (!all(sapply(exp_cor, function(x) memb_dim %in% names(dim(x))))) { + stop("Parameter 'memb_dim' is not found in 'exp_cor' dimension.") + } + } ## lat_dim - + if (!is.character(lat_dim) | length(lat_dim) != 1) { + stop("Parameter 'lat_dim' must be a character string.") + } + if (!all(sapply(exp, function(x) lat_dim %in% names(dim(x))))) { + stop("Parameter 'lat_dim' is not found in 'exp' dimension.") + } + if (!is.null(exp_cor)) { + if (!all(sapply(exp_cor, function(x) lat_dim %in% names(dim(x))))) { + stop("Parameter 'lat_dim' is not found in 'exp_cor' dimension.") + } + } ## accum if (accum > dim(exp[[1]])[leadtime_dim]) { - stop(paste0('ERROR: Cannot compute accumulation of ', accum, ' months because loaded data has only ', - dim(exp[[1]])[leadtime_dim], ' months.')) + stop(paste0("Cannot compute accumulation of ", accum, " months because ", + "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) } - ## start ## end @@ -234,7 +301,12 @@ PeriodSPEI <- function(exp, dates, lat, } ## ncores - + if (!is.null(ncores)) { + if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } # Data preparation # complete dates @@ -388,13 +460,6 @@ accumulation <- function(diff_P_PET, dates_monthly, accum = 1, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', ncores = 4) { - if (!time_dim %in% names(dim(diff_P_PET))) { - diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = time_dim) - } - if (!leadtime_dim %in% names(dim(diff_P_PET))) { - diff_P_PET <- InsertDim(diff_P_PET, posdim = 1, lendim = 1, name = leadtime_dim) - } - accum_result <- Apply(data = list(diff_P_PET), target_dims = list(diff_P_PET = c(leadtime_dim,time_dim)), dates_monthly = dates_monthly, @@ -510,22 +575,22 @@ atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL } if (pet_method == 'hargreaves') { # NOTE EVA: if NA.RM is FALSE this gives error - x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, na.rm = TRUE) + x_PET <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = TRUE)) # line to return the vector to the size of the actual original data x_PET <- x_PET[which(dates_monthly == 1)] PET <- array(x_PET, dim = dims) } if (pet_method == 'hargreaves_modified') { - x_PET <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, Pre = as.vector(data4), na.rm = TRUE) + x_PET <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = TRUE)) x_PET <- x_PET[which(dates_monthly == 1)] PET <- array(x_PET, dim = dims) } if (pet_method == 'thornthwaite') { - x_PET <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE) + x_PET <- invisible(thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE)) # line to return the vector to the size of the actual original data x_PET <- x_PET[which(dates_monthly == 1)] PET <- array(x_PET, dim = dims) @@ -536,8 +601,7 @@ atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL atomic_accum <- function(data, dates_monthly, accum, leadtime_dim, time_dim) { # data:[time, syear] - ftime <- dim(data)[1] - n_sdates <- dim(data)[2] + dims <- dim(data) data_vector <- array(0, dim = length(dates_monthly)) count <- 1 @@ -554,14 +618,13 @@ atomic_accum <- function(data, dates_monthly, accum, leadtime_dim, time_dim) { # (depends on accu) and so that the position in the vector corresponds to the accumulated # of the previous months (instead of the accumulated of the next months) data_sum_x <- data_sum_x[which(dates_monthly == 1)] # discard the months that don't appear in the original data - accum_result <- array(data_sum_x, dim = c(ftime,n_sdates)) # return to matrix form + dim(data_sum_x) <- dims if (accum > 1) { - accum_result[1:(accum-1),] <- NA # replace by NA when the accumulation corresponds to months that where not present in the original data + data_sum_x[1:(accum-1),] <- NA # replace by NA when the accumulation corresponds to months that where not present in the original data } - - return(accum_result) - + return(data_sum_x) } + atomic_spei <- function(data, params, leadtime_dim, time_dim, dim_memb, ref_period, handle_infinity, cross_validation, param_error, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm') { @@ -576,7 +639,7 @@ atomic_spei <- function(data, params, leadtime_dim, time_dim, dim_memb, ref_peri if (all(is.na(data))) { speiX <- array(NA, dim(data)) - } else if (var(data, na.rm=T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, + } else if (var(data, na.rm = T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, # so we assign a value to the result and skip the step speiX <- array(param_error, dim(data)) } else { diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R new file mode 100644 index 0000000..0a9a6bd --- /dev/null +++ b/tests/testthat/test-PeriodSPEI.R @@ -0,0 +1,113 @@ +context("CSIndicators::PeriodSPEI tests") + +############################################## +# cube1 +cube1 <- NULL +cube1$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube1) <- 's2dv_cube' + +# dat1 +dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) +dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) + +set.seed(1) +exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) +set.seed(2) +exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) +set.seed(3) +exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) + +set.seed(1) +expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) +set.seed(2) +expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) +set.seed(3) +expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) + +dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +lat <- c(40,40.1) + +exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) + +res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates = dates) +source("/esarchive/scratch/erifarov/git/csindicators/R/PeriodSPEI.R") + +############################################## + +test_that("1. Initial checks CST_PeriodSPEI", { + expect_error( + CST_PeriodSPEI(exp = NULL), + "Parameter 'exp' cannot be NULL." + ) + expect_error( + CST_PeriodSPEI(exp = array(10)), + "Parameter 'exp' must be a list of 's2dv_cube' class." + ) + expect_error( + CST_PeriodSPEI(exp = list(cube1)), + paste0("Spatial coordinate names of parameter 'exp' do not match any ", + "of the names accepted by the package.") + ) +}) + +############################################## + +test_that("1. Initial checks PeriodSPEI", { + # exp + expect_error( + PeriodSPEI(exp = NULL), + "Parameter 'exp' needs to be a named list with the needed variables." + ) + expect_error( + PeriodSPEI(exp = list(1)), + "Parameter 'exp' needs to be a named list with the variable names." + ) + expect_error( + PeriodSPEI(exp = list('tasmax' = array(10))), + "Parameter 'exp' needs to be a list of arrays with dimension names." + ) + # exp_cor + expect_error( + PeriodSPEI(exp = exp1, exp_cor = 1), + paste0("Parameter 'exp_cor' needs to be a named list with the needed ", + "variables if it is not NULL.") + ) + expect_error( + PeriodSPEI(exp = exp1, exp_cor = list(1)), + "Parameter 'exp_cor' needs to be a named list with the variable names." + ) + expect_error( + PeriodSPEI(exp = exp1, exp_cor = list('tasmax' = array(10))), + "Parameter 'exp_cor' needs to be a list of arrays with dimension names." + ) + expect_error( + PeriodSPEI(exp = list('tas' = array(10, dim = c(time = 10))), + exp_cor = list('tos' = array(10, dim = c(time = 10)))), + "Parameter 'exp_cor' needs to have the same variable names as 'exp'." + ) + # exp (2) + expect_warning( + PeriodSPEI(exp = exp1, pet_method = '1', dates = dates, lat = lat), + paste0("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves'.") + ) + # time_dim + expect_error( + PeriodSPEI(exp = exp1, ) + ) + # leadtime_dim + + # memb_dim + + # lat_dim + + # accum + +}) + +############################################## + -- GitLab From 677219da70aa26feb38d948a24dae8e2d95bf604 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 1 Jun 2023 16:25:12 +0200 Subject: [PATCH 07/87] Improve code --- R/PeriodSPEI.R | 585 ++++++++++++++++++++++++------------------------- 1 file changed, 290 insertions(+), 295 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 7d419d0..2eec05f 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -6,7 +6,7 @@ #'respect to normal conditions in a variety of natural and managed systems such #'as crops, ecosystems, rivers, water resources, etc. The SPI is calculated #'using monthly (or weekly) precipitation as the input data. The SPEI uses the -#'monthly (or weekly) difference between precipitation and PET. This represents +#'monthly (or weekly) difference between precipitation and pet. This represents #'a simple climatic water balance which is calculated at different time scales #'to obtain the SPEI. #' @@ -59,8 +59,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', - accum = 1, start = NULL, end = NULL, - pet_method = 'hargreaves', + accum = 1, start = NULL, end = NULL, + ref_period = NULL, pet_method = 'hargreaves', standardization = TRUE, params = NULL, # not used if standardization is FALSE param_error = -9999, # not used if standardization is FALSE @@ -68,7 +68,7 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, cross_validation = FALSE, # not used if standardization is FALSE method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', # not used if standardization is FALSE - ncores = 4) { + ncores = NULL) { # Check 's2dv_cube' if (is.null(exp)) { @@ -96,9 +96,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, dates = exp[[1]]$attrs$Dates, lat = exp[[1]]$coords[[lat_name]], exp_cor = lapply(exp_cor, function(x) x$data), - pet = pet, + pet = pet, ref_period = ref_period, time_dim = time_dim, leadtime_dim = leadtime_dim, - memb_dim = memb_dim, lat_dim = lat_dim, + memb_dim = memb_dim, lat_dim = lat_dim, accum = accum, start = start, end = end, pet_method = pet_method, standardization = standardization, params = params, param_error = param_error, @@ -116,7 +116,7 @@ PeriodSPEI <- function(exp, dates, lat, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, start = NULL, end = NULL, - pet_method = 'hargreaves', + pet_method = 'hargreaves', ref_period = NULL, standardization = TRUE, params = NULL, param_error = -9999, handle_infinity = FALSE, cross_validation = FALSE, @@ -169,14 +169,14 @@ PeriodSPEI <- function(exp, dates, lat, ## exp (2) if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' - if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + if (!(pet_method[1] %in% c('hargreaves_modified', 'hargreaves'))) { warning("Parameter 'pet_method' needs to be 'hargreaves' or ", "'hargreaves_modified'. It is set to 'hargreaves'.") pet_method[1] <- 'hargreaves' } } else if (all(c('tas', 'prlr') %in% names(exp))) { # thornthwaite: 'tas' (mean), 'lat' - if (!any(pet_method != 'thornthwaite')) { + if (!(pet_method[1] == 'thornthwaite')) { warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") pet_method[1] <- 'thornthwaite' } @@ -196,14 +196,14 @@ PeriodSPEI <- function(exp, dates, lat, } if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp_cor))) { # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' - if (!any(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + if (!(pet_method[2] %in% c('hargreaves_modified', 'hargreaves'))) { warning("Parameter 'pet_method' needs to be 'hargreaves' or ", "'hargreaves_modified'. It is set to 'hargreaves'.") pet_method[2] <- 'hargreaves' } } else if (all(c('tas', 'prlr') %in% names(exp_cor))) { # thornthwaite: 'tas' (mean), 'lat' - if (!any(pet_method != 'thornthwaite')) { + if (!(pet_method[2] == 'thornthwaite')) { warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") pet_method[2] <- 'thornthwaite' } @@ -334,31 +334,31 @@ PeriodSPEI <- function(exp, dates, lat, pet <- evapotranspiration(data = data, dates_monthly = dates_monthly, lat = lat, pet_method = pet_method[k], time_dim = time_dim, leadtime_dim = leadtime_dim, - memb_dim = memb_dim, lat_dim = lat_dim, - ncores = ncores) + lat_dim = lat_dim, ncores = ncores) computed_pet <- TRUE } # Accumulation - diff_P_PET <- data$prlr - pet - data_accum <- accumulation(diff_P_PET = diff_P_PET, + diff_p_pet <- data$prlr - pet + data_accum <- accumulation(data = diff_p_pet, dates_monthly = dates_monthly, accum = accum, - time_dim = time_dim, - leadtime_dim = leadtime_dim, - memb_dim = memb_dim, ncores = ncores) + time_dim = time_dim, leadtime_dim = leadtime_dim, + ncores = ncores) # Standardization: if (standardization == TRUE) { - spei_dat <- spei_standardization(data_accum = data_accum, - leadtime_dim = leadtime_dim, - time_dim = time_dim, - memb_dim = memb_dim, - cross_validation = cross_validation, - handle_infinity = handle_infinity, - ncores = ncores, - accum = accum, - param_error = param_error, - params = params, method = method, - distribution = distribution, fit = fit) + spei_dat <- spei_standardization(data = data_accum, + leadtime_dim = leadtime_dim, + time_dim = time_dim, + memb_dim = memb_dim, + ref_period = ref_period, + cross_validation = cross_validation, + handle_infinity = handle_infinity, + ncores = ncores, + accum = accum, + param_error = param_error, + params = params, method = method, + distribution = distribution, + fit = fit) params <- spei_dat$params } else { spei_dat <- data_accum @@ -395,32 +395,29 @@ PeriodSPEI <- function(exp, dates, lat, } - +#------------------------------------------------------------------------------- evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreaves', - time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', - lat_dim = 'latitude', - ncores = 4) { + time_dim = 'syear', leadtime_dim = 'time', + lat_dim = 'latitude', ncores = NULL) { - ## corrected:: lat_mask <- array(lat, dim = c(1, length(lat))) names(dim(lat_mask)) <- c('dat', lat_dim) # extract mask of NA locations to return to NA the final result - - mask_NA <- array(1, dim = dim(data[[1]])) + mask_na <- array(1, dim = dim(data[[1]])) if (pet_method == 'hargreaves') { varnames <- c('tasmax', 'tasmin') - mask_NA[which(is.na(data$tasmax))] <- 0 - mask_NA[which(is.na(data$tasmin))] <- 0 + mask_na[which(is.na(data$tasmax))] <- 0 + mask_na[which(is.na(data$tasmin))] <- 0 } else if (pet_method == 'hargreaves_modified') { varnames <- c('tasmax', 'tasmin', 'prlr') - mask_NA[which(is.na(data$tasmax))] <- 0 - mask_NA[which(is.na(data$tasmin))] <- 0 - mask_NA[which(is.na(data$prlr))] <- 0 + mask_na[which(is.na(data$tasmax))] <- 0 + mask_na[which(is.na(data$tasmin))] <- 0 + mask_na[which(is.na(data$prlr))] <- 0 } else if (pet_method == 'thornthwaite') { varnames <- c('tas') - mask_NA[which(is.na(data$tas))] <- 0 + mask_na[which(is.na(data$tas))] <- 0 } # replace NA with 0 @@ -433,7 +430,7 @@ evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreave # file <- tempfile() # file = 'out.txt' # sink(file) - PET_estimated <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), + pet_estimated <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), target_dims = c(list(lat_mask = 'dat'), target_dims_data), output_dims = c(leadtime_dim, time_dim), pet_method = pet_method, @@ -442,91 +439,18 @@ evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreave fun = atomic_pet, ncores = ncores)$output1 # sink(NULL) # captured_message <- readLines(file) - # print(paste0('Length captured!!', length(captured_message))) - # print(paste0('unique(captured_message)', length(unique(captured_message)))) - - # reorder dims in PET_estimated - pos <- match(names(dim(data[[1]])),names(dim(PET_estimated))) - PET_estimated <- aperm(PET_estimated, pos) - - # restore original NAs from mask_NA - PET_estimated[which(mask_NA == 0 )] <- NA - return(PET_estimated) + # reorder dims in pet_estimated + pos <- match(names(dim(data[[1]])),names(dim(pet_estimated))) + pet_estimated <- aperm(pet_estimated, pos) -} - -accumulation <- function(diff_P_PET, dates_monthly, accum = 1, - time_dim = 'syear', leadtime_dim = 'time', - memb_dim = 'ensemble', ncores = 4) { - - accum_result <- Apply(data = list(diff_P_PET), - target_dims = list(diff_P_PET = c(leadtime_dim,time_dim)), - dates_monthly = dates_monthly, - accum = accum, - output_dims = c(leadtime_dim, time_dim), #c('time','sdate'), - leadtime_dim = leadtime_dim, time_dim = time_dim, - fun = atomic_accum, ncores = ncores) - - # recover essential lost dims (if they had length 1 they'd have been dropped in previous step): - for (d in c(time_dim, leadtime_dim, 'latitude', 'longitude', memb_dim)) { - if(!d %in% names(dim(accum_result$output1))){ - accum_result$output1 <- InsertDim(data = accum_result$output1, posdim = length(names(dim(accum_result$output1))) + 1, lendim = 1, name = d) - } - } - - # reorder dims in accum_result - dims_order <- array(NA, length(dim(diff_P_PET))) - for (ord in 1:length(dim(diff_P_PET))){ - dims_order[ord] <- which(names(dim(accum_result$output1)) == names(dim(diff_P_PET))[ord]) - } - data_accum <- aperm(accum_result$output1, dims_order) + # restore original NAs from mask_na + pet_estimated[which(mask_na == 0 )] <- NA - return(data_accum) + return(pet_estimated) } -spei_standardization <- function(data_accum, - leadtime_dim, time_dim, memb_dim, handle_infinity, - cross_validation, ncores, accum, param_error, - params = NULL, method ='parametric', - distribution = 'log-Logistic', fit='ub-pwm') { - - n_leadtimes <- dim(data_accum)[leadtime_dim] - n_sdates_params <- dim(data_accum)[time_dim] - - if (!cross_validation) { - n_sdates_params <- 1 - } - - if (is.null(params)) { - params <- array(NA, dim = c(n_sdates_params, n_leadtimes, coef = 3)) - names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') - } else if (length(dim(params)) < 2) { - params <- array(params, dim = c(length(params), n_sdates_params, n_leadtimes)) - params <- aperm(params, c(2,3,1)) # dim(params): [time_dim, leadtime_dim, coef] with the values repeated each time_dim and leadtime_dim - names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') - } - - spei <- Apply(data = list(data = data_accum, params = params), - target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), - params = c(time_dim, leadtime_dim, 'coef')), - output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), - params = c(time_dim, leadtime_dim, 'coef')), - leadtime_dim = leadtime_dim, - time_dim = time_dim, - dim_memb = memb_dim, - handle_infinity = handle_infinity, - cross_validation = cross_validation, - method = method, distribution = distribution, fit = fit, - ref_period = NULL, - param_error = param_error, - fun = atomic_spei, - ncores = ncores) - - return(spei) # spei is a list of data_spei and params -} - atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL, pet_method, dates_monthly, leadtime_dim, time_dim) { @@ -575,30 +499,52 @@ atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL } if (pet_method == 'hargreaves') { # NOTE EVA: if NA.RM is FALSE this gives error - x_PET <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + x_pet <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, na.rm = TRUE)) # line to return the vector to the size of the actual original data - x_PET <- x_PET[which(dates_monthly == 1)] - PET <- array(x_PET, dim = dims) + x_pet <- x_pet[which(dates_monthly == 1)] + pet <- array(x_pet, dim = dims) } if (pet_method == 'hargreaves_modified') { - x_PET <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + x_pet <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, Pre = as.vector(data4), na.rm = TRUE)) - x_PET <- x_PET[which(dates_monthly == 1)] - PET <- array(x_PET, dim = dims) + x_pet <- x_pet[which(dates_monthly == 1)] + pet <- array(x_pet, dim = dims) } if (pet_method == 'thornthwaite') { - x_PET <- invisible(thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE)) + x_pet <- invisible(thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE)) # line to return the vector to the size of the actual original data - x_PET <- x_PET[which(dates_monthly == 1)] - PET <- array(x_PET, dim = dims) + x_pet <- x_pet[which(dates_monthly == 1)] + pet <- array(x_pet, dim = dims) } - return(PET) + return(pet) } -atomic_accum <- function(data, dates_monthly, accum, leadtime_dim, time_dim) { +#------------------------------------------------------------------------------- + +accumulation <- function(data, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time', + ncores = NULL) { + + accum_result <- Apply(data = list(data), + target_dims = list(data = c(leadtime_dim, time_dim)), + dates_monthly = dates_monthly, + accum = accum, + output_dims = c(leadtime_dim, time_dim), + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = atomic_accum, ncores = ncores)$output1 + + pos <- match(names(dim(accum_result)), names(dim(data))) + data_accum <- aperm(accum_result, pos) + + return(data_accum) + +} + +atomic_accum <- function(data, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time') { # data:[time, syear] dims <- dim(data) @@ -606,29 +552,90 @@ atomic_accum <- function(data, dates_monthly, accum, leadtime_dim, time_dim) { data_vector <- array(0, dim = length(dates_monthly)) count <- 1 for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1){ + if (dates_monthly[dd] == 1) { data_vector[dd] <- as.vector(data)[count] count <- count + 1 } } - # Accumulation at different timescales - data_sum_x <- rollapply(data_vector, accum, sum) # rollapply {zoo} A generic function for applying a function to rolling margins of an array. - data_sum_x <- c(rep(NA, accum-1), data_sum_x) # adds as many NAs as needed at the begining to account for the months that cannot be added - # (depends on accu) and so that the position in the vector corresponds to the accumulated - # of the previous months (instead of the accumulated of the next months) - data_sum_x <- data_sum_x[which(dates_monthly == 1)] # discard the months that don't appear in the original data - dim(data_sum_x) <- dims + # rollapply {zoo} A generic function for applying a function to rolling margins of an array. + data_sum_x <- rollapply(data_vector, accum, sum) + # adds as many NAs as needed at the begining to account for the months that cannot be added + # (depends on accu) and so that the position in the vector corresponds to the accumulated + # of the previous months (instead of the accumulated of the next months) + data_sum_x <- c(rep(NA, accum-1), data_sum_x) + # discard the months that don't appear in the original data + data_sum_x <- data_sum_x[which(dates_monthly == 1)] + accum_result <- array(data_sum_x, dim = c(dims)) + # replace by NA when the accumulation corresponds to months that where not present in the original data if (accum > 1) { - data_sum_x[1:(accum-1),] <- NA # replace by NA when the accumulation corresponds to months that where not present in the original data + accum_result[1:(accum-1), ] <- NA } - return(data_sum_x) + return(accum_result) } -atomic_spei <- function(data, params, leadtime_dim, time_dim, dim_memb, ref_period, - handle_infinity, cross_validation, param_error, method = 'parametric', +#------------------------------------------------------------------------------- + + +spei_standardization <- function(data, accum = 1, time_dim = 'syear', + leadtime_dim = 'time', memb_dim = 'ensemble', + ref_period = NULL, + handle_infinity = FALSE, + cross_validation = FALSE, + param_error = -9999, params = NULL, + method = 'parametric', + distribution = 'log-Logistic', + fit = 'ub-pwm', + ncores = NULL) { + + n_leadtimes <- dim(data)[leadtime_dim] + n_sdates_params <- dim(data)[time_dim] + + if (!cross_validation) { + n_sdates_params <- 1 + } + + if (is.null(params)) { + params <- array(NA, dim = c(n_sdates_params, n_leadtimes, coef = 3)) # hardcoded + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } else if (length(dim(params)) < 2) { + params <- array(params, dim = c(length(params), n_sdates_params, n_leadtimes)) + params <- aperm(params, c(2,3,1)) # dim(params): [time_dim, leadtime_dim, coef] with the values repeated each time_dim and leadtime_dim + names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } + + spei <- Apply(data = list(data = data, params = params), + target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), + output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), + leadtime_dim = leadtime_dim, + time_dim = time_dim, + memb_dim = memb_dim, + handle_infinity = handle_infinity, + cross_validation = cross_validation, + method = method, distribution = distribution, fit = fit, + ref_period = ref_period, + param_error = param_error, + fun = atomic_spei, + ncores = ncores) + + return(spei) # spei is a list of data_spei and params +} + + + + + +atomic_spei <- function(data, params, leadtime_dim = 'time', time_dim = 'syear', + memb_dim = 'ensemble', ref_period = NULL, + handle_infinity = FALSE, cross_validation = FALSE, + param_error = -9999, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm') { - # data: [time, sdate, memb] + + # data: [leadtime_dim, time_dim, memb_dim] + # params: [time_dim, leadtime_dim, 'coef'] + if (is.null(ref_period)) { ref.start <- NULL ref.end <- NULL @@ -639,99 +646,83 @@ atomic_spei <- function(data, params, leadtime_dim, time_dim, dim_memb, ref_peri if (all(is.na(data))) { speiX <- array(NA, dim(data)) - } else if (var(data, na.rm = T) == 0) { # if the data [time, sdate, memb] has no variability it will raise an error further down, - # so we assign a value to the result and skip the step + # if the data [time, sdate, memb] has no variability it will raise an error further down, + # so we assign a value to the result and skip the step + } else if (var(data, na.rm = T) == 0) { speiX <- array(param_error, dim(data)) + return(speiX) } else { - c(speiX, params) %<-% spX(data, ref.start=ref.start, ref.end=ref.end, params = params, - method = method, distribution = distribution, fit = fit, - leadtime_dim = leadtime_dim, time_dim = time_dim, dim_memb = dim_memb, - handle_infinity = handle_infinity, cross_validation = cross_validation) + n_coef_max <- dim(params)['coef'] + ftime <- as.numeric(dim(data)[leadtime_dim]) + n_sdates <- as.numeric(dim(data)[time_dim]) + nmemb <- as.numeric(dim(data)[memb_dim]) + + spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) + names(dim(spei_mod)) <- c(leadtime_dim, time_dim, memb_dim) + if (cross_validation) { + params_result <- array(data = NA, dim = c(n_sdates, ftime, n_coef_max)) + } else { + params_result <- array(data = NA, dim = c(1, ftime, n_coef_max)) + } + for (ff in 1:ftime) { # treat months independently + Accum_D_temp <- ClimProjDiags::Subset(data, along = leadtime_dim, + indices = ff, drop = FALSE) + params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} + + c(x_spei_mod, params_ff) %<-% spX_ftime(data = Accum_D_temp, na.rm = TRUE, method = method, + distribution = distribution, + fit = fit, ref.start = ref.start, ref.end = ref.end, + params = params_tmp, n_sdates = n_sdates, nmemb = nmemb, + handle_infinity = handle_infinity, + cross_validation = cross_validation) + spei_mod[ff, , ] <- x_spei_mod + coef_names <- names(params_ff) + # lengthen dimension coef of params_ff in case it doesn't match the corresponding dimension of parms_months + if (length(params_ff) < n_coef_max) { + params_ff <- append(params_ff, array(NA, dim = n_coef_max - length(params_ff))) + coef_names <- append(coef_names, '') + } + params_result[, ff, ] <- params_ff + } + colnames(params_result) <- coef_names + names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') + return(list(spei = spei_mod, params = params_result)) } - - return(list(speiX, params)) - } #------------------------------------------------------------------------------- ### Support functions -spX <- function(acc_data, ref.start, ref.end, params = params, na.rm = TRUE, - method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', - leadtime_dim, time_dim, dim_memb, handle_infinity, cross_validation){ - - # acc_data: [ftime, syear, nmemb] - # params: [syear, ftime, coef] - - n_coef_max <- dim(params)['coef'] # maximum number of parameters needed to define any of the considered distributions - - ftime <- as.numeric(dim(acc_data)[leadtime_dim]) - n_sdates <- as.numeric(dim(acc_data)[time_dim]) - nmemb <- as.numeric(dim(acc_data)[dim_memb]) - - spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) - names(dim(spei_mod)) <- c(leadtime_dim, time_dim, dim_memb) - if (cross_validation) { - params_result <- array(data = NA, dim = c(n_sdates, ftime, n_coef_max)) - } else { - params_result <- array(data = NA, dim = c(1, ftime, n_coef_max)) - } - - for (ff in 1:ftime) { # treat months independently - Accum_D_temp <- ClimProjDiags::Subset(acc_data, along = leadtime_dim, indices = ff, drop = FALSE) - params_tmp <- if (all(is.na(params))) {NULL} else {params[,ff,]} - c(x_spei_mod, params_ff) %<-% spX_ftime(Accum_D_temp, na.rm = TRUE, method = method, distribution = distribution, - fit = fit, ref.start = ref.start, ref.end = ref.end, - params = params_tmp, n_sdates = n_sdates, nmemb = nmemb, - handle_infinity = handle_infinity, cross_validation = cross_validation) - spei_mod[ff,,] <- x_spei_mod - coef_names <- names(params_ff) - if (length(params_ff) < n_coef_max){ # lengthen dimension coef of params_ff in case it doesn't match the corresponding dimension of parms_months - params_ff <- append(params_ff, array(NA, dim = n_coef_max - length(params_ff))) - coef_names <- append(coef_names, '') - } - params_result[,ff,] <- params_ff - } +spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', + na.rm = TRUE, method = 'parametric', n_sdates, nmemb, + ref.start = NULL, ref.end = NULL, params = NULL, + handle_infinity = FALSE, cross_validation = FALSE) { - colnames(params_result) <- coef_names - names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') - - return(list(spei = spei_mod, params = params_result)) -} + # data: [leadtime_dim = 1, time_dim, memb_dim] -#------------------------------------------------------------------------------- + if (anyNA(data) && na.rm == FALSE) { + stop('Error: Data must not contain NAs') # TO DO: return something? + } -# HandleInfinity: -spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = TRUE, method = 'parametric', n_sdates, nmemb, - ref.start = NULL, ref.end = NULL, params = NULL, handle_infinity = FALSE, cross_validation = FALSE) { - - # data:[ftime = 1, syear, ensemble] - if (method == 'non-parametric') { - - if (anyNA(data) && na.rm == FALSE) { - stop('Error: Data must not contain NAs') - } - + bp = matrix(0, length(data), 1) for (i in 1:length(data)) { - bp[i,1] = sum(data[] <= data[i]); # Writes the rank of the data + bp[i,1] = sum(data[] <= data[i], na.rm = na.rm); # Writes the rank of the data } - - SPEI = qnorm((bp-0.44)/(length(data)+0.12)) + SPEI = qnorm((bp - 0.44)/(length(data) + 0.12)) return(SPEI) # it won't return params to be used in exp_cor; also it is not using handle_infinity nor cross_validation } else { std_index <- array(NA, c(n_sdates, nmemb)) - + if (anyNA(data) && na.rm == FALSE) { stop('Error: Data must not contain NAs') } - coef = switch(distribution, "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha','beta'))), "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi','alpha','kappa'))), @@ -740,11 +731,11 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm dim_one <- length(coef) if (!is.null(params)) { - if (length(params) != dim_one) { + if (length(params)!=dim_one) { stop(paste0('parameters array should have dimensions [', dim_one, ']')) } } - + # Select window if necessary if (!is.null(ref.start) && !is.null(ref.end)) { data.fit <- window(data,ref.start,ref.end) @@ -752,107 +743,111 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', na.rm data.fit <- data } - if (cross_validation == "TRUE") { + if (cross_validation) { loop_years <- n_sdates } else { loop_years <- 1 } + params_result <- array(NA, dim = c(loop_years, dim_one)) colnames(params_result) <- names(coef) for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) # Cumulative series (acu) - if (cross_validation == TRUE){ + if (cross_validation) { acu <- as.vector(data.fit[,-nsd,]) } else { acu <- as.vector(data.fit) } acu.sorted <- sort.default(acu, method = "quick") - acu.sorted <- acu.sorted[!is.na(acu.sorted)] # remove NAs (no need if(na.rm) because if there are NA and na.rm=F we don't get to this point) - if (length(acu.sorted)!=0){ # else all acu was NA and we don't need to continue with this case + # remove NAs (no need if(na.rm) because if there are NA and na.rm = F we don't get to this point) + acu.sorted <- acu.sorted[!is.na(acu.sorted)] + # else all acu was NA and we don't need to continue with this case + if (length(acu.sorted) != 0) { acu_sd = sd(acu.sorted) - if (!is.na(acu_sd)){ - if (acu_sd != 0){ - if(distribution != "log-Logistic") { - pze <- sum(acu==0)/length(acu) - acu.sorted = acu.sorted[acu.sorted > 0] - } - if (!is.null(params)) { - f_params = as.vector(params) - params_result[nsd,] <- f_params - } else { - if (length(acu.sorted) >= 4){ # else coef will be NA - # Calculate probability weighted moments based on fit with lmomco or TLMoments - pwm = switch(fit, - "pp-pwm" = pwm.pp(acu.sorted,-0.35,0, nmom=3), - pwm.ub(acu.sorted, nmom=3) - #TLMoments::PWM(acu.sorted, order=0:2) - ) - - # Check L-moments validity - lmom <- pwm2lmom(pwm) - if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))){ - - # lmom fortran functions need specific inputs L1, L2, T3 - # this is handled by lmomco internally with lmorph - fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) - - # Calculate parameters based on distribution with lmom then lmomco - f_params = switch(distribution, - "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), error = function(e){ parglo(lmom)$para }), - "Gamma" = tryCatch(lmom::pelgam(fortran_vec), error = function(e){ pargam(lmom)$para }), - "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), error = function(e){ parpe3(lmom)$para }) - ) - - # Adjust if user chose log-Logistic and max-lik - if(distribution == 'log-Logistic' && fit == 'max-lik'){ - f_params = parglo.maxlik(acu.sorted, f_params)$para - } - params_result[nsd,] <- f_params - } # end if dor the case the L-moments are not valid (std_index will be NA) - } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) - } # end estimation of f_param - # Calculate cdf based on distribution with lmom - if (all(is.na(params_result[nsd,]))){ - cdf_res <- NA - } else { - f_params <- params_result[nsd,] - f_params <- f_params[which(!is.na(f_params))] - cdf_res = switch(distribution, - "log-Logistic" = lmom::cdfglo(data, f_params), - "Gamma" = lmom::cdfgam(data, f_params), - "PearsonIII" = lmom::cdfpe3(data, f_params) - ) - } - - std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) - - # Adjust if user chose Gamma or PearsonIII - Not tested: For future development - #if(distribution != 'log-Logistic'){ - # std_index[ff,s] = qnorm(pze + (1-pze)*pnorm(std_index[ff,s])) # ff doesn't exist at this point - #} - if (cross_validation == TRUE){ - std_index[nsd,] <- std_index_cv[nsd,] - } else { - std_index <- std_index_cv + if (!is.na(acu_sd)) { + if (acu_sd != 0) { + if (distribution != "log-Logistic") { + pze <- sum(acu == 0) / length(acu) + acu.sorted = acu.sorted[acu.sorted > 0] + } + if (!is.null(params)) { + f_params = as.vector(params) + params_result[nsd, ] <- f_params + } else { + # else coef will be NA + if (length(acu.sorted) >= 4) { + # Calculate probability weighted moments based on fit with lmomco or TLMoments + pwm = switch(fit, + "pp-pwm" = pwm.pp(acu.sorted,-0.35,0, nmom=3), + pwm.ub(acu.sorted, nmom=3) + # TLMoments::PWM(acu.sorted, order = 0:2) + ) + + # Check L-moments validity + lmom <- pwm2lmom(pwm) + if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { + # lmom fortran functions need specific inputs L1, L2, T3 + # this is handled by lmomco internally with lmorph + fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) + + # Calculate parameters based on distribution with lmom then lmomco + f_params = switch(distribution, + "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), + error = function(e){ parglo(lmom)$para }), + "Gamma" = tryCatch(lmom::pelgam(fortran_vec), + error = function(e){ pargam(lmom)$para }), + "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), + error = function(e){ parpe3(lmom)$para })) + + # Adjust if user chose log-Logistic and max-lik + if (distribution == 'log-Logistic' && fit == 'max-lik') { + f_params = parglo.maxlik(acu.sorted, f_params)$para + } + params_result[nsd, ] <- f_params + } # end if dor the case the L-moments are not valid (std_index will be NA) + } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) + } # end estimation of f_param + # Calculate cdf based on distribution with lmom + if (all(is.na(params_result[nsd,]))) { + cdf_res <- NA + } else { + f_params <- params_result[nsd,] + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data, f_params), + "Gamma" = lmom::cdfgam(data, f_params), + "PearsonIII" = lmom::cdfpe3(data, f_params)) + } + + std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) + + # Adjust if user chose Gamma or PearsonIII - Not tested: For future development + # if (distribution != 'log-Logistic') { + # std_index[ff,s] = qnorm(pze + (1-pze)*pnorm(std_index[ff,s])) # ff doesn't exist at this point + # } + if (cross_validation) { + std_index[nsd, ] <- std_index_cv[nsd, ] + } else { + std_index <- std_index_cv + } } - } - } # end if for the case there is no variability - } # end if for the case all NA in acu - } # next year (in case of cross_validation or all done if cross_validation == F) + } # end if for the case there is no variability + } # end if for the case all NA in acu + } # next year (in case of cross_validation or all done if cross_validation == F) - if(handle_infinity == 'TRUE'){ # could also use "param_error" ?; we are giving it the min/max value of the grid point + if (handle_infinity) { # could also use "param_error" ?; we are giving it the min/max value of the grid point std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) std_index[is.infinite(std_index) & std_index > 0] <- max(std_index[!is.infinite(std_index)]) } - - return(list(std_index = std_index, params = params_result)) # f_params will be params only if cross_validation is FALSE - # (otherwise there will be one f_params per year; - # but the output params will be read only in the case that - # it is called with cross_validation FALSE) + # f_params will be params only if cross_validation is FALSE + # (otherwise there will be one f_params per year; + # but the output params will be read only in the case that + # it is called with cross_validation FALSE) + return(list(std_index = std_index, params = params_result)) - } # end parametric - + } } +#------------------------------------------------------------------------------- -- GitLab From b5dde53a71224afbda3c61b5d4fc0eb6e4f4728d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 1 Jun 2023 17:26:56 +0200 Subject: [PATCH 08/87] Develop original_dates and correct Dates --- R/PeriodMean.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 85a12a7..303b38e 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -65,12 +65,19 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, total <- PeriodMean(data = data$data, dates = data$attrs$Dates, start, end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total + original_dates <- data$attrs$Dates if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, time_dim = time_dim, ncores = ncores) } + data$attrs$Dates <- ClimProjDiags::Subset(data$attrs$Dates, time_dim, 1, + drop = 'selected') + # Option (1) + # attr(data$attrs$Dates, 'original_dates') <- original_dates + # Option (2) + data$attrs$original_dates <- original_dates return(data) } -- GitLab From 96c3f9a56d23b0716220366a84573840e97de2a9 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 2 Jun 2023 09:41:57 +0200 Subject: [PATCH 09/87] Use testthat edition 3; remove context() --- DESCRIPTION | 1 + tests/testthat/test-AbsToProbs.R | 2 -- tests/testthat/test-AccumulationExceedingThreshold.R | 3 +-- tests/testthat/test-MergeRefToExp.R | 2 -- tests/testthat/test-PeriodAccumulation.R | 3 +-- tests/testthat/test-PeriodMean.R | 3 +-- tests/testthat/test-QThreshold.R | 3 +-- tests/testthat/test-SelectPeriod.R | 2 +- tests/testthat/test-Threshold.R | 3 +-- tests/testthat/test-TotalSpellTimeExceedingThreshold.R | 2 +- tests/testthat/test-TotalTimeExceedingThreshold.R | 2 +- tests/testthat/test-WindCapacityFactor.R | 2 +- tests/testthat/test-WindPowerDensity.R | 2 +- 13 files changed, 11 insertions(+), 19 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 90e0e83..4151ba4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,3 +40,4 @@ URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 RoxygenNote: 7.2.0 +Config/testthat/edition: 3 \ No newline at end of file diff --git a/tests/testthat/test-AbsToProbs.R b/tests/testthat/test-AbsToProbs.R index 902b3f1..c2cdc9f 100644 --- a/tests/testthat/test-AbsToProbs.R +++ b/tests/testthat/test-AbsToProbs.R @@ -1,5 +1,3 @@ -context("CSIndicators::AbsToProbs tests") - ############################################## # dat1 dat1 <- NULL diff --git a/tests/testthat/test-AccumulationExceedingThreshold.R b/tests/testthat/test-AccumulationExceedingThreshold.R index a6b598e..0331e8e 100644 --- a/tests/testthat/test-AccumulationExceedingThreshold.R +++ b/tests/testthat/test-AccumulationExceedingThreshold.R @@ -1,5 +1,4 @@ -context("CSIndicators::AccumulationExceedingThreshold tests") - +############################################## # dat1 dat1 <- 1:20 diff --git a/tests/testthat/test-MergeRefToExp.R b/tests/testthat/test-MergeRefToExp.R index 2c3e8f6..adbdfd6 100644 --- a/tests/testthat/test-MergeRefToExp.R +++ b/tests/testthat/test-MergeRefToExp.R @@ -1,5 +1,3 @@ -context("CSIndicators::MergeRefToExp tests") - ########################################################################### test_that("Sanity checks", { diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 777dc30..81718f5 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -1,5 +1,4 @@ -context("CSIndicators::PeriodAccumulation tests") - +############################################## test_that("Sanity Checks", { expect_error( PeriodAccumulation('x'), diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index 7576b11..4186639 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -1,5 +1,4 @@ -context("CSIndicators::PeriodMean tests") - +############################################## test_that("Sanity Checks", { expect_error( PeriodMean('x'), diff --git a/tests/testthat/test-QThreshold.R b/tests/testthat/test-QThreshold.R index 41cc3e5..deb35df 100644 --- a/tests/testthat/test-QThreshold.R +++ b/tests/testthat/test-QThreshold.R @@ -1,5 +1,4 @@ -context("CSIndicators::QThreshold tests") - +############################################## test_that("Sanity checks", { expect_error( QThreshold(NULL), diff --git a/tests/testthat/test-SelectPeriod.R b/tests/testthat/test-SelectPeriod.R index 1c264c2..deb8656 100644 --- a/tests/testthat/test-SelectPeriod.R +++ b/tests/testthat/test-SelectPeriod.R @@ -1,4 +1,4 @@ -context("CSIndicators::SelectPeriodOnData and SelectPeriodOnDates tests") +############################################## library(s2dv) diff --git a/tests/testthat/test-Threshold.R b/tests/testthat/test-Threshold.R index 24ca601..84e4e0d 100644 --- a/tests/testthat/test-Threshold.R +++ b/tests/testthat/test-Threshold.R @@ -1,5 +1,4 @@ -context("CSIndicators::Threshold tests") - +############################################## test_that("Sanity checks", { expect_error( Threshold(NULL), diff --git a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R index d215529..36e46cf 100644 --- a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R @@ -1,4 +1,4 @@ -context("CSIndicators::TotalSpellTimeExceedingThreshold tests") +############################################## # dat1 dat <- array(1:20, dim = c(2, 10)) diff --git a/tests/testthat/test-TotalTimeExceedingThreshold.R b/tests/testthat/test-TotalTimeExceedingThreshold.R index 68c6d77..1c3ca19 100644 --- a/tests/testthat/test-TotalTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalTimeExceedingThreshold.R @@ -1,4 +1,4 @@ -context("CSIndicators::TotalTimeExceedingThreshold tests") +############################################## # dat1 dat <- array(1:20, dim = c(2, 10)) diff --git a/tests/testthat/test-WindCapacityFactor.R b/tests/testthat/test-WindCapacityFactor.R index 1bf9089..bcecdbc 100644 --- a/tests/testthat/test-WindCapacityFactor.R +++ b/tests/testthat/test-WindCapacityFactor.R @@ -1,4 +1,4 @@ -context("CSIndicators::WindCapacityFactor tests") +############################################## # dat1 wind <- NULL diff --git a/tests/testthat/test-WindPowerDensity.R b/tests/testthat/test-WindPowerDensity.R index 249c529..184b062 100644 --- a/tests/testthat/test-WindPowerDensity.R +++ b/tests/testthat/test-WindPowerDensity.R @@ -1,4 +1,4 @@ -context("CSIndicators::WindPowerDensity tests") +########################################################################### # dat1 wind <- NULL -- GitLab From 20d7a12e3b2a3bf489b677f0808a6a3349fb3dee Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 9 Jun 2023 17:21:21 +0200 Subject: [PATCH 10/87] Add documentation and improve code --- R/PeriodSPEI.R | 704 ++++++++++++++++++------------- R/zzz.R | 8 + tests/testthat/test-PeriodSPEI.R | 33 +- 3 files changed, 460 insertions(+), 285 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 2eec05f..552c0d2 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -1,7 +1,7 @@ #'Compute the Standardised Precipitation-Evapotranspiration Index #' -#'The Standardised Precipitation-Evapotranspiration Index (SPEI) is a -#'multiscalar drought index based on climatic data. It can be used for +#'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) +#'that is a multiscalar drought index based on climatic data. It can be used for #'determining the onset, duration and magnitude of drought conditions with #'respect to normal conditions in a variety of natural and managed systems such #'as crops, ecosystems, rivers, water resources, etc. The SPI is calculated @@ -11,7 +11,14 @@ #'to obtain the SPEI. #' #'@param exp A named list with the needed \code{s2dv_cube} objects containing -#' the seasonal forecast experiment in the data element for each variable. +#' the seasonal forecast experiment in the data element for each variable. +#' Specific variables are needed for each method used in computing the +#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted +#' variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and +#' 'hargreaves_modified' and 'tas', required for method 'thornthwaite'. +#' Variable 'prlr' is always needed. The units for temperature variables +#' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for +#' precipitation ('prlr') need to be in mm/month. #'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each #' variable in which the quantile PeriodSPEI should be applied. If it is not #' specified, the PeriodSPEI is calculated from object 'exp'. @@ -29,46 +36,85 @@ #' dimension. By default it is set by 'latitude'. #'@param accum An integer value indicating the number of months for the #' accumulation for each variable. -#'@param start -#'@param end -#'@param pet_method -#'@param standardization -#'@param params -#'@param param_error -#'@param handle_infinity -#'@param cross_validation -#'@param method -#'@param distribution -#'@param fit -#'@param ncores +#'@param ref_period A list with two numeric values with the starting and end +#' points of the reference period used for computing the index. The default +#' value is NULL indicating that the first and end values in data will be +#' used as starting and end points. +#'@param params A multidimensional array with named dimensions for computing the +#' SPEI. This option overrides computation of fitting parameters. It needs +#' to be of same leadtime and time dimensions of exp and a dimension named +#' 'coef' with the length of the coefficients needed for the used distribution +#' (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or +#' 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime +#' dimension must be of length 1. +#'@param standardization A logical value indicating wether the standardization +#' is computed. +#'@param cross_validation A logical value indicating if cross validation is +#' done (TRUE), or not (FALSE). It is FALSE by default. +#'@param pet_method A character string indicating the method used to compute +#' the potential evapotranspiration. The accepted methods are: +#' 'hargreaves' and 'hargreaves_modified', that require the data to have +#' variables tasmin and tasmax; and 'thornthwaite', that requires variable +#' 'tas'. +#'@param method A character string indicating the standardization method used. +#' If can be: 'parametric' or 'non-parametric'. +#'@param distribution A character string indicating the name of the distribution +#' function to be used for computing the SPEI. The accepted names are: +#' 'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by +#' default. +#'@param fit A character string indicating the name of the method used for +#' computing the distribution function parameters The accepteed names are: +#' 'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default. +#'@param param_error A numeric value with the error accepted. +#'@param handle_infinity A logical value wether to return Infinite values (TRUE) +#' or not (FALSE). +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. #' #'@examples -#'exp <- 1 +#'# Test random data +#'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, +#' latitude = 2, longitude = 1, ensemble = 25) +#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, +#' latitude = 2, longitude = 1, ensemble = 15) +#'exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) #' -# '@import s2dv -# '@import multiApply -# '@import ClimProjDiags -# '@import zeallot -# '@import SPEI -# '@import zoo -# '@import TLMoments -# '@import lmomco -# '@import lubridate -# '@import CSTools -# '@export +#'expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) +#'expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) +#'expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) +#' +#'dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), +#' paste0(2010:2015, "-10-16"))) +#'dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +#' +#'lat <- c(40,40.1) +#' +#'exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +#'exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, +#' 'prlr' = expcor_prlr) +#'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates = dates) +#' +#'@import multiApply +#'@import ClimProjDiags +#'@import SPEI +#'@import zoo +#'@import TLMoments +#'@import lmomco +#'@import lubridate +#'@export CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', - accum = 1, start = NULL, end = NULL, - ref_period = NULL, pet_method = 'hargreaves', - standardization = TRUE, - params = NULL, # not used if standardization is FALSE - param_error = -9999, # not used if standardization is FALSE - handle_infinity = FALSE, # not used if standardization is FALSE - cross_validation = FALSE, # not used if standardization is FALSE - method = 'parametric', distribution = 'log-Logistic', - fit = 'ub-pwm', # not used if standardization is FALSE - ncores = NULL) { + accum = 1, ref_period = NULL, params = NULL, + standardization = TRUE, cross_validation = FALSE, + pet_method = 'hargreaves', method = 'parametric', + distribution = 'log-Logistic', fit = 'ub-pwm', + param_error = -9999, handle_infinity = FALSE, + na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (is.null(exp)) { @@ -83,45 +129,148 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, } } - .KnownLatNames <- CSTools:::.KnownLatNames() - - if (!any(names(exp[[1]]$coords) %in% .KnownLatNames)) { + if (!any(names(exp[[1]]$coords) %in% .KnownLatNames())) { stop("Spatial coordinate names of parameter 'exp' do not match any ", "of the names accepted by the package.") } - lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames)]] + lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames())]] res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), dates = exp[[1]]$attrs$Dates, lat = exp[[1]]$coords[[lat_name]], exp_cor = lapply(exp_cor, function(x) x$data), - pet = pet, ref_period = ref_period, - time_dim = time_dim, leadtime_dim = leadtime_dim, + pet = pet, time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, lat_dim = lat_dim, - accum = accum, start = start, end = end, - pet_method = pet_method, standardization = standardization, - params = params, param_error = param_error, - handle_infinity = handle_infinity, - cross_validation = cross_validation, - method = method, distribution = distribution, - fit = fit, ncores = ncores) + accum = accum, ref_period = ref_period, params = params, + standardization = standardization, + cross_validation = cross_validation, + pet_method = pet_method, method = method, + distribution = distribution, fit = fit, + param_error = param_error, + handle_infinity = handle_infinity, na.rm = na.rm, + ncores = ncores) return(res) } - -PeriodSPEI <- function(exp, dates, lat, - exp_cor = NULL, pet = NULL, +#'Compute the Standardised Precipitation-Evapotranspiration Index +#' +#'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) +#'that is a multiscalar drought index based on climatic data. It can be used for +#'determining the onset, duration and magnitude of drought conditions with +#'respect to normal conditions in a variety of natural and managed systems such +#'as crops, ecosystems, rivers, water resources, etc. The SPI is calculated +#'using monthly (or weekly) precipitation as the input data. The SPEI uses the +#'monthly (or weekly) difference between precipitation and pet. This represents +#'a simple climatic water balance which is calculated at different time scales +#'to obtain the SPEI. +#' +#'@param exp A named list with the needed \code{s2dv_cube} objects containing +#' the seasonal forecast experiment in the data element for each variable. +#' Specific variables are needed for each method used in computing the +#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted +#' variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and +#' 'hargreaves_modified' and 'tas', required for method 'thornthwaite'. +#' Variable 'prlr' is always needed. The units for temperature variables +#' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for +#' precipitation ('prlr') need to be in mm/month. +#'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each +#' variable in which the quantile PeriodSPEI should be applied. If it is not +#' specified, the PeriodSPEI is calculated from object 'exp'. +#'@param pet A multidimensional array containing the Potential +#' EvapoTranspiration data. If it is NULL it is calculated using pet_method. It +#' is NULL by default. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param memb_dim A character string indicating the name of the dimension in +#' which the ensemble members are stored. When set it to NULL, threshold is +#' computed for individual members. +#'@param lat_dim A character string indicating the name of the latitudinal +#' dimension. By default it is set by 'latitude'. +#'@param accum An integer value indicating the number of months for the +#' accumulation for each variable. +#'@param ref_period A list with two numeric values with the starting and end +#' points of the reference period used for computing the index. The default +#' value is NULL indicating that the first and end values in data will be +#' used as starting and end points. +#'@param params A multidimensional array with named dimensions for computing the +#' SPEI. This option overrides computation of fitting parameters. It needs +#' to be of same leadtime and time dimensions of exp and a dimension named +#' 'coef' with the length of the coefficients needed for the used distribution +#' (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or +#' 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime +#' dimension must be of length 1. +#'@param standardization A logical value indicating wether the standardization +#' is computed. +#'@param cross_validation A logical value indicating if cross validation is +#' done (TRUE), or not (FALSE). It is FALSE by default. +#'@param pet_method A character string indicating the method used to compute +#' the potential evapotranspiration. The accepted methods are: +#' 'hargreaves' and 'hargreaves_modified', that require the data to have +#' variables tasmin and tasmax; and 'thornthwaite', that requires variable +#' 'tas'. +#'@param method A character string indicating the standardization method used. +#' If can be: 'parametric' or 'non-parametric'. +#'@param distribution A character string indicating the name of the distribution +#' function to be used for computing the SPEI. The accepted names are: +#' 'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by +#' default. +#'@param fit A character string indicating the name of the method used for +#' computing the distribution function parameters The accepteed names are: +#' 'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default. +#'@param param_error A numeric value with the error accepted. +#'@param handle_infinity A logical value wether to return Infinite values (TRUE) +#' or not (FALSE). +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@examples +#'# Test random data +#'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, +#' latitude = 2, longitude = 1, ensemble = 25) +#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, +#' latitude = 2, longitude = 1, ensemble = 15) +#'exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) +#' +#'expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) +#'expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) +#'expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) +#' +#'dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), +#' paste0(2010:2015, "-10-16"))) +#'dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +#' +#'lat <- c(40,40.1) +#' +#'exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +#'exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, +#' 'prlr' = expcor_prlr) +#'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates = dates) +#' +#'@import multiApply +#'@import ClimProjDiags +#'@import SPEI +#'@import zoo +#'@import TLMoments +#'@import lmomco +#'@import lubridate +#'@export +PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', - accum = 1, start = NULL, end = NULL, - pet_method = 'hargreaves', ref_period = NULL, - standardization = TRUE, - params = NULL, param_error = -9999, - handle_infinity = FALSE, cross_validation = FALSE, - method = 'parametric', distribution = 'log-Logistic', - fit = 'ub-pwm', ncores = 4) { + accum = 1, ref_period = NULL, params = NULL, + standardization = TRUE, cross_validation = FALSE, + pet_method = 'hargreaves', method = 'parametric', + distribution = 'log-Logistic', fit = 'ub-pwm', + param_error = -9999, handle_infinity = FALSE, + na.rm = FALSE, ncores = NULL) { # Initial checks ## exp @@ -297,7 +446,7 @@ PeriodSPEI <- function(exp, dates, lat, } ## fit if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { - stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik"') + stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik".') } ## ncores @@ -316,9 +465,11 @@ PeriodSPEI <- function(exp, dates, lat, dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] - dates_monthly <- array(0, dim=length(dates_complete_monthly)) + dates_monthly <- array(0, dim = length(dates_complete_monthly)) for (dd in 1:length(dates)) { - ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), lubridate::month(dates[dd]), 01, sep = '-'))) + ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), + lubridate::month(dates[dd]), + 01, sep = '-'))) dates_monthly[ii] <- 1 } @@ -331,34 +482,31 @@ PeriodSPEI <- function(exp, dates, lat, k = k + 1 # Evapotranspiration estimation (unless pet is already provided) if (is.null(pet) | computed_pet) { - pet <- evapotranspiration(data = data, dates_monthly = dates_monthly, - lat = lat, pet_method = pet_method[k], - time_dim = time_dim, leadtime_dim = leadtime_dim, - lat_dim = lat_dim, ncores = ncores) + pet <- .Evapotranspiration(data = data, dates_monthly = dates_monthly, + lat = lat, pet_method = pet_method[k], + time_dim = time_dim, leadtime_dim = leadtime_dim, + lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) computed_pet <- TRUE } # Accumulation diff_p_pet <- data$prlr - pet - data_accum <- accumulation(data = diff_p_pet, - dates_monthly = dates_monthly, accum = accum, - time_dim = time_dim, leadtime_dim = leadtime_dim, - ncores = ncores) + data_accum <- .Accumulation(data = diff_p_pet, + dates_monthly = dates_monthly, accum = accum, + time_dim = time_dim, leadtime_dim = leadtime_dim, + ncores = ncores) # Standardization: - if (standardization == TRUE) { - spei_dat <- spei_standardization(data = data_accum, - leadtime_dim = leadtime_dim, - time_dim = time_dim, - memb_dim = memb_dim, - ref_period = ref_period, - cross_validation = cross_validation, - handle_infinity = handle_infinity, - ncores = ncores, - accum = accum, - param_error = param_error, - params = params, method = method, - distribution = distribution, - fit = fit) + if (standardization) { + spei_dat <- .Standardization(data = data_accum, params = params, + accum = accum, time_dim = time_dim, + leadtime_dim = leadtime_dim, + memb_dim = memb_dim, + ref_period = ref_period, + cross_validation = cross_validation, + handle_infinity = handle_infinity, + param_error = param_error, + method = method, distribution = distribution, + fit = fit, ncores = ncores) params <- spei_dat$params } else { spei_dat <- data_accum @@ -380,9 +528,7 @@ PeriodSPEI <- function(exp, dates, lat, names(spei_res) <- c('exp', 'exp_cor') } } - return(spei_res) - } @@ -395,11 +541,10 @@ PeriodSPEI <- function(exp, dates, lat, } -#------------------------------------------------------------------------------- - -evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreaves', - time_dim = 'syear', leadtime_dim = 'time', - lat_dim = 'latitude', ncores = NULL) { +.Evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreaves', + time_dim = 'syear', leadtime_dim = 'time', + lat_dim = 'latitude', na.rm = FALSE, + ncores = NULL) { lat_mask <- array(lat, dim = c(1, length(lat))) names(dim(lat_mask)) <- c('dat', lat_dim) @@ -428,31 +573,33 @@ evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreave # prepare data target_dims_data <- lapply(data[varnames], function(x) rep(c(leadtime_dim, time_dim), 1)) # file <- tempfile() - # file = 'out.txt' # sink(file) - pet_estimated <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), - target_dims = c(list(lat_mask = 'dat'), target_dims_data), - output_dims = c(leadtime_dim, time_dim), - pet_method = pet_method, - dates_monthly = dates_monthly, - leadtime_dim = leadtime_dim, time_dim = time_dim, - fun = atomic_pet, ncores = ncores)$output1 - # sink(NULL) + # print(varnames) + # print(is.na(data['tasmax'])) + # print(is.na(data['tasmin'])) + pet <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), + target_dims = c(list(lat_mask = 'dat'), target_dims_data), + fun = .evapotranspiration, + dates_monthly = dates_monthly, pet_method = pet_method, + leadtime_dim = leadtime_dim, time_dim = time_dim, + output_dims = c(leadtime_dim, time_dim), + ncores = ncores)$output1 + # sink() # captured_message <- readLines(file) - + # print(unique(captured_message)) # reorder dims in pet_estimated - pos <- match(names(dim(data[[1]])),names(dim(pet_estimated))) - pet_estimated <- aperm(pet_estimated, pos) + pos <- match(names(dim(data[[1]])), names(dim(pet))) + pet <- aperm(pet, pos) # restore original NAs from mask_na - pet_estimated[which(mask_na == 0 )] <- NA - - return(pet_estimated) + pet[which(mask_na == 0 )] <- NA + return(pet) } -atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL, - pet_method, dates_monthly, leadtime_dim, time_dim) { +.evapotranspiration <- function(lat_mask, data2, data3 = NULL, data4 = NULL, + dates_monthly, pet_method = 'hargreaves', + leadtime_dim = 'time', time_dim = 'syear') { dims <- dim(data2) @@ -460,7 +607,7 @@ atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL # of the considered period # (starting in January of the first year) so that the solar radiation # estimation is computed in each case for the correct month - + any(is.na(data2)) if (!is.null(data2)) { data_tmp <- as.vector(data2) data2 <- array(0, dim = length(dates_monthly)) @@ -473,6 +620,7 @@ atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL } rm(data_tmp) } + any(is.na(data3)) if (!is.null(data3)) { data_tmp <- as.vector(data3) data3 <- array(0, dim = length(dates_monthly)) @@ -499,52 +647,58 @@ atomic_pet <- function(lat_mask = NULL, data2 = NULL, data3 = NULL, data4 = NULL } if (pet_method == 'hargreaves') { # NOTE EVA: if NA.RM is FALSE this gives error - x_pet <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, na.rm = TRUE)) + # print('hi') + # print(any(is.na(data3))) + # print('he') + # print(any(is.na(data2))) + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = na.rm, verbose = FALSE) # line to return the vector to the size of the actual original data - x_pet <- x_pet[which(dates_monthly == 1)] - pet <- array(x_pet, dim = dims) + pet <- pet[which(dates_monthly == 1)] + pet <- array(pet, dim = dims) } if (pet_method == 'hargreaves_modified') { - x_pet <- invisible(hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, Pre = as.vector(data4), na.rm = TRUE)) - x_pet <- x_pet[which(dates_monthly == 1)] - pet <- array(x_pet, dim = dims) + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = na.rm, + verbose = FALSE) + pet <- pet[which(dates_monthly == 1)] + pet <- array(pet, dim = dims) } if (pet_method == 'thornthwaite') { - x_pet <- invisible(thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE)) + pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = na.rm, + verbose = FALSE) # line to return the vector to the size of the actual original data - x_pet <- x_pet[which(dates_monthly == 1)] - pet <- array(x_pet, dim = dims) + pet <- pet[which(dates_monthly == 1)] + pet <- array(pet, dim = dims) } return(pet) } -#------------------------------------------------------------------------------- -accumulation <- function(data, dates_monthly, accum = 1, - time_dim = 'syear', leadtime_dim = 'time', - ncores = NULL) { +.Accumulation <- function(data, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time', + ncores = NULL) { - accum_result <- Apply(data = list(data), - target_dims = list(data = c(leadtime_dim, time_dim)), - dates_monthly = dates_monthly, - accum = accum, - output_dims = c(leadtime_dim, time_dim), - leadtime_dim = leadtime_dim, time_dim = time_dim, - fun = atomic_accum, ncores = ncores)$output1 + accumulated <- Apply(data = list(data), + target_dims = list(data = c(leadtime_dim, time_dim)), + dates_monthly = dates_monthly, + accum = accum, + output_dims = c(leadtime_dim, time_dim), + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = .accumulation, + ncores = ncores)$output1 - pos <- match(names(dim(accum_result)), names(dim(data))) - data_accum <- aperm(accum_result, pos) + pos <- match(names(dim(accumulated)), names(dim(data))) + accumulated <- aperm(accumulated, pos) - return(data_accum) + return(accumulated) } -atomic_accum <- function(data, dates_monthly, accum = 1, - time_dim = 'syear', leadtime_dim = 'time') { +.accumulation <- function(data, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time') { # data:[time, syear] dims <- dim(data) @@ -558,215 +712,205 @@ atomic_accum <- function(data, dates_monthly, accum = 1, } } # Accumulation at different timescales - # rollapply {zoo} A generic function for applying a function to rolling margins of an array. + # rollapply {zoo} A generic function for applying a function to rolling + # margins of an array. data_sum_x <- rollapply(data_vector, accum, sum) - # adds as many NAs as needed at the begining to account for the months that cannot be added - # (depends on accu) and so that the position in the vector corresponds to the accumulated - # of the previous months (instead of the accumulated of the next months) + # adds as many NAs as needed at the begining to account for the months that + # cannot be added (depends on accu) and so that the position in the vector + # corresponds to the accumulated of the previous months (instead of the + # accumulated of the next months) data_sum_x <- c(rep(NA, accum-1), data_sum_x) # discard the months that don't appear in the original data data_sum_x <- data_sum_x[which(dates_monthly == 1)] accum_result <- array(data_sum_x, dim = c(dims)) - # replace by NA when the accumulation corresponds to months that where not present in the original data + # replace by NA when the accumulation corresponds to months that where not + # present in the original data if (accum > 1) { accum_result[1:(accum-1), ] <- NA } return(accum_result) } -#------------------------------------------------------------------------------- +.Standardization <- function(data, params = NULL, accum = 1, time_dim = 'syear', + leadtime_dim = 'time', memb_dim = 'ensemble', + ref_period = NULL, cross_validation = FALSE, + handle_infinity = FALSE, param_error = -9999, + method = 'parametric', distribution = 'log-Logistic', + fit = 'ub-pwm', na.rm = FALSE, ncores = NULL) { - -spei_standardization <- function(data, accum = 1, time_dim = 'syear', - leadtime_dim = 'time', memb_dim = 'ensemble', - ref_period = NULL, - handle_infinity = FALSE, - cross_validation = FALSE, - param_error = -9999, params = NULL, - method = 'parametric', - distribution = 'log-Logistic', - fit = 'ub-pwm', - ncores = NULL) { - - n_leadtimes <- dim(data)[leadtime_dim] - n_sdates_params <- dim(data)[time_dim] + nleadtime <- dim(data)[leadtime_dim] + ntime <- dim(data)[time_dim] if (!cross_validation) { - n_sdates_params <- 1 + ntime <- 1 } + coef = switch(distribution, + "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha', 'beta'))), + "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi', 'alpha', 'kappa'))), + "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu', 'sigma', 'gamma')))) + if (is.null(params)) { - params <- array(NA, dim = c(n_sdates_params, n_leadtimes, coef = 3)) # hardcoded + params <- array(NA, dim = c(ntime, nleadtime, length(coef))) names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') } else if (length(dim(params)) < 2) { - params <- array(params, dim = c(length(params), n_sdates_params, n_leadtimes)) - params <- aperm(params, c(2,3,1)) # dim(params): [time_dim, leadtime_dim, coef] with the values repeated each time_dim and leadtime_dim + params <- array(params, dim = c(length(params), ntime, nleadtime)) + # dim(params): [time_dim, leadtime_dim, coef] + # with the values repeated each time_dim and leadtime_dim + params <- aperm(params, c(2,3,1)) names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + } else { + if (dim(params)['coef'] != length(coef)) { + stop(paste0("Params array should have 'coef' dimension of length ", + length(coef), ".")) + } } spei <- Apply(data = list(data = data, params = params), target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), params = c(time_dim, leadtime_dim, 'coef')), - output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), - params = c(time_dim, leadtime_dim, 'coef')), + fun = .standardization, + coef = coef, leadtime_dim = leadtime_dim, time_dim = time_dim, memb_dim = memb_dim, handle_infinity = handle_infinity, cross_validation = cross_validation, method = method, distribution = distribution, fit = fit, - ref_period = ref_period, - param_error = param_error, - fun = atomic_spei, + ref_period = ref_period, param_error = param_error, + na.rm = na.rm, + output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), + params = c(time_dim, leadtime_dim, 'coef')), ncores = ncores) return(spei) # spei is a list of data_spei and params } - - - - -atomic_spei <- function(data, params, leadtime_dim = 'time', time_dim = 'syear', - memb_dim = 'ensemble', ref_period = NULL, - handle_infinity = FALSE, cross_validation = FALSE, - param_error = -9999, method = 'parametric', - distribution = 'log-Logistic', fit = 'ub-pwm') { +.standardization <- function(data, params, coef, leadtime_dim = 'time', + time_dim = 'syear', memb_dim = 'ensemble', + ref_period = NULL, handle_infinity = FALSE, + cross_validation = FALSE, param_error = -9999, + method = 'parametric', distribution = 'log-Logistic', + fit = 'ub-pwm', na.rm = FALSE) { # data: [leadtime_dim, time_dim, memb_dim] # params: [time_dim, leadtime_dim, 'coef'] - - if (is.null(ref_period)) { - ref.start <- NULL - ref.end <- NULL + + # maximum number of parameters needed to define any of the considered distributions + ncoef <- length(coef) + nleadtime <- as.numeric(dim(data)[leadtime_dim]) + ntime <- as.numeric(dim(data)[time_dim]) + nmemb <- as.numeric(dim(data)[memb_dim]) + + if (cross_validation) { + params_result <- array(data = NA, dim = c(ntime, nleadtime, ncoef)) } else { - ref.start <- ref_period[[1]] - ref.end <- ref_period[[2]] + params_result <- array(data = NA, dim = c(1, nleadtime, ncoef)) } + names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') if (all(is.na(data))) { - speiX <- array(NA, dim(data)) - # if the data [time, sdate, memb] has no variability it will raise an error further down, - # so we assign a value to the result and skip the step - } else if (var(data, na.rm = T) == 0) { - speiX <- array(param_error, dim(data)) - return(speiX) + spei_mod <- array(NA, dim(data)) + # if the data [time, sdate, memb] has no variability it will raise an error + # further down, so we assign a value to the result and skip the step + } else if (any(is.na(data)) && !na.rm) { + spei_mod <- array(NA, dim(data)) + } else if (var(data, na.rm = T) == 0) { + spei_mod <- array(param_error, dim(data)) } else { - n_coef_max <- dim(params)['coef'] - ftime <- as.numeric(dim(data)[leadtime_dim]) - n_sdates <- as.numeric(dim(data)[time_dim]) - nmemb <- as.numeric(dim(data)[memb_dim]) - - spei_mod <- array(data = NA, dim = c(ftime, n_sdates, nmemb)) - names(dim(spei_mod)) <- c(leadtime_dim, time_dim, memb_dim) - if (cross_validation) { - params_result <- array(data = NA, dim = c(n_sdates, ftime, n_coef_max)) + if (is.null(ref_period)) { + ref.start <- NULL + ref.end <- NULL } else { - params_result <- array(data = NA, dim = c(1, ftime, n_coef_max)) + ref.start <- ref_period[[1]] + ref.end <- ref_period[[2]] } - for (ff in 1:ftime) { # treat months independently - Accum_D_temp <- ClimProjDiags::Subset(data, along = leadtime_dim, - indices = ff, drop = FALSE) + + spei_mod <- array(data = NA, dim = c(nleadtime, ntime, nmemb)) + names(dim(spei_mod)) <- c(leadtime_dim, time_dim, memb_dim) + + for (ff in 1:nleadtime) { + data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, + indices = ff, drop = 'selected') params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} - - c(x_spei_mod, params_ff) %<-% spX_ftime(data = Accum_D_temp, na.rm = TRUE, method = method, - distribution = distribution, - fit = fit, ref.start = ref.start, ref.end = ref.end, - params = params_tmp, n_sdates = n_sdates, nmemb = nmemb, - handle_infinity = handle_infinity, - cross_validation = cross_validation) - spei_mod[ff, , ] <- x_spei_mod - coef_names <- names(params_ff) - # lengthen dimension coef of params_ff in case it doesn't match the corresponding dimension of parms_months - if (length(params_ff) < n_coef_max) { - params_ff <- append(params_ff, array(NA, dim = n_coef_max - length(params_ff))) - coef_names <- append(coef_names, '') + + + spei_data <- .std(data = data_subset, coef = coef, + ntime = ntime, nmemb = nmemb, + method = method, + distribution = distribution, + fit = fit, na.rm = na.rm, + ref.start = ref.start, + ref.end = ref.end, + params = params_tmp, + handle_infinity = handle_infinity, + cross_validation = cross_validation) + spei_mod[ff, , ] <- spei_data[[1]] + params_ff <- spei_data[[2]] + # lengthen dimension coef of params_ff in case it doesn't match the + # corresponding dimension of parms_months + if (!is.null(params_ff)) { + if (length(params_ff) < ncoef) { + params_ff <- append(params_ff, array(NA, dim = ncoef - length(params_ff))) + } + params_result[, ff, ] <- params_ff } - params_result[, ff, ] <- params_ff } - colnames(params_result) <- coef_names - names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') - return(list(spei = spei_mod, params = params_result)) } + return(list(spei = spei_mod, params = params_result)) } -#------------------------------------------------------------------------------- - -### Support functions - -spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', - na.rm = TRUE, method = 'parametric', n_sdates, nmemb, - ref.start = NULL, ref.end = NULL, params = NULL, - handle_infinity = FALSE, cross_validation = FALSE) { +.std <- function(data, coef, ntime, nmemb, method = 'parametric', + distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = FALSE, + ref.start = NULL, ref.end = NULL, params = NULL, + handle_infinity = FALSE, cross_validation = FALSE) { - # data: [leadtime_dim = 1, time_dim, memb_dim] - - if (anyNA(data) && na.rm == FALSE) { - stop('Error: Data must not contain NAs') # TO DO: return something? - } + # data: [time_dim, memb_dim] + # params: NULL or [(ntime), coef] if (method == 'non-parametric') { - - bp = matrix(0, length(data), 1) + bp <- matrix(0, length(data), 1) for (i in 1:length(data)) { bp[i,1] = sum(data[] <= data[i], na.rm = na.rm); # Writes the rank of the data } - SPEI = qnorm((bp - 0.44)/(length(data) + 0.12)) - - return(SPEI) # it won't return params to be used in exp_cor; also it is not using handle_infinity nor cross_validation - + std_index <- qnorm((bp - 0.44)/(length(data) + 0.12)) + dim(std_index) <- c(ntime, nmemb) + # it won't return params to be used in exp_cor; also it is not using + # handle_infinity nor cross_validation + params_result <- NULL } else { - - std_index <- array(NA, c(n_sdates, nmemb)) - - if (anyNA(data) && na.rm == FALSE) { - stop('Error: Data must not contain NAs') - } - - coef = switch(distribution, - "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha','beta'))), - "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi','alpha','kappa'))), - "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu','sigma','gamma')))) - - dim_one <- length(coef) - - if (!is.null(params)) { - if (length(params)!=dim_one) { - stop(paste0('parameters array should have dimensions [', dim_one, ']')) - } - } - + std_index <- array(NA, c(ntime, nmemb)) # Select window if necessary if (!is.null(ref.start) && !is.null(ref.end)) { - data.fit <- window(data,ref.start,ref.end) + data.fit <- window(data, ref.start, ref.end) } else { data.fit <- data } if (cross_validation) { - loop_years <- n_sdates + loop_years <- ntime } else { loop_years <- 1 } - - params_result <- array(NA, dim = c(loop_years, dim_one)) + params_result <- array(NA, dim = c(loop_years, length(coef))) colnames(params_result) <- names(coef) for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) # Cumulative series (acu) if (cross_validation) { - acu <- as.vector(data.fit[,-nsd,]) + acu <- as.vector(data.fit[-nsd, ]) } else { acu <- as.vector(data.fit) } acu.sorted <- sort.default(acu, method = "quick") - # remove NAs (no need if(na.rm) because if there are NA and na.rm = F we don't get to this point) + # remove NAs (no need if(na.rm) because if there are NA and na.rm = F + # we don't get to this point) acu.sorted <- acu.sorted[!is.na(acu.sorted)] # else all acu was NA and we don't need to continue with this case if (length(acu.sorted) != 0) { - acu_sd = sd(acu.sorted) + acu_sd <- sd(acu.sorted) if (!is.na(acu_sd)) { if (acu_sd != 0) { if (distribution != "log-Logistic") { @@ -774,17 +918,17 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', acu.sorted = acu.sorted[acu.sorted > 0] } if (!is.null(params)) { - f_params = as.vector(params) + f_params <- as.vector(params) params_result[nsd, ] <- f_params } else { # else coef will be NA if (length(acu.sorted) >= 4) { # Calculate probability weighted moments based on fit with lmomco or TLMoments pwm = switch(fit, - "pp-pwm" = pwm.pp(acu.sorted,-0.35,0, nmom=3), - pwm.ub(acu.sorted, nmom=3) - # TLMoments::PWM(acu.sorted, order = 0:2) - ) + "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), + pwm.ub(acu.sorted, nmom = 3) + # TLMoments::PWM(acu.sorted, order = 0:2) + ) # Check L-moments validity lmom <- pwm2lmom(pwm) @@ -792,23 +936,21 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', # lmom fortran functions need specific inputs L1, L2, T3 # this is handled by lmomco internally with lmorph fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) - # Calculate parameters based on distribution with lmom then lmomco f_params = switch(distribution, "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), - error = function(e){ parglo(lmom)$para }), + error = function(e){parglo(lmom)$para}), "Gamma" = tryCatch(lmom::pelgam(fortran_vec), - error = function(e){ pargam(lmom)$para }), + error = function(e){pargam(lmom)$para}), "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), - error = function(e){ parpe3(lmom)$para })) - + error = function(e){parpe3(lmom)$para})) # Adjust if user chose log-Logistic and max-lik if (distribution == 'log-Logistic' && fit == 'max-lik') { f_params = parglo.maxlik(acu.sorted, f_params)$para } params_result[nsd, ] <- f_params - } # end if dor the case the L-moments are not valid (std_index will be NA) - } # end if for the case there are not enough values to estimate the parameters (std_index will be NA) + } # end for the case the L-moments are not valid (std_index will be NA) + } # end for case there are not enough values to estimate the parameters (std_index will be NA) } # end estimation of f_param # Calculate cdf based on distribution with lmom if (all(is.na(params_result[nsd,]))) { @@ -822,7 +964,7 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', "PearsonIII" = lmom::cdfpe3(data, f_params)) } - std_index_cv <- array(qnorm(cdf_res), dim = c(n_sdates,nmemb)) + std_index_cv <- array(qnorm(cdf_res), dim = c(ntime, nmemb)) # Adjust if user chose Gamma or PearsonIII - Not tested: For future development # if (distribution != 'log-Logistic') { @@ -834,9 +976,9 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', std_index <- std_index_cv } } - } # end if for the case there is no variability - } # end if for the case all NA in acu - } # next year (in case of cross_validation or all done if cross_validation == F) + } # end if for the case there is no variability + } # end if for the case all NA in acu + } # next year (in case of cross_validation or all done if cross_validation == F) if (handle_infinity) { # could also use "param_error" ?; we are giving it the min/max value of the grid point std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) @@ -846,8 +988,6 @@ spX_ftime <- function(data, distribution = 'log-Logistic', fit = 'ub-pwm', # (otherwise there will be one f_params per year; # but the output params will be read only in the case that # it is called with cross_validation FALSE) - return(list(std_index = std_index, params = params_result)) - } + return(list(std_index, params_result)) } -#------------------------------------------------------------------------------- diff --git a/R/zzz.R b/R/zzz.R index cf91639..81bd0ce 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -88,4 +88,12 @@ wind2CF <- function(wind, pc) { power <- wind2power(wind, pc) CF <- power / pc$attr$RatedPower return(CF) +} + +.KnownLonNames <- function() { + known_lon_names <- c('lon', 'lons', 'longitude', 'x', 'i', 'nav_lon') +} + +.KnownLatNames <- function() { + known_lat_names <- c('lat', 'lats', 'latitude', 'y', 'j', 'nav_lat') } \ No newline at end of file diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 0a9a6bd..7c55211 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -1,5 +1,3 @@ -context("CSIndicators::PeriodSPEI tests") - ############################################## # cube1 cube1 <- NULL @@ -97,7 +95,7 @@ test_that("1. Initial checks PeriodSPEI", { ) # time_dim expect_error( - PeriodSPEI(exp = exp1, ) + PeriodSPEI(exp = exp1, time_dim = 1) ) # leadtime_dim @@ -111,3 +109,32 @@ test_that("1. Initial checks PeriodSPEI", { ############################################## +# Test different time dimensions of exp and exp_cor +dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) +dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) + +set.seed(1) +exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) +set.seed(2) +exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) +set.seed(3) +exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) + +set.seed(1) +expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) +set.seed(2) +expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) +set.seed(3) +expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) + +dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +lat <- c(40,40.1) + +exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) + +res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates = dates, + cross_validation = TRUE, na.rm = TRUE) \ No newline at end of file -- GitLab From db9ecd3627f220ddf5d8402b12dbfe5fe30f82bf Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 12 Jun 2023 21:15:35 +0200 Subject: [PATCH 11/87] Add parameter dates_expcor; improve documentation; add warning for cross_validation; return correct values within 's2dv_cube' --- NAMESPACE | 8 + R/PeriodSPEI.R | 265 ++++++++++++++++++++++--------- man/CST_PeriodSPEI.Rd | 157 ++++++++++++++++++ man/PeriodSPEI.Rd | 160 +++++++++++++++++++ tests/testthat/test-PeriodSPEI.R | 88 +++++----- 5 files changed, 559 insertions(+), 119 deletions(-) create mode 100644 man/CST_PeriodSPEI.Rd create mode 100644 man/PeriodSPEI.Rd diff --git a/NAMESPACE b/NAMESPACE index d80accb..61b6b92 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(CST_AccumulationExceedingThreshold) export(CST_MergeRefToExp) export(CST_PeriodAccumulation) export(CST_PeriodMean) +export(CST_PeriodSPEI) export(CST_QThreshold) export(CST_SelectPeriodOnData) export(CST_Threshold) @@ -17,6 +18,7 @@ export(CST_WindPowerDensity) export(MergeRefToExp) export(PeriodAccumulation) export(PeriodMean) +export(PeriodSPEI) export(QThreshold) export(SelectPeriodOnData) export(SelectPeriodOnDates) @@ -25,7 +27,13 @@ export(TotalSpellTimeExceedingThreshold) export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) +import(ClimProjDiags) +import(SPEI) +import(TLMoments) +import(lmomco) +import(lubridate) import(multiApply) +import(zoo) importFrom(stats,approxfun) importFrom(stats,ecdf) importFrom(stats,quantile) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 552c0d2..284c174 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -73,30 +73,53 @@ #'@param ncores An integer value indicating the number of cores to use in #' parallel computation. #' +#'@return A list with elements: +#'\itemize{ +#' \item{'exp', if 'standarization' is TRUE an 's2dv_cube' conaining the 'SPEI' +#' in element data from 'exp' array with the same dimensions as 'exp'. +#' If it is FALSE, it is an array with the accumulated values of PET +#' minus 'prlr' data.} +#' \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not +#' NULL. It is an 's2dv_cube' with the SPEI data from 'exp_cor' in +#' element 'data'. If 'standarization' is FALSE, only the accumulated +#' values of PET minus 'prlr' is returned.} +#' \item{'params', returned if 'standarization' is TRUE, it contains the +#' parameters used for the standarization of 'exp' that are used for +#' computing the 'SPEI' for 'exp_cor'.} +#' } +#' #'@examples #'# Test random data #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, #' latitude = 2, longitude = 1, ensemble = 25) -#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, +#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, #' latitude = 2, longitude = 1, ensemble = 15) -#'exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) -#'exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) -#'exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) -#' -#'expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) -#'expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) -#'expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) -#' -#'dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), -#' paste0(2010:2015, "-10-16"))) +#' +#'dates <- as.POSIXct(c(paste0(2010:2015, "-08-16"), +#' paste0(2010:2015, "-09-15"), +#' paste0(2010:2015, "-10-16")), 'UTC') #'dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -#' +#' #'lat <- c(40,40.1) -#' +#' +#'exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) +#' +#'expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +#'expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +#'expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) +#' #'exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) #'exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, #' 'prlr' = expcor_prlr) -#'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates = dates) +#' +#'exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), +#' Dates = dates) +#'exp_cor <- lapply(exp_cor, CSTools::s2dv_cube, coords = list(latitude = lat), +#' Dates = dates) +#' +#'res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) #' #'@import multiApply #'@import ClimProjDiags @@ -128,18 +151,32 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, stop("Parameter 'exp_cor' must be a list of 's2dv_cube' class.") } } - + # latitude if (!any(names(exp[[1]]$coords) %in% .KnownLatNames())) { stop("Spatial coordinate names of parameter 'exp' do not match any ", "of the names accepted by the package.") } + # Dates + dates_exp <- exp[[1]]$attrs$Dates + if (is.null(exp[[1]]$attrs$Dates)) { + stop("Element 'Dates' is not found in 'exp$attrs' list.") + } + + if (!is.null(exp_cor)) { + if (is.null(exp_cor[[1]]$attrs$Dates)) { + stop("Element 'Dates' is not found in 'exp_cor$attrs'.") + } + } - lat_name <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames())]] + lat_dim <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames())]] + res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), - dates = exp[[1]]$attrs$Dates, - lat = exp[[1]]$coords[[lat_name]], - exp_cor = lapply(exp_cor, function(x) x$data), + dates_exp = exp[[1]]$attrs$Dates, + lat = exp[[1]]$coords[[lat_dim]], + exp_cor = if (is.null(exp_cor)) {NULL} else { + lapply(exp_cor, function(x) x$data)}, + dates_expcor = exp_cor[[1]]$attrs$Dates, pet = pet, time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, lat_dim = lat_dim, accum = accum, ref_period = ref_period, params = params, @@ -150,6 +187,22 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, param_error = param_error, handle_infinity = handle_infinity, na.rm = na.rm, ncores = ncores) + if (is.null(exp_cor)) { + exp$data <- res[[1]] + if (standardization) { + return(list(exp = exp, params = res[[2]])) + } else { + return(exp) + } + } else { + exp$data <- res[[1]] + exp_cor$data <- res[[2]] + if (standardization) { + return(list(exp = exp, exp_cor = exp_cor, params = res[[3]])) + } else { + return(list(exp = exp, exp_cor = exp_cor)) + } + } return(res) } @@ -175,9 +228,14 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #' Variable 'prlr' is always needed. The units for temperature variables #' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for #' precipitation ('prlr') need to be in mm/month. +#'@param dates_exp An array of temporal dimensions containing the Dates of +#' 'exp'. It must be of class 'Date' or 'POSIXct'. +#'@param lat A numeric vector containing the latitude values of 'exp'. #'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each #' variable in which the quantile PeriodSPEI should be applied. If it is not #' specified, the PeriodSPEI is calculated from object 'exp'. +#'@param dates_expcor An array of temporal dimensions containing the Dates of +#' 'exp_cor'. It must be of class 'Date' or 'POSIXct'. #'@param pet A multidimensional array containing the Potential #' EvapoTranspiration data. If it is NULL it is calculated using pet_method. It #' is NULL by default. @@ -229,19 +287,33 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #'@param ncores An integer value indicating the number of cores to use in #' parallel computation. #' +#'@return A list with elements: +#'\itemize{ +#' \item{'exp', if 'standarization' is TRUE an array conaining SPEI data from +#' 'exp' array with the same dimensions as 'exp'. If it is FALSE, it +#' is an array with the accumulated values of PET minus 'prlr' data.} +#' \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not +#' NULL. It is an array with the SPEI data from 'exp_cor'. If +#' 'standarization' is FALSE, only the accumulated values of PET minus +#' 'prlr' is returned.} +#' \item{'params', returned if 'standarization' is TRUE, it contains the +#' parameters used for the standarization of 'exp' that are used for +#' computing the 'SPEI' for 'exp_cor'.} +#'} +#' #'@examples #'# Test random data #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, #' latitude = 2, longitude = 1, ensemble = 25) -#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, +#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, #' latitude = 2, longitude = 1, ensemble = 15) -#'exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) -#'exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) -#'exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) +#'exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) #' -#'expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) -#'expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) -#'expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) +#'expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +#'expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +#'expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) #' #'dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), #' paste0(2010:2015, "-10-16"))) @@ -262,7 +334,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #'@import lmomco #'@import lubridate #'@export -PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, +PeriodSPEI <- function(exp, dates_exp, lat, + exp_cor = NULL, dates_expcor = NULL, pet = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, ref_period = NULL, params = NULL, @@ -305,14 +378,40 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, if (!all(names(exp_cor) %in% names(exp))) { stop("Parameter 'exp_cor' needs to have the same variable names as 'exp'.") } - dims <- lapply(exp_cor, function(x) dim(x)) - first_dims <- dims[[1]] - all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) + dimscor <- lapply(exp_cor, function(x) dim(x)) + first_dims <- dimscor[[1]] + all_equal <- all(sapply(dimscor[-1], function(x) identical(first_dims, x))) if (!all_equal) { stop("Parameter 'exp_cor' variables needs to have the same dimension names.") } } + # dates + if (!(is.Date(dates_exp)) & !(is.POSIXct(dates_exp))) { + stop("Parameter 'dates_exp' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!is.null(exp_cor)) { + if (!(is.Date(dates_expcor)) & !(is.POSIXct(dates_expcor))) { + stop("Element 'Dates' in 'exp_cor' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + } + # lat + if (!is.numeric(lat)) { + stop("Parameter 'lat' must be numeric.") + } + if (any(sapply(dims, FUN = function(x) x[lat_dim] != length(lat)))) { + stop("Parameter 'lat' needs to have the same length of latitudinal", + "dimension of all the variables arrays in 'exp'.") + } + if (!is.null(exp_cor)) { + if (any(sapply(dimscor, FUN = function(x) x[lat_dim] != length(lat)))) { + stop("Parameter 'lat' needs to have the same length of latitudinal", + "dimension of all the variables arrays in 'exp'.") + } + } + # Variable checks if (is.null(pet)) { ## exp (2) @@ -424,17 +523,32 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, stop(paste0("Cannot compute accumulation of ", accum, " months because ", "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) } - ## start - - ## end ## standardization + if (!is.logical(standardization)) { + stop("Parameter 'standardization' must be a logical value.") + } ## param_error + if (!is.numeric(param_error)) { + stop("Parameter 'param_error' must be a numeric value.") + } ## handle_infinity + if (!is.logical(handle_infinity)) { + stop("Parameter 'handle_infinity' must be a logical value.") + } ## cross_validation + if (!is.logical(cross_validation)) { + stop("Parameter 'cross_validation' must be a logical value.") + } + if (cross_validation) { + warning("Detected 'cross_validation' = TRUE. This functionality ", + "is being developed, sorry for the inconvenience. It will ", + "be set to FALSE.") + cross_validation <- FALSE + } ## method if (!(method %in% c('parametric', 'non-parametric'))) { @@ -459,18 +573,23 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, # Data preparation # complete dates - ini_date <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep= '-')) - end_date <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-')) - dates_complete_daily <- as.Date(ini_date:end_date) - - dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) - dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] - dates_monthly <- array(0, dim = length(dates_complete_monthly)) - for (dd in 1:length(dates)) { - ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), - lubridate::month(dates[dd]), - 01, sep = '-'))) - dates_monthly[ii] <- 1 + dates_monthly <- NULL + k = 0 + for (dates in .return2list(dates_exp, dates_expcor)) { + k = k + 1 + ini_date <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep= '-')) + end_date <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-')) + dates_complete_daily <- as.Date(ini_date:end_date) + + dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) + dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] + dates_monthly[[k]] <- array(0, dim = length(dates_complete_monthly)) + for (dd in 1:length(dates)) { + ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), + lubridate::month(dates[dd]), + 01, sep = '-'))) + dates_monthly[[k]][ii] <- 1 + } } # Compute PeriodSPEI @@ -482,7 +601,7 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, k = k + 1 # Evapotranspiration estimation (unless pet is already provided) if (is.null(pet) | computed_pet) { - pet <- .Evapotranspiration(data = data, dates_monthly = dates_monthly, + pet <- .Evapotranspiration(data = data, dates_monthly = dates_monthly[[k]], lat = lat, pet_method = pet_method[k], time_dim = time_dim, leadtime_dim = leadtime_dim, lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) @@ -492,10 +611,10 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, # Accumulation diff_p_pet <- data$prlr - pet data_accum <- .Accumulation(data = diff_p_pet, - dates_monthly = dates_monthly, accum = accum, + dates_monthly = dates_monthly[[k]], accum = accum, time_dim = time_dim, leadtime_dim = leadtime_dim, ncores = ncores) - # Standardization: + # Standardization if (standardization) { spei_dat <- .Standardization(data = data_accum, params = params, accum = accum, time_dim = time_dim, @@ -508,10 +627,18 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, method = method, distribution = distribution, fit = fit, ncores = ncores) params <- spei_dat$params + + pos <- match(names(dim(data[[1]])), names(dim(spei_dat[[1]]))) + spei_dat[[1]] <- aperm(spei_dat[[1]], pos) + + spei_res[[k]] <- spei_dat[[1]] } else { - spei_dat <- data_accum + + pos <- match(names(dim(data[[1]])), names(dim(data_accum))) + data_accum <- aperm(data_accum, pos) + + spei_res[[k]] <- data_accum } - spei_res[[k]] <- spei_dat[[1]] } if (standardization) { @@ -572,11 +699,6 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, # prepare data target_dims_data <- lapply(data[varnames], function(x) rep(c(leadtime_dim, time_dim), 1)) - # file <- tempfile() - # sink(file) - # print(varnames) - # print(is.na(data['tasmax'])) - # print(is.na(data['tasmin'])) pet <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), target_dims = c(list(lat_mask = 'dat'), target_dims_data), fun = .evapotranspiration, @@ -584,9 +706,6 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, leadtime_dim = leadtime_dim, time_dim = time_dim, output_dims = c(leadtime_dim, time_dim), ncores = ncores)$output1 - # sink() - # captured_message <- readLines(file) - # print(unique(captured_message)) # reorder dims in pet_estimated pos <- match(names(dim(data[[1]])), names(dim(pet))) pet <- aperm(pet, pos) @@ -607,7 +726,7 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, # of the considered period # (starting in January of the first year) so that the solar radiation # estimation is computed in each case for the correct month - any(is.na(data2)) + if (!is.null(data2)) { data_tmp <- as.vector(data2) data2 <- array(0, dim = length(dates_monthly)) @@ -646,11 +765,6 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, rm(data_tmp) } if (pet_method == 'hargreaves') { - # NOTE EVA: if NA.RM is FALSE this gives error - # print('hi') - # print(any(is.na(data3))) - # print('he') - # print(any(is.na(data2))) pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, na.rm = na.rm, verbose = FALSE) # line to return the vector to the size of the actual original data @@ -832,19 +946,18 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, for (ff in 1:nleadtime) { data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, indices = ff, drop = 'selected') + params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} spei_data <- .std(data = data_subset, coef = coef, - ntime = ntime, nmemb = nmemb, - method = method, - distribution = distribution, - fit = fit, na.rm = na.rm, - ref.start = ref.start, - ref.end = ref.end, - params = params_tmp, - handle_infinity = handle_infinity, - cross_validation = cross_validation) + ntime = ntime, nmemb = nmemb, + method = method, distribution = distribution, + fit = fit, na.rm = na.rm, + ref.start = ref.start, ref.end = ref.end, + params = params_tmp, + handle_infinity = handle_infinity, + cross_validation = cross_validation) spei_mod[ff, , ] <- spei_data[[1]] params_ff <- spei_data[[2]] # lengthen dimension coef of params_ff in case it doesn't match the @@ -867,7 +980,6 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, # data: [time_dim, memb_dim] # params: NULL or [(ntime), coef] - if (method == 'non-parametric') { bp <- matrix(0, length(data), 1) for (i in 1:length(data)) { @@ -903,12 +1015,13 @@ PeriodSPEI <- function(exp, dates, lat, exp_cor = NULL, pet = NULL, } else { acu <- as.vector(data.fit) } - + acu.sorted <- sort.default(acu, method = "quick") # remove NAs (no need if(na.rm) because if there are NA and na.rm = F # we don't get to this point) acu.sorted <- acu.sorted[!is.na(acu.sorted)] - # else all acu was NA and we don't need to continue with this case + # else all acu was NA and we don't need to continue with this case + if (length(acu.sorted) != 0) { acu_sd <- sd(acu.sorted) if (!is.na(acu_sd)) { diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd new file mode 100644 index 0000000..2bc5c47 --- /dev/null +++ b/man/CST_PeriodSPEI.Rd @@ -0,0 +1,157 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodSPEI.R +\name{CST_PeriodSPEI} +\alias{CST_PeriodSPEI} +\title{Compute the Standardised Precipitation-Evapotranspiration Index} +\usage{ +CST_PeriodSPEI( + exp, + exp_cor = NULL, + pet = NULL, + time_dim = "syear", + leadtime_dim = "time", + memb_dim = "ensemble", + lat_dim = "latitude", + accum = 1, + ref_period = NULL, + params = NULL, + standardization = TRUE, + cross_validation = FALSE, + pet_method = "hargreaves", + method = "parametric", + distribution = "log-Logistic", + fit = "ub-pwm", + param_error = -9999, + handle_infinity = FALSE, + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named list with the needed \code{s2dv_cube} objects containing +the seasonal forecast experiment in the data element for each variable. +Specific variables are needed for each method used in computing the +Potential Evapotranspiration. See parameter 'pet_method'. The accepted +variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and +'hargreaves_modified' and 'tas', required for method 'thornthwaite'. +Variable 'prlr' is always needed. The units for temperature variables +('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for +precipitation ('prlr') need to be in mm/month.} + +\item{exp_cor}{A named list with the needed \code{s2dv_cube} objects for each +variable in which the quantile PeriodSPEI should be applied. If it is not +specified, the PeriodSPEI is calculated from object 'exp'.} + +\item{pet}{A multidimensional array containing the Potential +EvapoTranspiration data. If it is NULL it is calculated using pet_method. It +is NULL by default.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{memb_dim}{A character string indicating the name of the dimension in +which the ensemble members are stored. When set it to NULL, threshold is +computed for individual members.} + +\item{lat_dim}{A character string indicating the name of the latitudinal +dimension. By default it is set by 'latitude'.} + +\item{accum}{An integer value indicating the number of months for the +accumulation for each variable.} + +\item{ref_period}{A list with two numeric values with the starting and end +points of the reference period used for computing the index. The default +value is NULL indicating that the first and end values in data will be +used as starting and end points.} + +\item{params}{A multidimensional array with named dimensions for computing the +SPEI. This option overrides computation of fitting parameters. It needs +to be of same leadtime and time dimensions of exp and a dimension named +'coef' with the length of the coefficients needed for the used distribution +(for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or +'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime +dimension must be of length 1.} + +\item{standardization}{A logical value indicating wether the standardization +is computed.} + +\item{cross_validation}{A logical value indicating if cross validation is +done (TRUE), or not (FALSE). It is FALSE by default.} + +\item{pet_method}{A character string indicating the method used to compute +the potential evapotranspiration. The accepted methods are: +'hargreaves' and 'hargreaves_modified', that require the data to have +variables tasmin and tasmax; and 'thornthwaite', that requires variable +'tas'.} + +\item{method}{A character string indicating the standardization method used. +If can be: 'parametric' or 'non-parametric'.} + +\item{distribution}{A character string indicating the name of the distribution +function to be used for computing the SPEI. The accepted names are: +'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by +default.} + +\item{fit}{A character string indicating the name of the method used for +computing the distribution function parameters The accepteed names are: +'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default.} + +\item{param_error}{A numeric value with the error accepted.} + +\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) +or not (FALSE).} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\description{ +Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) +that is a multiscalar drought index based on climatic data. It can be used for +determining the onset, duration and magnitude of drought conditions with +respect to normal conditions in a variety of natural and managed systems such +as crops, ecosystems, rivers, water resources, etc. The SPI is calculated +using monthly (or weekly) precipitation as the input data. The SPEI uses the +monthly (or weekly) difference between precipitation and pet. This represents +a simple climatic water balance which is calculated at different time scales +to obtain the SPEI. +} +\examples{ +# Test random data +dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, + latitude = 2, longitude = 1, ensemble = 25) +dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, + latitude = 2, longitude = 1, ensemble = 15) + +dates <- as.POSIXct(c(paste0(2010:2015, "-08-16"), + paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16")), 'UTC') +dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +lat <- c(40,40.1) + +exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) + +expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) + +exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, + 'prlr' = expcor_prlr) + +exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), + Dates = dates) +exp_cor <- lapply(exp_cor, CSTools::s2dv_cube, coords = list(latitude = lat), + Dates = dates) + +res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) + +} diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd new file mode 100644 index 0000000..1168122 --- /dev/null +++ b/man/PeriodSPEI.Rd @@ -0,0 +1,160 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodSPEI.R +\name{PeriodSPEI} +\alias{PeriodSPEI} +\title{Compute the Standardised Precipitation-Evapotranspiration Index} +\usage{ +PeriodSPEI( + exp, + dates_exp, + lat, + exp_cor = NULL, + dates_expcor = NULL, + pet = NULL, + time_dim = "syear", + leadtime_dim = "time", + memb_dim = "ensemble", + lat_dim = "latitude", + accum = 1, + ref_period = NULL, + params = NULL, + standardization = TRUE, + cross_validation = FALSE, + pet_method = "hargreaves", + method = "parametric", + distribution = "log-Logistic", + fit = "ub-pwm", + param_error = -9999, + handle_infinity = FALSE, + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named list with the needed \code{s2dv_cube} objects containing +the seasonal forecast experiment in the data element for each variable. +Specific variables are needed for each method used in computing the +Potential Evapotranspiration. See parameter 'pet_method'. The accepted +variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and +'hargreaves_modified' and 'tas', required for method 'thornthwaite'. +Variable 'prlr' is always needed. The units for temperature variables +('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for +precipitation ('prlr') need to be in mm/month.} + +\item{dates_exp}{An array of temporal dimensions containing the Dates of +'exp'. It must be of class 'Date' or 'POSIXct'.} + +\item{lat}{A numeric vector containing the latitude values of 'exp'.} + +\item{exp_cor}{A named list with the needed \code{s2dv_cube} objects for each +variable in which the quantile PeriodSPEI should be applied. If it is not +specified, the PeriodSPEI is calculated from object 'exp'.} + +\item{dates_expcor}{An array of temporal dimensions containing the Dates of +'exp_cor'. It must be of class 'Date' or 'POSIXct'.} + +\item{pet}{A multidimensional array containing the Potential +EvapoTranspiration data. If it is NULL it is calculated using pet_method. It +is NULL by default.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{memb_dim}{A character string indicating the name of the dimension in +which the ensemble members are stored. When set it to NULL, threshold is +computed for individual members.} + +\item{lat_dim}{A character string indicating the name of the latitudinal +dimension. By default it is set by 'latitude'.} + +\item{accum}{An integer value indicating the number of months for the +accumulation for each variable.} + +\item{ref_period}{A list with two numeric values with the starting and end +points of the reference period used for computing the index. The default +value is NULL indicating that the first and end values in data will be +used as starting and end points.} + +\item{params}{A multidimensional array with named dimensions for computing the +SPEI. This option overrides computation of fitting parameters. It needs +to be of same leadtime and time dimensions of exp and a dimension named +'coef' with the length of the coefficients needed for the used distribution +(for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or +'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime +dimension must be of length 1.} + +\item{standardization}{A logical value indicating wether the standardization +is computed.} + +\item{cross_validation}{A logical value indicating if cross validation is +done (TRUE), or not (FALSE). It is FALSE by default.} + +\item{pet_method}{A character string indicating the method used to compute +the potential evapotranspiration. The accepted methods are: +'hargreaves' and 'hargreaves_modified', that require the data to have +variables tasmin and tasmax; and 'thornthwaite', that requires variable +'tas'.} + +\item{method}{A character string indicating the standardization method used. +If can be: 'parametric' or 'non-parametric'.} + +\item{distribution}{A character string indicating the name of the distribution +function to be used for computing the SPEI. The accepted names are: +'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by +default.} + +\item{fit}{A character string indicating the name of the method used for +computing the distribution function parameters The accepteed names are: +'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default.} + +\item{param_error}{A numeric value with the error accepted.} + +\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) +or not (FALSE).} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\description{ +Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) +that is a multiscalar drought index based on climatic data. It can be used for +determining the onset, duration and magnitude of drought conditions with +respect to normal conditions in a variety of natural and managed systems such +as crops, ecosystems, rivers, water resources, etc. The SPI is calculated +using monthly (or weekly) precipitation as the input data. The SPEI uses the +monthly (or weekly) difference between precipitation and pet. This represents +a simple climatic water balance which is calculated at different time scales +to obtain the SPEI. +} +\examples{ +# Test random data +dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, + latitude = 2, longitude = 1, ensemble = 25) +dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, + latitude = 2, longitude = 1, ensemble = 15) +exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) + +expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) + +dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +lat <- c(40,40.1) + +exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, + 'prlr' = expcor_prlr) +res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates = dates) + +} diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 7c55211..e009ad0 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -9,30 +9,34 @@ dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) set.seed(1) -exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) set.seed(2) -exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) set.seed(3) -exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) set.seed(1) -expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) +expcor_tasmax <- array(rnorm(60, 29.03, 5.67), dim = dimscor) set.seed(2) -expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) +expcor_tasmin <- array(rnorm(60, 15.70, 4.40), dim = dimscor) set.seed(3) -expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) +expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) -dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), +dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16"))) -dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +dates_expcor <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), + paste0(2020, "-10-16"))) +dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) lat <- c(40,40.1) exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) -res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates = dates) -source("/esarchive/scratch/erifarov/git/csindicators/R/PeriodSPEI.R") +res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor) ############################################## @@ -89,52 +93,50 @@ test_that("1. Initial checks PeriodSPEI", { ) # exp (2) expect_warning( - PeriodSPEI(exp = exp1, pet_method = '1', dates = dates, lat = lat), + PeriodSPEI(exp = exp1, pet_method = '1', dates_exp = dates_exp, lat = lat), paste0("Parameter 'pet_method' needs to be 'hargreaves' or ", "'hargreaves_modified'. It is set to 'hargreaves'.") ) # time_dim expect_error( - PeriodSPEI(exp = exp1, time_dim = 1) + PeriodSPEI(exp = exp1, time_dim = 1, dates_exp = dates_exp, lat = lat) ) # leadtime_dim - + expect_error( + PeriodSPEI(exp = exp1, time_dim = 1, dates_exp = dates_exp, lat = lat) + ) # memb_dim - + expect_error( + PeriodSPEI(exp = exp1, memb_dim = 1, dates_exp = dates_exp, lat = lat) + ) # lat_dim - + expect_error( + PeriodSPEI(exp = exp1, lat_dim = 1, dates_exp = dates_exp, lat = lat) + ) # accum + expect_error( + PeriodSPEI(exp = exp1, accum = 10, dates_exp = dates_exp, lat = lat) + ) }) ############################################## -# Test different time dimensions of exp and exp_cor -dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) -dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) - -set.seed(1) -exp_tasmax <- array(rnorm(100, 27.73, 5.26), dim = dims) -set.seed(2) -exp_tasmin <- array(rnorm(100, 14.83, 3.86), dim = dims) -set.seed(3) -exp_prlr <- array(rnorm(100, 21.19, 25.64), dim = dims) - -set.seed(1) -expcor_tasmax <- array(rnorm(100, 29.03, 5.67), dim = dimscor) -set.seed(2) -expcor_tasmin <- array(rnorm(100, 15.70, 4.40), dim = dimscor) -set.seed(3) -expcor_prlr <- array(rnorm(100, 15.62, 21.38), dim = dimscor) - -dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) -dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) - -lat <- c(40,40.1) - -exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) -exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) +test_that("2. Output checks", { + res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor) + expect_equal( + length(res), + 3 + ) + expect_equal( + dim(res[[1]]), + dims + ) + expect_equal( + dim(res[[3]])[which(!names(dim(res[[3]])) %in% c('coef', 'syear'))], + dims[which(!names(dims) %in% c('syear', 'ensemble'))] + ) +}) -res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates = dates, - cross_validation = TRUE, na.rm = TRUE) \ No newline at end of file +############################################## \ No newline at end of file -- GitLab From 9243ba3c9cb649c4b2cac55cd769db0064c60d95 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 13 Jun 2023 17:41:38 +0200 Subject: [PATCH 12/87] Separate pet parameter to pet_exp and pet_expcor; add initial checks; add few tests --- R/PeriodSPEI.R | 247 +++++++++++++++++++++---------- man/CST_PeriodSPEI.Rd | 57 +++++-- man/PeriodSPEI.Rd | 50 +++++-- tests/testthat/test-PeriodSPEI.R | 112 ++++++++++++-- 4 files changed, 345 insertions(+), 121 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 284c174..39e6daf 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -22,9 +22,6 @@ #'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each #' variable in which the quantile PeriodSPEI should be applied. If it is not #' specified, the PeriodSPEI is calculated from object 'exp'. -#'@param pet A multidimensional array containing the Potential -#' EvapoTranspiration data. If it is NULL it is calculated using pet_method. It -#' is NULL by default. #'@param time_dim A character string indicating the name of the temporal #' dimension. By default, it is set to 'syear'. #'@param leadtime_dim A character string indicating the name of the temporal @@ -42,11 +39,19 @@ #' used as starting and end points. #'@param params A multidimensional array with named dimensions for computing the #' SPEI. This option overrides computation of fitting parameters. It needs -#' to be of same leadtime and time dimensions of exp and a dimension named +#' to be of same leadtime and time dimensions of 'exp' and a dimension named #' 'coef' with the length of the coefficients needed for the used distribution #' (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or #' 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime #' dimension must be of length 1. +#'@param pet_exp A multidimensional array containing the Potential +#' EvapoTranspiration data of 'exp'. It must have the same dimensions of the +#' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +#' variables with specified 'pet_method'. It is NULL by default. +#'@param pet_expcor A multidimensional array containing the Potential +#' EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of +#' the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +#' provided variables with specified 'pet_method'. It is NULL by default. #'@param standardization A logical value indicating wether the standardization #' is computed. #'@param cross_validation A logical value indicating if cross validation is @@ -57,7 +62,8 @@ #' variables tasmin and tasmax; and 'thornthwaite', that requires variable #' 'tas'. #'@param method A character string indicating the standardization method used. -#' If can be: 'parametric' or 'non-parametric'. +#' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +#' default. #'@param distribution A character string indicating the name of the distribution #' function to be used for computing the SPEI. The accepted names are: #' 'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by @@ -89,17 +95,18 @@ #' } #' #'@examples -#'# Test random data #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, #' latitude = 2, longitude = 1, ensemble = 25) -#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, +#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, #' latitude = 2, longitude = 1, ensemble = 15) #' -#'dates <- as.POSIXct(c(paste0(2010:2015, "-08-16"), -#' paste0(2010:2015, "-09-15"), -#' paste0(2010:2015, "-10-16")), 'UTC') -#'dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -#' +#'dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), +#' paste0(2010:2015, "-09-15"), +#' paste0(2010:2015, "-10-16")), 'UTC') +#'dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +#'dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), +#' paste0(2020, "-10-16")), 'UTC') +#'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) #'lat <- c(40,40.1) #' #'exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) @@ -115,9 +122,9 @@ #' 'prlr' = expcor_prlr) #' #'exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), -#' Dates = dates) +#' Dates = dates_exp) #'exp_cor <- lapply(exp_cor, CSTools::s2dv_cube, coords = list(latitude = lat), -#' Dates = dates) +#' Dates = dates_expcor) #' #'res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) #' @@ -129,10 +136,11 @@ #'@import lmomco #'@import lubridate #'@export -CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, +CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, ref_period = NULL, params = NULL, + pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, cross_validation = FALSE, pet_method = 'hargreaves', method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', @@ -158,18 +166,21 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, } # Dates dates_exp <- exp[[1]]$attrs$Dates - if (is.null(exp[[1]]$attrs$Dates)) { - stop("Element 'Dates' is not found in 'exp$attrs' list.") + if (!'Dates' %in% names(exp[[1]]$attrs)) { + stop("Element 'Dates' is not found in 'attrs' list of 'exp'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") } if (!is.null(exp_cor)) { - if (is.null(exp_cor[[1]]$attrs$Dates)) { - stop("Element 'Dates' is not found in 'exp_cor$attrs'.") + if (!'Dates' %in% names(exp_cor[[1]]$attrs)) { + stop("Element 'Dates' is not found in 'attrs' list of 'exp_cor'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") } } lat_dim <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames())]] - res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), dates_exp = exp[[1]]$attrs$Dates, @@ -177,9 +188,10 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, exp_cor = if (is.null(exp_cor)) {NULL} else { lapply(exp_cor, function(x) x$data)}, dates_expcor = exp_cor[[1]]$attrs$Dates, - pet = pet, time_dim = time_dim, leadtime_dim = leadtime_dim, + time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, lat_dim = lat_dim, accum = accum, ref_period = ref_period, params = params, + pet_exp = pet_exp, pet_expcor = pet_expcor, standardization = standardization, cross_validation = cross_validation, pet_method = pet_method, method = method, @@ -236,9 +248,6 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #' specified, the PeriodSPEI is calculated from object 'exp'. #'@param dates_expcor An array of temporal dimensions containing the Dates of #' 'exp_cor'. It must be of class 'Date' or 'POSIXct'. -#'@param pet A multidimensional array containing the Potential -#' EvapoTranspiration data. If it is NULL it is calculated using pet_method. It -#' is NULL by default. #'@param time_dim A character string indicating the name of the temporal #' dimension. By default, it is set to 'syear'. #'@param leadtime_dim A character string indicating the name of the temporal @@ -261,6 +270,14 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #' (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or #' 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime #' dimension must be of length 1. +#'@param pet_exp A multidimensional array containing the Potential +#' EvapoTranspiration data of 'exp'. It must have the same dimensions of the +#' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +#' variables with specified 'pet_method'. It is NULL by default. +#'@param pet_expcor A multidimensional array containing the Potential +#' EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of +#' the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +#' provided variables with specified 'pet_method'. It is NULL by default. #'@param standardization A logical value indicating wether the standardization #' is computed. #'@param cross_validation A logical value indicating if cross validation is @@ -302,10 +319,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #'} #' #'@examples -#'# Test random data #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, #' latitude = 2, longitude = 1, ensemble = 25) -#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, +#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, #' latitude = 2, longitude = 1, ensemble = 15) #'exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) #'exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) @@ -315,16 +331,21 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #'expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) #'expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) #' -#'dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), -#' paste0(2010:2015, "-10-16"))) -#'dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -#' +#'dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), +#' paste0(2010:2015, "-09-15"), +#' paste0(2010:2015, "-10-16"))) +#'dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +#'dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), +#' paste0(2020, "-09-15"), +#' paste0(2020, "-10-16")), 'UTC') +#'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) #'lat <- c(40,40.1) #' #'exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) #'exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, #' 'prlr' = expcor_prlr) -#'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates = dates) +#'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, +#' dates_exp = dates_exp, dates_expcor = dates_expcor) #' #'@import multiApply #'@import ClimProjDiags @@ -335,10 +356,11 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet = NULL, #'@import lubridate #'@export PeriodSPEI <- function(exp, dates_exp, lat, - exp_cor = NULL, dates_expcor = NULL, pet = NULL, + exp_cor = NULL, dates_expcor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, ref_period = NULL, params = NULL, + pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, cross_validation = FALSE, pet_method = 'hargreaves', method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', @@ -375,28 +397,14 @@ PeriodSPEI <- function(exp, dates_exp, lat, if (any(sapply(exp_cor, function(x) is.null(names(dim(x)))))) { stop("Parameter 'exp_cor' needs to be a list of arrays with dimension names.") } - if (!all(names(exp_cor) %in% names(exp))) { - stop("Parameter 'exp_cor' needs to have the same variable names as 'exp'.") - } dimscor <- lapply(exp_cor, function(x) dim(x)) - first_dims <- dimscor[[1]] - all_equal <- all(sapply(dimscor[-1], function(x) identical(first_dims, x))) + first_dimscor <- dimscor[[1]] + all_equal <- all(sapply(dimscor[-1], function(x) identical(first_dimscor, x))) if (!all_equal) { stop("Parameter 'exp_cor' variables needs to have the same dimension names.") } } - # dates - if (!(is.Date(dates_exp)) & !(is.POSIXct(dates_exp))) { - stop("Parameter 'dates_exp' is not of the correct class, ", - "only 'Date' and 'POSIXct' classes are accepted.") - } - if (!is.null(exp_cor)) { - if (!(is.Date(dates_expcor)) & !(is.POSIXct(dates_expcor))) { - stop("Element 'Dates' in 'exp_cor' is not of the correct class, ", - "only 'Date' and 'POSIXct' classes are accepted.") - } - } # lat if (!is.numeric(lat)) { stop("Parameter 'lat' must be numeric.") @@ -413,8 +421,9 @@ PeriodSPEI <- function(exp, dates_exp, lat, } # Variable checks - if (is.null(pet)) { - ## exp (2) + ## exp (2) + pet <- vector("list", 2) + if (is.null(pet_exp)) { if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' if (!(pet_method[1] %in% c('hargreaves_modified', 'hargreaves'))) { @@ -429,12 +438,30 @@ PeriodSPEI <- function(exp, dates_exp, lat, pet_method[1] <- 'thornthwaite' } } else { - stop("Parameter 'exp' needs to be a named list with accepted variable names.", - "See documentation.") + stop("Parameter 'exp' needs to be a named list with accepted ", + "variable names if 'pet_exp' is not provided. See documentation.") } - - ## exp_cor (2) - if (!is.null(exp_cor)) { + } else { + if (!('prlr' %in% names(exp))) { + stop("Variable 'prlr' is not included in 'exp'.") + } + if (length(dim(exp[['prlr']])) != length(dim(pet_exp))) { + stop("Parameter 'pet_exp' must have the same length of all the ", + "dimensions as variable 'prlr' in 'exp'.") + } + if (!all(dim(exp[['prlr']]) %in% dim(pet_exp))) { + stop("Parameter 'pet_exp' must have the same length of all the ", + "dimensions as variable 'prlr' in 'exp'.") + } + if (any(names(dim(exp[['prlr']])) != names(dim(pet_exp)))) { + pos <- match(names(dim(exp[['prlr']])), names(dim(pet_exp))) + pet_exp <- aperm(pet_exp, pos) + } + pet[[1]] <- pet_exp + } + ## exp_cor (2) + if (!is.null(exp_cor)) { + if (is.null(pet_expcor)) { if (length(exp_cor) < 1) { exp_cor <- NULL } else { @@ -456,17 +483,28 @@ PeriodSPEI <- function(exp, dates_exp, lat, pet_method[2] <- 'thornthwaite' } } else { - stop("Parameter 'exp_cor' needs to be a list with the needed variables.") + stop("Parameter 'exp_cor' needs to be a list with the needed ", + "variables if 'pet_expcor' is not provided.") } - } - } else { - if (!('prlr' %in% names(exp))) { - stop("Variable 'prlr' is not included in 'exp'.") - } - if (!is.null(exp_cor)) { - if (!('prlr' %in% names(exp_cor))) { - stop("Variable 'prlr' is not included in 'exp_cor'.") + } else { + if (!is.null(exp_cor)) { + if (!('prlr' %in% names(exp_cor))) { + stop("Variable 'prlr' is not included in 'exp_cor'.") + } + if (length(dim(exp_cor[['prlr']])) != length(dim(pet_expcor))) { + stop("Parameter 'pet_expcor' must have the same length of all the ", + "dimensions as variable 'prlr' in 'exp_cor'.") + } + if (!all(dim(exp_cor[['prlr']]) %in% dim(pet_expcor))) { + stop("Parameter 'pet_expcor' must have the same length of all the ", + "dimensions as variable 'prlr' in 'exp_cor'.") + } + if (any(names(dim(exp_cor[['prlr']])) != names(dim(pet_expcor)))) { + pos <- match(names(dim(exp_cor[['prlr']])), names(dim(pet_expcor))) + pet_expcor <- aperm(pet_expcor, pos) + } } + pet[[2]] <- pet_expcor } } @@ -518,11 +556,50 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'lat_dim' is not found in 'exp_cor' dimension.") } } + # dates + if (is.null(dates_exp)) { + stop("Parameter 'dates_exp' is missing, dates must be provided.") + } + if (!(is.Date(dates_exp)) & !(is.POSIXct(dates_exp))) { + stop("Parameter 'dates_exp' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!all(dim(exp[[1]])[c(time_dim, leadtime_dim)] == + dim(dates_exp)[c(time_dim, leadtime_dim)])) { + stop("Parameter 'dates_exp' needs to have the same length as 'time_dim' ", + "and 'leadtime_dim' as 'exp'.") + } + + if (!is.null(exp_cor)) { + if (is.null(dates_expcor)) { + stop("Parameter 'dates_expcor' is missing, dates for 'exp_cor' must be ", + "provided if exp_cor is not NULL.") + } + if (!(is.Date(dates_expcor)) & !(is.POSIXct(dates_expcor))) { + stop("Element 'Dates' in 'exp_cor' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!all(dim(exp_cor[[1]])[c(time_dim, leadtime_dim)] == + dim(dates_expcor)[c(time_dim, leadtime_dim)])) { + stop("Parameter 'dates_expcor' needs to have the same length as ", + "'time_dim' and 'leadtime_dim' as 'exp_cor'.") + } + } ## accum if (accum > dim(exp[[1]])[leadtime_dim]) { stop(paste0("Cannot compute accumulation of ", accum, " months because ", "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) } + ## params + if (!is.null(params)) { + if (!is.numeric(params)) { + stop("Parameter 'params' must be numeric.") + } + if (!all(c(time_dim, leadtime_dim, 'coef') %in% names(dim(params)))) { + stop("Parameter 'params' must be a multidimensional array with named ", + "dimensions: 'time_dim', 'leadtime_dim' and 'coef'.") + } + } ## standardization if (!is.logical(standardization)) { @@ -543,26 +620,29 @@ PeriodSPEI <- function(exp, dates_exp, lat, if (!is.logical(cross_validation)) { stop("Parameter 'cross_validation' must be a logical value.") } - if (cross_validation) { - warning("Detected 'cross_validation' = TRUE. This functionality ", - "is being developed, sorry for the inconvenience. It will ", - "be set to FALSE.") - cross_validation <- FALSE - } + # if (cross_validation) { + # warning("Detected 'cross_validation' = TRUE. This functionality ", + # "is being developed, sorry for the inconvenience. It will ", + # "be set to FALSE.") + # cross_validation <- FALSE + # } ## method if (!(method %in% c('parametric', 'non-parametric'))) { - stop('pcX script error: SPEI can be only computed using the following approach: parametric or non-parametric') + stop("Parameter 'method' must be a character string containing one of ", + "the following methods: 'parametric' or 'non-parametric'.") } ## distribution if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { - stop('Distrib must be one of "log-Logistic", "Gamma" or "PearsonIII"') + stop("Parameter 'distribution' must be a character string containing one ", + "of the following distributions: 'log-Logistic', 'Gamma' or ", + "'PearsonIII'.") } ## fit if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { - stop('Method must be one of "ub-pwm" (default), "pp-pwm" or "max-lik".') + stop("Parameter 'fit' must be a character string containing one of ", + "the following fit methods: 'max-lik', 'ub-pwm', 'pp-pwm'.") } - ## ncores if (!is.null(ncores)) { if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | @@ -600,16 +680,19 @@ PeriodSPEI <- function(exp, dates_exp, lat, for (data in .return2list(exp, exp_cor)) { k = k + 1 # Evapotranspiration estimation (unless pet is already provided) - if (is.null(pet) | computed_pet) { - pet <- .Evapotranspiration(data = data, dates_monthly = dates_monthly[[k]], - lat = lat, pet_method = pet_method[k], - time_dim = time_dim, leadtime_dim = leadtime_dim, - lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) + if (is.null(pet[[k]]) | computed_pet) { + pet[[k]] <- .Evapotranspiration(data = data, + dates_monthly = dates_monthly[[k]], + lat = lat, pet_method = pet_method[k], + time_dim = time_dim, + leadtime_dim = leadtime_dim, + lat_dim = lat_dim, na.rm = na.rm, + ncores = ncores) computed_pet <- TRUE } # Accumulation - diff_p_pet <- data$prlr - pet + diff_p_pet <- data$prlr - pet[[k]] data_accum <- .Accumulation(data = diff_p_pet, dates_monthly = dates_monthly[[k]], accum = accum, time_dim = time_dim, leadtime_dim = leadtime_dim, @@ -660,7 +743,9 @@ PeriodSPEI <- function(exp, dates_exp, lat, .return2list <- function(data1, data2 = NULL) { - if (is.null(data2)) { + if (is.null(data1) & is.null(data2)) { + return(NULL) + } else if (is.null(data2)) { return(list(data1)) } else { return(list(data1, data2)) diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 2bc5c47..70c9b21 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -7,7 +7,6 @@ CST_PeriodSPEI( exp, exp_cor = NULL, - pet = NULL, time_dim = "syear", leadtime_dim = "time", memb_dim = "ensemble", @@ -15,6 +14,8 @@ CST_PeriodSPEI( accum = 1, ref_period = NULL, params = NULL, + pet_exp = NULL, + pet_expcor = NULL, standardization = TRUE, cross_validation = FALSE, pet_method = "hargreaves", @@ -42,10 +43,6 @@ precipitation ('prlr') need to be in mm/month.} variable in which the quantile PeriodSPEI should be applied. If it is not specified, the PeriodSPEI is calculated from object 'exp'.} -\item{pet}{A multidimensional array containing the Potential -EvapoTranspiration data. If it is NULL it is calculated using pet_method. It -is NULL by default.} - \item{time_dim}{A character string indicating the name of the temporal dimension. By default, it is set to 'syear'.} @@ -69,12 +66,22 @@ used as starting and end points.} \item{params}{A multidimensional array with named dimensions for computing the SPEI. This option overrides computation of fitting parameters. It needs -to be of same leadtime and time dimensions of exp and a dimension named +to be of same leadtime and time dimensions of 'exp' and a dimension named 'coef' with the length of the coefficients needed for the used distribution (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime dimension must be of length 1.} +\item{pet_exp}{A multidimensional array containing the Potential +EvapoTranspiration data of 'exp'. It must have the same dimensions of the +variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +variables with specified 'pet_method'. It is NULL by default.} + +\item{pet_expcor}{A multidimensional array containing the Potential +EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of +the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +provided variables with specified 'pet_method'. It is NULL by default.} + \item{standardization}{A logical value indicating wether the standardization is computed.} @@ -88,7 +95,8 @@ variables tasmin and tasmax; and 'thornthwaite', that requires variable 'tas'.} \item{method}{A character string indicating the standardization method used. -If can be: 'parametric' or 'non-parametric'.} +If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +default.} \item{distribution}{A character string indicating the name of the distribution function to be used for computing the SPEI. The accepted names are: @@ -110,6 +118,22 @@ from data. It is FALSE by default.} \item{ncores}{An integer value indicating the number of cores to use in parallel computation.} } +\value{ +A list with elements: +\itemize{ + \item{'exp', if 'standarization' is TRUE an 's2dv_cube' conaining the 'SPEI' + in element data from 'exp' array with the same dimensions as 'exp'. + If it is FALSE, it is an array with the accumulated values of PET + minus 'prlr' data.} + \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not + NULL. It is an 's2dv_cube' with the SPEI data from 'exp_cor' in + element 'data'. If 'standarization' is FALSE, only the accumulated + values of PET minus 'prlr' is returned.} + \item{'params', returned if 'standarization' is TRUE, it contains the + parameters used for the standarization of 'exp' that are used for + computing the 'SPEI' for 'exp_cor'.} +} +} \description{ Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) that is a multiscalar drought index based on climatic data. It can be used for @@ -122,17 +146,18 @@ a simple climatic water balance which is calculated at different time scales to obtain the SPEI. } \examples{ -# Test random data dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 25) -dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, +dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) -dates <- as.POSIXct(c(paste0(2010:2015, "-08-16"), - paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16")), 'UTC') -dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) - +dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), + paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16")), 'UTC') +dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), + paste0(2020, "-10-16")), 'UTC') +dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) lat <- c(40,40.1) exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) @@ -148,9 +173,9 @@ exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), - Dates = dates) + Dates = dates_exp) exp_cor <- lapply(exp_cor, CSTools::s2dv_cube, coords = list(latitude = lat), - Dates = dates) + Dates = dates_expcor) res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index 1168122..cf2d23c 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -10,7 +10,6 @@ PeriodSPEI( lat, exp_cor = NULL, dates_expcor = NULL, - pet = NULL, time_dim = "syear", leadtime_dim = "time", memb_dim = "ensemble", @@ -18,6 +17,8 @@ PeriodSPEI( accum = 1, ref_period = NULL, params = NULL, + pet_exp = NULL, + pet_expcor = NULL, standardization = TRUE, cross_validation = FALSE, pet_method = "hargreaves", @@ -53,10 +54,6 @@ specified, the PeriodSPEI is calculated from object 'exp'.} \item{dates_expcor}{An array of temporal dimensions containing the Dates of 'exp_cor'. It must be of class 'Date' or 'POSIXct'.} -\item{pet}{A multidimensional array containing the Potential -EvapoTranspiration data. If it is NULL it is calculated using pet_method. It -is NULL by default.} - \item{time_dim}{A character string indicating the name of the temporal dimension. By default, it is set to 'syear'.} @@ -86,6 +83,16 @@ to be of same leadtime and time dimensions of exp and a dimension named 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime dimension must be of length 1.} +\item{pet_exp}{A multidimensional array containing the Potential +EvapoTranspiration data of 'exp'. It must have the same dimensions of the +variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +variables with specified 'pet_method'. It is NULL by default.} + +\item{pet_expcor}{A multidimensional array containing the Potential +EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of +the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +provided variables with specified 'pet_method'. It is NULL by default.} + \item{standardization}{A logical value indicating wether the standardization is computed.} @@ -121,6 +128,21 @@ from data. It is FALSE by default.} \item{ncores}{An integer value indicating the number of cores to use in parallel computation.} } +\value{ +A list with elements: +\itemize{ + \item{'exp', if 'standarization' is TRUE an array conaining SPEI data from + 'exp' array with the same dimensions as 'exp'. If it is FALSE, it + is an array with the accumulated values of PET minus 'prlr' data.} + \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not + NULL. It is an array with the SPEI data from 'exp_cor'. If + 'standarization' is FALSE, only the accumulated values of PET minus + 'prlr' is returned.} + \item{'params', returned if 'standarization' is TRUE, it contains the + parameters used for the standarization of 'exp' that are used for + computing the 'SPEI' for 'exp_cor'.} +} +} \description{ Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) that is a multiscalar drought index based on climatic data. It can be used for @@ -133,10 +155,9 @@ a simple climatic water balance which is calculated at different time scales to obtain the SPEI. } \examples{ -# Test random data dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 25) -dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, +dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) @@ -146,15 +167,20 @@ expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) -dates <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) -dim(dates) <- c(sday = 1, sweek = 1, syear = 6, time = 3) - +dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), + paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), + paste0(2020, "-09-15"), + paste0(2020, "-10-16")), 'UTC') +dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) lat <- c(40,40.1) exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) -res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates = dates) +res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor) } diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index e009ad0..fb9b946 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -86,11 +86,6 @@ test_that("1. Initial checks PeriodSPEI", { PeriodSPEI(exp = exp1, exp_cor = list('tasmax' = array(10))), "Parameter 'exp_cor' needs to be a list of arrays with dimension names." ) - expect_error( - PeriodSPEI(exp = list('tas' = array(10, dim = c(time = 10))), - exp_cor = list('tos' = array(10, dim = c(time = 10)))), - "Parameter 'exp_cor' needs to have the same variable names as 'exp'." - ) # exp (2) expect_warning( PeriodSPEI(exp = exp1, pet_method = '1', dates_exp = dates_exp, lat = lat), @@ -117,26 +112,119 @@ test_that("1. Initial checks PeriodSPEI", { expect_error( PeriodSPEI(exp = exp1, accum = 10, dates_exp = dates_exp, lat = lat) ) - + # standardization + expect_error( + PeriodSPEI(exp = exp1, standardization = 10, dates_exp = dates_exp, lat = lat) + ) + # param_error + expect_error( + PeriodSPEI(exp = exp1, param_error = TRUE, dates_exp = dates_exp, lat = lat) + ) + # handle_infinity + expect_error( + PeriodSPEI(exp = exp1, handle_infinity = 1, dates_exp = dates_exp, lat = lat) + ) + # cross_validation + expect_error( + PeriodSPEI(exp = exp1, cross_validation = 1, dates_exp = dates_exp, lat = lat) + ) + # method + expect_error( + PeriodSPEI(exp = exp1, method = 1, dates_exp = dates_exp, lat = lat) + ) + # distribution + expect_error( + PeriodSPEI(exp = exp1, distribution = 1, dates_exp = dates_exp, lat = lat) + ) + # fit + expect_error( + PeriodSPEI(exp = exp1, fit = 1, dates_exp = dates_exp, lat = lat) + ) + # ncores + expect_error( + PeriodSPEI(exp = exp1, ncores = 1.5, dates_exp = dates_exp, lat = lat) + ) }) ############################################## test_that("2. Output checks", { - res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor) + res1 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor) + res2 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor, + standardization = FALSE) + res3 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp) + res4 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, standardization = FALSE) + # output dims + expect_equal( + names(res1), + c('exp', 'exp_cor', 'params') + ) expect_equal( - length(res), - 3 + names(res2), + c('exp', 'exp_cor') ) expect_equal( - dim(res[[1]]), + names(res3), + c('exp', 'params') + ) + expect_equal( + names(res4), + c('exp') + ) + expect_equal( + dim(res1[[1]]), dims ) expect_equal( - dim(res[[3]])[which(!names(dim(res[[3]])) %in% c('coef', 'syear'))], + dim(res1[[3]])[which(!names(dim(res1[[3]])) %in% c('coef', 'syear'))], dims[which(!names(dims) %in% c('syear', 'ensemble'))] ) + expect_equal( + dim(res2[[2]]), + dimscor + ) + expect_equal( + dim(res3[[2]]), + c(syear = 1, time = 3, coef = 3, latitude = 2, longitude = 1) + ) + # exp + # exp_cor + # pet + # time_dim + # leadtime_dim + # memb_dim + # lat_dim + # accum + # ref_period + # params + # standarization + # cross_validation + # pet_method - + # method - + # distribution - Only works for 'log-Logistic' + res5 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, distribution = 'PearsonIII') + res6 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, distribution = 'Gamma') + # fit - + res7 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, fit = 'ub-pwm') + res8 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, fit = 'max-lik') + res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, fit = 'pp-pwm') + all.equal(res7, res8) + all.equal(res7, res9) # res9 doesn't work for this data + # param_error - + # handle_infinity - OK + res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, handle_infinity = FALSE) + # na.rm - + # ncores }) ############################################## \ No newline at end of file -- GitLab From f8c059f64c1f1e4c2192b38656a5fe8ba879ddfa Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 14 Jun 2023 11:09:47 +0200 Subject: [PATCH 13/87] Return 's2dv_cube' spei CST_PeriodSPEI correctly --- NAMESPACE | 2 + R/PeriodSPEI.R | 34 +++++++++++++--- tests/testthat/test-PeriodSPEI.R | 70 ++++++++++++++++++++++++-------- 3 files changed, 83 insertions(+), 23 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 61b6b92..0723757 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,9 +27,11 @@ export(TotalSpellTimeExceedingThreshold) export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) +import(CSTools) import(ClimProjDiags) import(SPEI) import(TLMoments) +import(lmom) import(lmomco) import(lubridate) import(multiApply) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 39e6daf..213dd73 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -134,7 +134,9 @@ #'@import zoo #'@import TLMoments #'@import lmomco +#'@import lmom #'@import lubridate +#'@import CSTools #'@export CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', leadtime_dim = 'time', @@ -200,19 +202,38 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, handle_infinity = handle_infinity, na.rm = na.rm, ncores = ncores) if (is.null(exp_cor)) { - exp$data <- res[[1]] + source_files <- lapply(exp, function(x) {x$attrs$source_files}) + suppressWarnings( + res_exp <- CSTools::s2dv_cube(data = res[[1]], coords = exp[[1]]$coords, + varName = c('SPEI'), Dates = dates_exp, + when = Sys.time(), + source_files = source_files) + ) if (standardization) { - return(list(exp = exp, params = res[[2]])) + return(list(spei_exp = res_exp, params = res[[2]])) } else { return(exp) } } else { - exp$data <- res[[1]] - exp_cor$data <- res[[2]] + source_files_exp <- lapply(exp, function(x) {x$attrs$source_files}) + suppressWarnings( + res_exp <- CSTools::s2dv_cube(data = res[[1]], coords = exp[[1]]$coords, + varName = c('SPEI'), Dates = dates_exp, + source_files = source_files_exp, + when = Sys.time()) + ) + source_files_expcor <- lapply(exp_cor, function(x) {x$attrs$source_files}) + suppressWarnings( + res_expcor <- CSTools::s2dv_cube(data = res[[2]], coords = exp_cor[[1]]$coords, + varName = c('SPEI'), Dates = dates_expcor, + source_files = source_files_expcor, + when = Sys.time()) + ) + if (standardization) { - return(list(exp = exp, exp_cor = exp_cor, params = res[[3]])) + return(list(spei_exp = res_exp, spei_exp_cor = res_expcor, params = res[[3]])) } else { - return(list(exp = exp, exp_cor = exp_cor)) + return(list(spei_exp = res_exp, spei_exp_cor = res_expcor)) } } return(res) @@ -353,6 +374,7 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'@import zoo #'@import TLMoments #'@import lmomco +#'@import lmom #'@import lubridate #'@export PeriodSPEI <- function(exp, dates_exp, lat, diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index fb9b946..90622ad 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -35,8 +35,32 @@ lat <- c(40,40.1) exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) -res <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor) +# dat2 +dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) +dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) + +set.seed(1) +exp_tas <- array(rnorm(100, 17.34, 9.18), dim = dims) +set.seed(2) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) + +set.seed(1) +expcor_tas <- array(rnorm(100, 17.23, 9.19), dim = dimscor) +set.seed(2) +expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) + +dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +dates_expcor <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), + paste0(2020, "-10-16"))) +dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) + +lat <- c(40,40.1) + +exp2 <- list('tas' = exp_tas, 'prlr' = exp_prlr) +exp_cor2 <- list('tas' = expcor_tas, 'prlr' = expcor_prlr) ############################################## @@ -202,23 +226,35 @@ test_that("2. Output checks", { # ref_period # params # standarization - # cross_validation - # pet_method - - # method - + # cross_validation - Not working + # pet_method - ok + res5 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor, + pet_method = c('hargreaves', 'hargreaves_modified')) + res6 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor, + pet_method = c('hargreaves_modified', 'hargreaves')) + res7 <- PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor, + pet_method = c('thornthwaite', 'thornthwaite')) + # method - ok + res8 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor, + method = 'non-parametric') # distribution - Only works for 'log-Logistic' - res5 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, distribution = 'PearsonIII') - res6 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, distribution = 'Gamma') - # fit - - res7 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, fit = 'ub-pwm') - res8 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, fit = 'max-lik') res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, fit = 'pp-pwm') - all.equal(res7, res8) - all.equal(res7, res9) # res9 doesn't work for this data + dates_exp = dates_exp, distribution = 'PearsonIII') # NA + res10 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, distribution = 'Gamma') # NA + # fit - + res12 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, fit = 'ub-pwm') # ok + res13 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, fit = 'max-lik') # ok + res14 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, fit = 'pp-pwm') # NA + all.equal(res12, res13) + all.equal(res12, res14) # res14 doesn't work for this data # param_error - # handle_infinity - OK res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, -- GitLab From 387c589075ab109c100dff2bb4cdd0a34c9647a2 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 14 Jun 2023 11:17:07 +0200 Subject: [PATCH 14/87] Move auxiliary function to zzz file --- R/PeriodSPEI.R | 12 ------------ R/zzz.R | 10 ++++++++++ 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 213dd73..44c8552 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -763,18 +763,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, return(spei_res) } - -.return2list <- function(data1, data2 = NULL) { - if (is.null(data1) & is.null(data2)) { - return(NULL) - } else if (is.null(data2)) { - return(list(data1)) - } else { - return(list(data1, data2)) - } -} - - .Evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreaves', time_dim = 'syear', leadtime_dim = 'time', lat_dim = 'latitude', na.rm = FALSE, diff --git a/R/zzz.R b/R/zzz.R index 81bd0ce..47d871d 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -96,4 +96,14 @@ wind2CF <- function(wind, pc) { .KnownLatNames <- function() { known_lat_names <- c('lat', 'lats', 'latitude', 'y', 'j', 'nav_lat') +} + +.return2list <- function(data1, data2 = NULL) { + if (is.null(data1) & is.null(data2)) { + return(NULL) + } else if (is.null(data2)) { + return(list(data1)) + } else { + return(list(data1, data2)) + } } \ No newline at end of file -- GitLab From 382dadd2d269e16e0a521dfcc66b06cec7d92c62 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 14 Jun 2023 11:46:21 +0200 Subject: [PATCH 15/87] Correct Dates output for 's2dv_cube' in CST_PeriodSPEI --- R/PeriodSPEI.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 44c8552..2cd02e8 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -205,9 +205,10 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, source_files <- lapply(exp, function(x) {x$attrs$source_files}) suppressWarnings( res_exp <- CSTools::s2dv_cube(data = res[[1]], coords = exp[[1]]$coords, - varName = c('SPEI'), Dates = dates_exp, - when = Sys.time(), - source_files = source_files) + varName = c('SPEI'), + Dates = exp[[1]]$attrs$Dates, + source_files = source_files, + when = Sys.time()) ) if (standardization) { return(list(spei_exp = res_exp, params = res[[2]])) @@ -218,14 +219,16 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, source_files_exp <- lapply(exp, function(x) {x$attrs$source_files}) suppressWarnings( res_exp <- CSTools::s2dv_cube(data = res[[1]], coords = exp[[1]]$coords, - varName = c('SPEI'), Dates = dates_exp, + varName = c('SPEI'), + Dates = exp[[1]]$attrs$Dates, source_files = source_files_exp, when = Sys.time()) ) source_files_expcor <- lapply(exp_cor, function(x) {x$attrs$source_files}) suppressWarnings( res_expcor <- CSTools::s2dv_cube(data = res[[2]], coords = exp_cor[[1]]$coords, - varName = c('SPEI'), Dates = dates_expcor, + varName = c('SPEI'), + Dates = exp_cor[[1]]$attrs$Dates, source_files = source_files_expcor, when = Sys.time()) ) -- GitLab From 617e68fc0b6a785b508e409179ca8c8fc339ffeb Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 14 Jun 2023 17:16:58 +0200 Subject: [PATCH 16/87] Improve documentation and restrict cross_validation TRUE when exp_cor is not provided --- R/PeriodSPEI.R | 48 +++++++++++++++++--------------- man/CST_PeriodSPEI.Rd | 13 +++++---- man/PeriodSPEI.Rd | 13 +++++---- tests/testthat/test-PeriodSPEI.R | 28 ++++++++++++++++++- 4 files changed, 66 insertions(+), 36 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 2cd02e8..f5a4b3b 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -39,11 +39,11 @@ #' used as starting and end points. #'@param params A multidimensional array with named dimensions for computing the #' SPEI. This option overrides computation of fitting parameters. It needs -#' to be of same leadtime and time dimensions of 'exp' and a dimension named -#' 'coef' with the length of the coefficients needed for the used distribution -#' (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or -#' 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime -#' dimension must be of length 1. +#' to be of same time dimension (specified in 'time_dim') of 'exp' and a +#' dimension named 'coef' with the length of the coefficients needed for the +#' used distribution (for 'Gamma' coef dimension is of lenght 2, for +#' 'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a +#' leadtime dimension (specified in 'leadtime_dim') of length 1. #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the #' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided @@ -55,7 +55,8 @@ #'@param standardization A logical value indicating wether the standardization #' is computed. #'@param cross_validation A logical value indicating if cross validation is -#' done (TRUE), or not (FALSE). It is FALSE by default. +#' done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and +#' is not provided. It is FALSE by default. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -211,9 +212,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, when = Sys.time()) ) if (standardization) { - return(list(spei_exp = res_exp, params = res[[2]])) + return(list(exp = res_exp, params = res[[2]])) } else { - return(exp) + return(res_exp) } } else { source_files_exp <- lapply(exp, function(x) {x$attrs$source_files}) @@ -234,9 +235,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, ) if (standardization) { - return(list(spei_exp = res_exp, spei_exp_cor = res_expcor, params = res[[3]])) + return(list(exp = res_exp, exp_cor = res_expcor, params = res[[3]])) } else { - return(list(spei_exp = res_exp, spei_exp_cor = res_expcor)) + return(list(exp = res_exp, exp_cor = res_expcor)) } } return(res) @@ -289,11 +290,11 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' used as starting and end points. #'@param params A multidimensional array with named dimensions for computing the #' SPEI. This option overrides computation of fitting parameters. It needs -#' to be of same leadtime and time dimensions of exp and a dimension named -#' 'coef' with the length of the coefficients needed for the used distribution -#' (for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or -#' 'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime -#' dimension must be of length 1. +#' to be of same time dimension (specified in 'time_dim') of 'exp' and a +#' dimension named 'coef' with the length of the coefficients needed for the +#' used distribution (for 'Gamma' coef dimension is of lenght 2, for +#' 'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a +#' leadtime dimension (specified in 'leadtime_dim') of length 1. #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the #' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided @@ -305,7 +306,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'@param standardization A logical value indicating wether the standardization #' is computed. #'@param cross_validation A logical value indicating if cross validation is -#' done (TRUE), or not (FALSE). It is FALSE by default. +#' done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and +#' is not provided. It is FALSE by default. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -645,12 +647,13 @@ PeriodSPEI <- function(exp, dates_exp, lat, if (!is.logical(cross_validation)) { stop("Parameter 'cross_validation' must be a logical value.") } - # if (cross_validation) { - # warning("Detected 'cross_validation' = TRUE. This functionality ", - # "is being developed, sorry for the inconvenience. It will ", - # "be set to FALSE.") - # cross_validation <- FALSE - # } + if (!is.null(exp_cor)) { + if (cross_validation & standardization) { + warning("Detected 'cross_validation' = TRUE. It will be set as FALSE ", + "since 'exp_cor' is provided.") + cross_validation <- FALSE + } + } ## method if (!(method %in% c('parametric', 'non-parametric'))) { @@ -741,7 +744,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, spei_res[[k]] <- spei_dat[[1]] } else { - pos <- match(names(dim(data[[1]])), names(dim(data_accum))) data_accum <- aperm(data_accum, pos) diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 70c9b21..2a7aaa6 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -66,11 +66,11 @@ used as starting and end points.} \item{params}{A multidimensional array with named dimensions for computing the SPEI. This option overrides computation of fitting parameters. It needs -to be of same leadtime and time dimensions of 'exp' and a dimension named -'coef' with the length of the coefficients needed for the used distribution -(for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or -'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime -dimension must be of length 1.} +to be of same time dimension (specified in 'time_dim') of 'exp' and a +dimension named 'coef' with the length of the coefficients needed for the +used distribution (for 'Gamma' coef dimension is of lenght 2, for +'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a +leadtime dimension (specified in 'leadtime_dim') of length 1.} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the @@ -86,7 +86,8 @@ provided variables with specified 'pet_method'. It is NULL by default.} is computed.} \item{cross_validation}{A logical value indicating if cross validation is -done (TRUE), or not (FALSE). It is FALSE by default.} +done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and +is not provided. It is FALSE by default.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index cf2d23c..86aaa02 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -77,11 +77,11 @@ used as starting and end points.} \item{params}{A multidimensional array with named dimensions for computing the SPEI. This option overrides computation of fitting parameters. It needs -to be of same leadtime and time dimensions of exp and a dimension named -'coef' with the length of the coefficients needed for the used distribution -(for 'Gamma' coef dimension is of lenght 2, for 'log-Logistic' or -'PearsonIII' is of length 3). If cross_validation is FALSE, the leadtime -dimension must be of length 1.} +to be of same time dimension (specified in 'time_dim') of 'exp' and a +dimension named 'coef' with the length of the coefficients needed for the +used distribution (for 'Gamma' coef dimension is of lenght 2, for +'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a +leadtime dimension (specified in 'leadtime_dim') of length 1.} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the @@ -97,7 +97,8 @@ provided variables with specified 'pet_method'. It is NULL by default.} is computed.} \item{cross_validation}{A logical value indicating if cross validation is -done (TRUE), or not (FALSE). It is FALSE by default.} +done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and +is not provided. It is FALSE by default.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 90622ad..85a1427 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -226,7 +226,33 @@ test_that("2. Output checks", { # ref_period # params # standarization - # cross_validation - Not working + # cross_validation + expect_warning( + PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, + dates_exp = dates_exp, dates_expcor = dates_expcor, + cross_validation = TRUE), + paste0("Detected 'cross_validation' = TRUE. It will be set as FALSE ", + "since 'exp_cor' is provided.") + ) + res_crossval_T <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + cross_validation = TRUE) + res_crossval_F <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + cross_validation = FALSE) + # cross_validation = TRUE + expect_equal( + dim(res_crossval_T$exp), + dims + ) + expect_equal( + dim(res_crossval_T$params), + dims + ) + # cross_validation = FALSE + expect_equal( + dim(res_crossval_F$params)[-which(names(dim(res_crossval_F$params)) == 'coef')], + dimscor[-which(names(dimscor) == 'ensemble')] + ) + # pet_method - ok res5 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, -- GitLab From 9b861f0a0b3175848508c654dbab1fc54aca69b7 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 14 Jun 2023 17:22:57 +0200 Subject: [PATCH 17/87] Remove typo --- R/PeriodSPEI.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index f5a4b3b..077137c 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -839,7 +839,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, } rm(data_tmp) } - any(is.na(data3)) if (!is.null(data3)) { data_tmp <- as.vector(data3) data3 <- array(0, dim = length(dates_monthly)) -- GitLab From e5eff31bca61b2fae01030e0ec709030425e6d2d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 16 Jun 2023 18:01:06 +0200 Subject: [PATCH 18/87] Develop new element time_bounds with start and end elements containing the start and end dates of the aggregation for PeriodMean and PeriodAggregation; updated documentation; added tests --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/PeriodAccumulation.R | 74 +++++++++++++++------- R/PeriodMean.R | 69 ++++++++++++++------- man/CST_PeriodAccumulation.Rd | 23 ++++--- man/CST_PeriodMean.Rd | 22 +++++-- man/PeriodAccumulation.Rd | 15 +++-- tests/testthat/test-PeriodAccumulation.R | 78 ++++++++++++++++++++++-- tests/testthat/test-PeriodMean.R | 63 +++++++++++++++++-- 9 files changed, 270 insertions(+), 77 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4151ba4..4e20983 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,4 @@ URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 RoxygenNote: 7.2.0 -Config/testthat/edition: 3 \ No newline at end of file +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index d80accb..0a16d4d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) import(multiApply) +importFrom(ClimProjDiags,Subset) importFrom(stats,approxfun) importFrom(stats,ecdf) importFrom(stats,quantile) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index d181d8e..2ef738f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -31,7 +31,10 @@ #' computation. #' #'@return A 's2dv_cube' object containing the indicator in the element -#'\code{data}. +#'\code{data}. A new element called 'time_bounds' will be added into +#' the 'attrs' element in the 's2dv_cube' object. It consists of a list +#' containing two elements, the start and end dates of the aggregated period +#' with the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL @@ -39,14 +42,16 @@ #' ftime = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' #'TP <- CST_PeriodAccumulation(exp) -#'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), -#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), -#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), -#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'exp$data <- array(rnorm(5 * 3 * 214 * 2), +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'exp$attrs$Dates <- Dates #'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) #'dim(SprR$data) #'head(SprR$attrs$Dates) @@ -55,6 +60,7 @@ #'head(HarR$attrs$Dates) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, @@ -73,15 +79,29 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, } } - total <- PeriodAccumulation(data$data, dates = data$attrs$Dates, start, end, + Dates <- data$attrs$Dates + + total <- PeriodAccumulation(data$data, dates = Dates, start, end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds } + return(data) } @@ -98,9 +118,10 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'} #' #'@param data A multidimensional array with named dimensions. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of datesW with named dimensions matching +#' the dimensions on parameter 'data'. By default it is NULL, to select a +#' period this parameter must be provided and it needs to have temporal +#' dimensions. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -128,15 +149,17 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'TP <- PeriodAccumulation(exp, time_dim = 'ftime') #'data <- array(rnorm(5 * 3 * 214 * 2), #' c(memb = 5, sdate = 3, time = 214, lon = 2)) -#'# ftime tested #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), end = list(21, 6)) -#'HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), end = list(21, 10)) +#'dim(Dates) <- c(sdate = 3, time = 214) +#'SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), +#' end = list(21, 6)) +#'HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), +#' end = list(21, 10)) #' #'@import multiApply #'@export @@ -159,8 +182,13 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data, dates, start, end, + time_dim = time_dim, ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } total <- Apply(list(data), target_dims = time_dim, fun = sum, diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 303b38e..e12cd09 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -31,19 +31,30 @@ #' computation. #' #'@return An 's2dv_cube' object containing the indicator in the element -#' \code{data}. +#' \code{data}. A new element called 'time_bounds' will be added into +#' the 'attrs' element in the 's2dv_cube' object. It consists of a list +#' containing two elements, the start and end dates of the aggregated period +#' with the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, ftime = 8)) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 6, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' -#'exp$attrs$Dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), -#' as.Date("01-08-1993","%d-%m-%Y", tz = 'UTC'), "day"), -#' seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), -#' as.Date("01-08-1994","%d-%m-%Y", tz = 'UTC'), "day")) +#' #'SA <- CST_PeriodMean(exp) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_PeriodMean <- function(data, start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, @@ -62,22 +73,29 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, } } - total <- PeriodMean(data = data$data, dates = data$attrs$Dates, start, end, + Dates <- data$attrs$Dates + + total <- PeriodMean(data = data$data, dates = Dates, start, end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total - original_dates <- data$attrs$Dates - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds } - data$attrs$Dates <- ClimProjDiags::Subset(data$attrs$Dates, time_dim, 1, - drop = 'selected') - # Option (1) - # attr(data$attrs$Dates, 'original_dates') <- original_dates - # Option (2) - data$attrs$original_dates <- original_dates + return(data) } @@ -139,15 +157,20 @@ PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, } if (is.null(dates)) { warning("Parameter 'dates' is NULL and the Average of the ", - "full data provided in 'data' is computed.") + "full data provided in 'data' is computed.") } else { if (!is.null(start) && !is.null(end)) { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", - "day and the month of the period start and end.") + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data, dates, start, end, + time_dim = time_dim, ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) } } total <- Apply(list(data), target_dims = time_dim, fun = mean, diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 3928705..71122d6 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -41,7 +41,10 @@ computation.} } \value{ A 's2dv_cube' object containing the indicator in the element -\code{data}. +\code{data}. A new element called 'time_bounds' will be added into + the 'attrs' element in the 's2dv_cube' object. It consists of a list + containing two elements, the start and end dates of the aggregated period + with the same dimensions of 'Dates' element. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a @@ -60,14 +63,16 @@ exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' TP <- CST_PeriodAccumulation(exp) -exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), - as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), - as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), - as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +exp$data <- array(rnorm(5 * 3 * 214 * 2), + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +exp$attrs$Dates <- Dates SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) dim(SprR$data) head(SprR$attrs$Dates) diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index b1004ad..f9db984 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -41,7 +41,10 @@ computation.} } \value{ An 's2dv_cube' object containing the indicator in the element - \code{data}. + \code{data}. A new element called 'time_bounds' will be added into + the 'attrs' element in the 's2dv_cube' object. It consists of a list + containing two elements, the start and end dates of the aggregated period + with the same dimensions of 'Dates' element. } \description{ Period Mean computes the average (mean) of a given variable in a period. @@ -56,12 +59,19 @@ this function: } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, ftime = 8)) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 6, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' -exp$attrs$Dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), - as.Date("01-08-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), - seq(as.Date("01-07-1994", "\%d-\%m-\%Y", tz = 'UTC'), - as.Date("01-08-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) + SA <- CST_PeriodMean(exp) } diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 9903321..0f55937 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -17,9 +17,10 @@ PeriodAccumulation( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of datesW with named dimensions matching +the dimensions on parameter 'data'. By default it is NULL, to select a +period this parameter must be provided and it needs to have temporal +dimensions.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -64,14 +65,16 @@ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, TP <- PeriodAccumulation(exp, time_dim = 'ftime') data <- array(rnorm(5 * 3 * 214 * 2), c(memb = 5, sdate = 3, time = 214, lon = 2)) -# ftime tested Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), end = list(21, 6)) -HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), end = list(21, 10)) +dim(Dates) <- c(sdate = 3, time = 214) +SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), + end = list(21, 6)) +HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), + end = list(21, 10)) } diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 81718f5..74bb45d 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -1,5 +1,7 @@ +library(CSTools) + ############################################## -test_that("Sanity Checks", { +test_that("1. Sanity Checks", { expect_error( PeriodAccumulation('x'), "Parameter 'data' must be numeric." @@ -30,13 +32,21 @@ test_that("Sanity Checks", { PeriodAccumulation(data), array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4)) ) - + # Test dates warning + expect_warning( + PeriodAccumulation(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) }) + ############################################## -library(CSTools) -test_that("seasonal", { - exp <- CSTools::lonlat_prec +test_that("2. Seasonal", { + exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), c(memb = 1, sdate = 3, ftime = 214, lon = 2)) exp$dims <- dim(exp$data) @@ -47,6 +57,7 @@ test_that("seasonal", { seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(sum(exp$data[1,1,21:82,1]), sum(exp$data[1,2,21:82,1]), sum(exp$data[1,3,21:82,1]), sum(exp$data[1,1,21:82,2]), @@ -58,3 +69,60 @@ test_that("seasonal", { output$data ) }) + +############################################## + +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodAccumulation(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + res2 <- CST_PeriodAccumulation(data = CSTools::lonlat_prec, time_dim = 'ftime') + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + expect_equal( + dim(res2$data), + dim(exp$data)[-which(names(dim(exp$data)) == 'ftime')] + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + expect_equal( + dim(res2$data)['sdate'], + dim(res2$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + expect_equal( + res2$attrs$Dates, + res2$attrs$time_bounds$start + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) \ No newline at end of file diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index 4186639..18b5995 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -1,5 +1,7 @@ +library(CSTools) + ############################################## -test_that("Sanity Checks", { +test_that("1. Sanity Checks", { expect_error( PeriodMean('x'), "Parameter 'data' must be numeric." @@ -31,13 +33,21 @@ test_that("Sanity Checks", { c(sdate = 2, lon = 4)) ) ) + # Test dates warning + expect_warning( + PeriodMean(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) }) ############################################## -library(CSTools) -test_that("seasonal", { - exp <- CSTools::lonlat_prec +test_that("2. Seasonal", { + exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), c(memb = 1, sdate = 3, ftime = 214, lon = 2)) exp$dims <- dim(exp$data) @@ -48,6 +58,7 @@ test_that("seasonal", { seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(mean(exp$data[1,1,21:82,1]), mean(exp$data[1,2,21:82,1]), mean(exp$data[1,3,21:82,1]), mean(exp$data[1,1,21:82,2]), @@ -58,3 +69,47 @@ test_that("seasonal", { output$data ) }) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMean(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + -- GitLab From 50f9c6ef7e7c09729a18ddf6718f4dbba03c1bd5 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 19 Jun 2023 17:25:03 +0200 Subject: [PATCH 19/87] Add time_bounds in functions that reduce time dimensions ; Add element; Add checks if dates have dimensions; add tests for this development --- R/AccumulationExceedingThreshold.R | 121 ++++++++++++------ R/PeriodAccumulation.R | 30 +++-- R/PeriodMean.R | 60 +++++---- R/QThreshold.R | 44 +++++-- R/Threshold.R | 28 ++-- R/TotalSpellTimeExceedingThreshold.R | 77 +++++++++-- R/TotalTimeExceedingThreshold.R | 78 ++++++++--- R/WindCapacityFactor.R | 48 +++++-- R/WindPowerDensity.R | 49 +++++-- man/AccumulationExceedingThreshold.Rd | 12 +- man/CST_AccumulationExceedingThreshold.Rd | 21 ++- man/CST_PeriodMean.Rd | 20 +-- man/CST_QThreshold.Rd | 10 +- man/CST_Threshold.Rd | 5 +- man/CST_TotalSpellTimeExceedingThreshold.Rd | 12 +- man/CST_TotalTimeExceedingThreshold.Rd | 11 +- man/CST_WindCapacityFactor.Rd | 13 +- man/CST_WindPowerDensity.Rd | 17 ++- man/PeriodAccumulation.Rd | 7 +- man/PeriodMean.Rd | 6 +- man/QThreshold.Rd | 22 +++- man/Threshold.Rd | 10 +- man/TotalSpellTimeExceedingThreshold.Rd | 22 +++- man/TotalTimeExceedingThreshold.Rd | 23 +++- man/WindCapacityFactor.Rd | 23 +++- man/WindPowerDensity.Rd | 21 ++- .../test-AccumulationExceedingThreshold.R | 58 ++++++++- tests/testthat/test-QThreshold.R | 36 +++++- tests/testthat/test-Threshold.R | 34 ++++- .../test-TotalSpellTimeExceedingThreshold.R | 46 ++++++- .../test-TotalTimeExceedingThreshold.R | 50 +++++++- tests/testthat/test-WindCapacityFactor.R | 28 +++- tests/testthat/test-WindPowerDensity.R | 24 ++++ 33 files changed, 811 insertions(+), 255 deletions(-) diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index e346b53..d3c7147 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -49,15 +49,29 @@ #' #'@return An 's2dv_cube' object containing the aggregated values in the element #'\code{data} with dimensions of the input parameter 'data' except the dimension -#'where the indicator has been computed. +#'where the indicator has been computed. A new element called 'time_bounds' will +#'be added into the 'attrs' element in the 's2dv_cube' object. It consists of a +#'list containing two elements, the start and end dates of the aggregated period +#'with the same dimensions of 'Dates' element. #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'class(exp) <- 's2dv_cube' -#'DOT <- CST_AccumulationExceedingThreshold(exp, threshold = 280) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'exp$attrs$Dates <- Dates +#'AT <- CST_AccumulationExceedingThreshold(data = exp, threshold = 100, +#' start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, start = NULL, end = NULL, time_dim = 'ftime', @@ -78,7 +92,7 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = if (length(op) == 1) { if (inherits(threshold, 's2dv_cube')) { - threshold <- threshold$data + threshold <- threshold$data } } else if (length(op) == 2) { if (inherits(threshold[[1]], 's2dv_cube')) { @@ -89,17 +103,38 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = } } - total <- AccumulationExceedingThreshold(data$data, dates = data$attrs$Dates, + Dates <- data$attrs$Dates + total <- AccumulationExceedingThreshold(data = data$data, dates = Dates, threshold = threshold, op = op, diff = diff, start = start, end = end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } + return(data) } #'Accumulation of a variable when Exceeding (not exceeding) a Threshold @@ -133,9 +168,9 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'@param diff A logical value indicating whether to accumulate the difference #' between data and threshold (TRUE) or not (FALSE by default). It can only be #' TRUE if a unique threshold is used. -#'@param dates A vector of dates or a multidimensional array with of dates with -#' named dimensions matching the dimensions on parameter 'data'. By default it -#' is NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to define the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is @@ -161,12 +196,6 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'# Assuming data is already (tasmax + tasmin)/2 - 10 #'data <- array(rnorm(5 * 3 * 214 * 2, mean = 25, sd = 3), #' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), -#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), -#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), -#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) #'GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), #' end = list(31, 10)) #'@import multiApply @@ -228,8 +257,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL } if (length(op) == 2) { if (length(op) != length(threshold)) { - stop(paste0("If 'op' is a pair of logical operators parameter 'threshold' ", - "also has to be a pair of values.")) + stop("If 'op' is a pair of logical operators parameter 'threshold' ", + "also has to be a pair of values.") } if (!is.numeric(threshold[[1]]) | !is.numeric(threshold[[2]])) { stop("Parameter 'threshold' must be numeric.") @@ -240,7 +269,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (!is.array(threshold[[1]]) && length(threshold[[1]]) > 1) { if (dim(data)[time_dim] != length(threshold[[1]])) { - stop("If parameter 'threshold' is a vector it must have the same length as data any time dimension.") + stop("If parameter 'threshold' is a vector it must have the same ", + "length as data any time dimension.") } else { dim(threshold[[1]]) <- length(threshold[[1]]) dim(threshold[[2]]) <- length(threshold[[2]]) @@ -265,8 +295,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (any(names(dim(threshold[[1]])) %in% names(dim(data)))) { common_dims <- dim(threshold[[1]])[names(dim(threshold[[1]])) %in% names(dim(data))] if (!all(common_dims == dim(data)[names(common_dims)])) { - stop(paste0("Parameter 'data' and 'threshold' must have same length of ", - "all common dimensions.")) + stop("Parameter 'data' and 'threshold' must have same length of ", + "all common dimensions.") } } } else if (length(threshold[[1]]) == 1) { @@ -276,7 +306,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL } else { if (!is.array(threshold) && length(threshold) > 1) { if (dim(data)[time_dim] != length(threshold)) { - stop("If parameter 'threshold' is a vector it must have the same length as data time dimension.") + stop("If parameter 'threshold' is a vector it must have the same ", + "length as data time dimension.") } else { dim(threshold) <- length(threshold) names(dim(threshold)) <- time_dim @@ -288,8 +319,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (any(names(dim(threshold)) %in% names(dim(data)))) { common_dims <- dim(threshold)[names(dim(threshold)) %in% names(dim(data))] if (!all(common_dims == dim(data)[names(common_dims)])) { - stop(paste0("Parameter 'data' and 'threshold' must have same length of ", - "all common dimensions.")) + stop("Parameter 'data' and 'threshold' must have same length of ", + "all common dimensions.") } } } else if (length(threshold) == 1) { @@ -313,27 +344,41 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (length(op) == 1) { if (time_dim %in% names(dim(threshold))) { if (dim(threshold)[time_dim] == dim(data)[time_dim]) { - threshold <- SelectPeriodOnData(threshold, dates, start, end, - time_dim = time_dim, ncores = ncores) + threshold <- SelectPeriodOnData(data = threshold, dates = dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } } } else if (length(op) == 2) { if (time_dim %in% names(dim(threshold[[1]]))) { if (dim(threshold[[1]])[time_dim] == dim(data)[time_dim]) { - threshold[[1]] <- SelectPeriodOnData(threshold[[1]], dates, start, end, - time_dim = time_dim, ncores = ncores) - threshold[[2]] <- SelectPeriodOnData(threshold[[2]], dates, start, end, - time_dim = time_dim, ncores = ncores) + threshold[[1]] <- SelectPeriodOnData(data = threshold[[1]], + dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + threshold[[2]] <- SelectPeriodOnData(data = threshold[[2]], dates = dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } } } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } } # diff if (length(op) == 2 & diff == TRUE) { - stop("Parameter 'diff' can't be TRUE if the parameter 'threshold' is a range of values.") + stop("Parameter 'diff' can't be TRUE if the parameter 'threshold' is a ", + "range of values.") } else if (diff == TRUE) { if (length(threshold) != 1) { stop("Parameter 'diff' can't be TRUE if the parameter 'threshold' is not a scalar.") @@ -345,8 +390,6 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL threshold <- 0 } - ### - if (length(op) > 1) { thres1 <- threshold[[1]] thres2 <- threshold[[2]] diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 2ef738f..c8e976e 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -80,7 +80,6 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, } Dates <- data$attrs$Dates - total <- PeriodAccumulation(data$data, dates = Dates, start, end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total @@ -91,17 +90,21 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, time_dim = time_dim, ncores = ncores) } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') - # Create time_bounds - time_bounds <- NULL - time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') - time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') - - # Add Dates in attrs - data$attrs$Dates <- time_bounds$start - data$attrs$time_bounds <- time_bounds + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } - return(data) } @@ -118,10 +121,9 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'} #' #'@param data A multidimensional array with named dimensions. -#'@param dates A multidimensional array of datesW with named dimensions matching -#' the dimensions on parameter 'data'. By default it is NULL, to select a -#' period this parameter must be provided and it needs to have temporal -#' dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/PeriodMean.R b/R/PeriodMean.R index e12cd09..6acea60 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -38,20 +38,20 @@ #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 6, ftime = 3)) -#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) #'dim(Dates) <- c(sdate = 4, ftime = 3) #'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' #' -#'SA <- CST_PeriodMean(exp) +#'SA <- CST_PeriodMean(exp, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply #'@importFrom ClimProjDiags Subset @@ -74,9 +74,9 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, } Dates <- data$attrs$Dates - - total <- PeriodMean(data = data$data, dates = Dates, start, end, + total <- PeriodMean(data = data$data, dates = Dates, start = start, end = end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) + data$data <- total data$dims <- dim(total) @@ -85,17 +85,24 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, time_dim = time_dim, ncores = ncores) } - - # Create time_bounds - time_bounds <- NULL - time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') - time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') - # Add Dates in attrs - data$attrs$Dates <- time_bounds$start - data$attrs$time_bounds <- time_bounds + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } - return(data) } @@ -112,9 +119,9 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'} #' #'@param data A multidimensional array with named dimensions. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -165,8 +172,9 @@ PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, "day and the month of the period start and end.") } if (!is.null(dim(dates))) { - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) } else { warning("Parameter 'dates' must have named dimensions if 'start' and ", "'end' are not NULL. All data will be used.") diff --git a/R/QThreshold.R b/R/QThreshold.R index 49217dd..0d069bb 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -57,15 +57,19 @@ #'exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, ftime = 2)) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_QThreshold(exp, threshold) -#'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' +#'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*50), +#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'exp_probs <- CST_QThreshold(exp, threshold) +#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +#'class(exp) <- 's2dv_cube' +#'exp_probs <- CST_QThreshold(exp, threshold, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply #'@export @@ -92,6 +96,7 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, start, end, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim, ncores = ncores) data$data <- probs + data$dims <- dim(probs) if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, @@ -127,9 +132,9 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #'@param threshold A multidimensional array with named dimensions in the same #' units as parameter 'data' and with the common dimensions of the element #' 'data' of the same length. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -157,14 +162,24 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #'@examples #'threshold = 25 #'data <- array(rnorm(5 * 3 * 20 * 2, mean = 26), -#' c(member = 5, sdate = 3, time = 20, lon = 2)) -#'thres_q <- QThreshold(data, threshold) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) +#' +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#' +#'thres_q <- QThreshold(data, threshold, dates = Dates, time_dim = 'time', +#' start = list(21, 4), end = list(21, 6)) #' #'@import multiApply #'@export QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', - ncores = NULL) { + time_dim = 'ftime', memb_dim = 'member', + sdate_dim = 'sdate', ncores = NULL) { # Initial checks ## data if (is.null(data)) { @@ -220,8 +235,13 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, } } } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } if (length(threshold) == 1) { diff --git a/R/Threshold.R b/R/Threshold.R index 3122c12..d76cbfa 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -8,7 +8,7 @@ #'@param data An 's2dv_cube' object as provided function \code{CST_Load} in #' package CSTools. #'@param threshold A single scalar or vector indicating the relative -#' threshold(s). +#' threshold(s). It must contain values between 0 and 1. #'@param start An optional parameter to defined the initial date of the period #' to selectfrom the data by providing a list of two elements: the initial date #' of the period and the initial month of the period. By default it is set to @@ -40,13 +40,14 @@ #'threshold <- 0.9 #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_Threshold(exp, threshold, start = list(21, 4), end = list(21, 6)) #' @@ -74,6 +75,7 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim, na.rm = na.rm, ncores = ncores) data$data <- thres + data$dims <- dim(thres) if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, @@ -91,10 +93,10 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, #' #'@param data A multidimensional array with named dimensions. #'@param threshold A single scalar or vector indicating the relative -#' threshold(s). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#' threshold(s). It must contain values between 0 and 1. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -134,7 +136,7 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, #'@importFrom stats quantile #'@export Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', + time_dim = 'ftime', memb_dim = 'member', sdate_dim = 'sdate', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") @@ -147,7 +149,7 @@ Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, names(dim(data)) <- c(memb_dim, sdate_dim) } if (is.null(threshold)) { - stop("Parameter 'threshold' cannot be NULL.") + stop("Parameter 'threshold' cannot be NULL.") } if (!is.numeric(threshold)) { stop("Parameter 'threshold' must be numeric.") @@ -161,8 +163,14 @@ Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } if (!is.null(memb_dim)) { diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index 3ee22a2..5d649b4 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -48,7 +48,12 @@ #' computation. #' #'@return An 's2dv_cube' object containing the number of days that are part of a -#'spell within a threshold in element \code{data}. +#'spell within a threshold in element \code{data} with dimensions of the input +#'parameter 'data' except the dimension where the indicator has been computed. +#'A new element called 'time_bounds' will be added into the 'attrs' element in +#'the 's2dv_cube' object. It consists of a list containing two elements, the +#'start and end dates of the aggregated period with the same dimensions of +#''Dates' element. #' #'@examples #'exp <- NULL @@ -60,10 +65,14 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) #'class(exp) <- 's2dv_cube' -#'TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3) +#'TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3, +#' start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', start = NULL, end = NULL, @@ -95,19 +104,41 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> threshold[[2]] <- threshold[[2]]$data } } + + Dates <- data$attrs$Dates - total <- TotalSpellTimeExceedingThreshold(data$data, data$attrs$Dates, + total <- TotalSpellTimeExceedingThreshold(data$data, Dates, threshold = threshold, spell = spell, op = op, start = start, end = end, time_dim = time_dim, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } + return(data) } #'Total Spell Time Exceeding Threshold @@ -143,9 +174,9 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #' are used it has to be a vector of a pair of two logical operators: #' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), #' c('>', '<='), c('>=', '<'),c('>=', '<=')). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -171,9 +202,19 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'values by values exceeding the threshold. #'@examples -#'data <- array(rnorm(120), c(member = 1, sdate = 2, ftime = 20, lat = 4)) -#'threshold <- array(rnorm(4), c(lat = 4)) -#'total <- TotalSpellTimeExceedingThreshold(data, threshold, spell = 6) +#'data <- array(1:100, c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#' +#'threshold <- array(1:4, c(lat = 4)) +#'total <- TotalSpellTimeExceedingThreshold(data, threshold, dates = Dates, +#' spell = 6, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply #'@export @@ -334,6 +375,14 @@ TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', } } } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } data <- SelectPeriodOnData(data, dates, start, end, time_dim = time_dim, ncores = ncores) } diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index ceda1ee..49fa988 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -54,11 +54,14 @@ #' #'@return An 's2dv_cube' object containing in element \code{data} the total #'number of the corresponding units of the data frequency that a variable is -#'exceeding a threshold during a period. +#'exceeding a threshold during a period. A new element called 'time_bounds' will +#'be added into the 'attrs' element in the 's2dv_cube' object. It consists of a +#'list containing two elements, the start and end dates of the aggregated period +#'with the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL -#'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*280), +#'exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, #' c(member = 5, sdate = 3, ftime = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), @@ -66,10 +69,13 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) #'class(exp) <- 's2dv_cube' -#'DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 280) +#'DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 23, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', start = NULL, end = NULL, @@ -101,17 +107,38 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', threshold[[2]] <- threshold[[2]]$data } } - total <- TotalTimeExceedingThreshold(data$data, dates = data$attrs$Dates, + + Dates <- data$attrs$Dates + total <- TotalTimeExceedingThreshold(data = data$data, dates = Dates, threshold = threshold, op = op, start = start, end = end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } return(data) } @@ -151,9 +178,9 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' are used it has to be a vector of a pair of two logical operators: #' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), #' c('>', '<='), c('>=', '<'),c('>=', '<=')). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to define the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -173,12 +200,21 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' #'@return A multidimensional array with named dimensions containing the total #'number of the corresponding units of the data frequency that a variable is -#'exceeding a threshold during a period. +#'exceeding a threshold during a period with dimensions of the input parameter +#''data' except the dimension where the indicator has been computed. #' #'@examples -#'exp <- array(abs(rnorm(5 * 3 * 214 * 2)*280), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'DOT <- TotalTimeExceedingThreshold(exp, threshold = 300, time_dim = 'ftime') +#'data <- array(rnorm(5 * 3 * 214 * 2)*23, +#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'DOT <- TotalTimeExceedingThreshold(data, threshold = 23, dates = Dates, +#' start = list(21, 4), end = list(21, 6)) #' #'@import multiApply #'@export @@ -336,8 +372,14 @@ TotalTimeExceedingThreshold <- function(data, threshold, op = '>', } } } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index 8ed2084..906ade3 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -42,14 +42,23 @@ #'@examples #'wind <- NULL #'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), -#' c(member = 10, lat = 2, lon = 5)) +#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) #'wind$coords <- list(lat = c(40, 41), lon = 1:5) #'variable <- list(varName = 'sfcWind', #' metadata = list(sfcWind = list(level = 'Surface'))) #'wind$attrs <- list(Variable = variable, Datasets = 'synthetic', #' when = Sys.time(), Dates = '1990-01-01 00:00:00') +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'wind$attrs$Dates <- Dates #'class(wind) <- 's2dv_cube' -#'WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") +#'WCF <- CST_WindCapacityFactor(wind, IEC_class = "III", +#' start = list(21, 4), end = list(21, 6)) #' #'@export CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", "III"), @@ -73,6 +82,8 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II dates = wind$attrs$Dates, start = start, end = end, ncores = ncores) wind$data <- WindCapacity + wind$dims <- dim(WindCapacity) + if ('Variable' %in% names(wind$attrs)) { if ('varName' %in% names(wind$attrs$Variable)) { wind$attrs$Variable$varName <- 'WindCapacityFactor' @@ -111,9 +122,9 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' respectively. Classes \code{'I/II'} and \code{'II/III'} indicate #' intermediate turbines that fit both classes. More details of the five #' turbines and a plot of its power curves can be found in Lledó et al. (2019). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -134,15 +145,26 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' Capacity Factor (unitless). #' #'@examples -#'wind <- rweibull(n = 100, shape = 2, scale = 6) -#'WCF <- WindCapacityFactor(wind, IEC_class = "III") +#'wind <- array(rweibull(n = 32100, shape = 2, scale = 6), +#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +#' +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#' +#'WCF <- WindCapacityFactor(wind, IEC_class = "III", dates = Dates, +#' start = list(21, 4), end = list(21, 6)) #' #'@importFrom stats approxfun #'@importFrom utils read.delim #'@export WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", "III"), dates = NULL, start = NULL, end = NULL, - time_dim = 'time', ncores = NULL) { + time_dim = 'ftime', ncores = NULL) { IEC_class <- match.arg(IEC_class) pc_files <- c( "I" = "Enercon_E70_2.3MW.txt", @@ -159,8 +181,14 @@ WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - wind <- SelectPeriodOnData(wind, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + wind <- SelectPeriodOnData(data = wind, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index 3578209..e9c70f6 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -6,8 +6,8 @@ #'@description It is computed as 0.5*ro*wspd^3. As this function is non-linear, #'it will give inaccurate results if used with period means. #' -#'@param wind An s2dv_cube object with instantaneous wind speeds expressed in m/s -#' obtained from CST_Load or s2dv_cube functions from CSTools pacakge. +#'@param wind An 's2dv_cube' object with instantaneous wind speeds expressed in +#' m/s obtained from CST_Load or s2dv_cube functions from CSTools pacakge. #'@param ro A scalar, or alternatively a multidimensional array with the same #' dimensions as wind, with the air density expressed in kg/m^3. By default it #' takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa. @@ -32,14 +32,23 @@ #'@examples #'wind <- NULL #'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), -#' c(member = 10, lat = 2, lon = 5)) +#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) #'wind$coords <- list(lat = c(40, 41), lon = 1:5) #'variable <- list(varName = 'sfcWind', #' metadata = list(sfcWind = list(level = 'Surface'))) #'wind$attrs <- list(Variable = variable, Datasets = 'synthetic', #' when = Sys.time(), Dates = '1990-01-01 00:00:00') +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'wind$attrs$Dates <- Dates #'class(wind) <- 's2dv_cube' -#'WCF <- CST_WindPowerDensity(wind) +#'WPD <- CST_WindPowerDensity(wind, start = list(21, 4), +#' end = list(21, 6)) #' #'@export CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, @@ -61,6 +70,7 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, dates = wind$attrs$Dates, start = start, end = end, ncores = ncores) wind$data <- WindPower + wind$dims <- dim(WindPower) if ('Variable' %in% names(wind$attrs)) { if ('varName' %in% names(wind$attrs$Variable)) { wind$attrs$Variable$varName <- 'WindPowerDensity' @@ -88,9 +98,9 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #'@param ro A scalar, or alternatively a multidimensional array with the same #' dimensions as wind, with the air density expressed in kg/m^3. By default it #' takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -111,20 +121,35 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #'Density expressed in W/m^2. #' #'@examples -#'wind <- rweibull(n = 100, shape = 2, scale = 6) -#'WPD <- WindPowerDensity(wind) +#'wind <- array(rweibull(n = 32100, shape = 2, scale = 6), +#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'WPD <- WindPowerDensity(wind, dates = Dates, start = list(21, 4), +#' end = list(21, 6)) #' #'@export WindPowerDensity <- function(wind, ro = 1.225, dates = NULL, start = NULL, - end = NULL, time_dim = 'time', ncores = NULL) { + end = NULL, time_dim = 'ftime', ncores = NULL) { if (!is.null(dates)) { if (!is.null(start) && !is.null(end)) { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - wind <- SelectPeriodOnData(wind, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + wind <- SelectPeriodOnData(data = wind, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } return(0.5 * ro * wind^3) diff --git a/man/AccumulationExceedingThreshold.Rd b/man/AccumulationExceedingThreshold.Rd index 172592c..0f9a64a 100644 --- a/man/AccumulationExceedingThreshold.Rd +++ b/man/AccumulationExceedingThreshold.Rd @@ -39,9 +39,9 @@ c('>', '<='), c('>=', '<'),c('>=', '<=')).} between data and threshold (TRUE) or not (FALSE by default). It can only be TRUE if a unique threshold is used.} -\item{dates}{A vector of dates or a multidimensional array with of dates with -named dimensions matching the dimensions on parameter 'data'. By default it -is NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to define the initial date of the period to select from the data by providing a list of two elements: the initial @@ -86,12 +86,6 @@ function: # Assuming data is already (tasmax + tasmin)/2 - 10 data <- array(rnorm(5 * 3 * 214 * 2, mean = 25, sd = 3), c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), - as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), - as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), - as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), end = list(31, 10)) } diff --git a/man/CST_AccumulationExceedingThreshold.Rd b/man/CST_AccumulationExceedingThreshold.Rd index bc0eb83..f14c33b 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -63,7 +63,10 @@ computation.} \value{ An 's2dv_cube' object containing the aggregated values in the element \code{data} with dimensions of the input parameter 'data' except the dimension -where the indicator has been computed. +where the indicator has been computed. A new element called 'time_bounds' will +be added into the 'attrs' element in the 's2dv_cube' object. It consists of a +list containing two elements, the start and end dates of the aggregated period +with the same dimensions of 'Dates' element. } \description{ The accumulation (sum) of a variable in the days (or time steps) that the @@ -80,9 +83,19 @@ function: } \examples{ exp <- NULL -exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) +exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) class(exp) <- 's2dv_cube' -DOT <- CST_AccumulationExceedingThreshold(exp, threshold = 280) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +exp$attrs$Dates <- Dates +AT <- CST_AccumulationExceedingThreshold(data = exp, threshold = 100, + start = list(21, 4), + end = list(21, 6)) } diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index f9db984..d0e1ba8 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -59,19 +59,19 @@ this function: } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 6, ftime = 3)) -Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) dim(Dates) <- c(sdate = 4, ftime = 3) exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' -SA <- CST_PeriodMean(exp) +SA <- CST_PeriodMean(exp, start = list(01, 12), end = list(01, 01)) } diff --git a/man/CST_QThreshold.Rd b/man/CST_QThreshold.Rd index eda0fd1..5a68bc3 100644 --- a/man/CST_QThreshold.Rd +++ b/man/CST_QThreshold.Rd @@ -83,14 +83,18 @@ exp <- NULL exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, ftime = 2)) class(exp) <- 's2dv_cube' exp_probs <- CST_QThreshold(exp, threshold) -exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + +exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, ftime = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -exp_probs <- CST_QThreshold(exp, threshold) +dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +class(exp) <- 's2dv_cube' +exp_probs <- CST_QThreshold(exp, threshold, start = list(21, 4), + end = list(21, 6)) } diff --git a/man/CST_Threshold.Rd b/man/CST_Threshold.Rd index ffe0600..e513ec0 100644 --- a/man/CST_Threshold.Rd +++ b/man/CST_Threshold.Rd @@ -21,7 +21,7 @@ CST_Threshold( package CSTools.} \item{threshold}{A single scalar or vector indicating the relative -threshold(s).} +threshold(s). It must contain values between 0 and 1.} \item{start}{An optional parameter to defined the initial date of the period to selectfrom the data by providing a list of two elements: the initial date @@ -67,13 +67,14 @@ given a dataset. threshold <- 0.9 exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, ftime = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) class(exp) <- 's2dv_cube' exp_probs <- CST_Threshold(exp, threshold, start = list(21, 4), end = list(21, 6)) diff --git a/man/CST_TotalSpellTimeExceedingThreshold.Rd b/man/CST_TotalSpellTimeExceedingThreshold.Rd index e2f7d26..69dee16 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -56,7 +56,12 @@ computation.} } \value{ An 's2dv_cube' object containing the number of days that are part of a -spell within a threshold in element \code{data}. +spell within a threshold in element \code{data} with dimensions of the input +parameter 'data' except the dimension where the indicator has been computed. +A new element called 'time_bounds' will be added into the 'attrs' element in +the 's2dv_cube' object. It consists of a list containing two elements, the +start and end dates of the aggregated period with the same dimensions of +'Dates' element. } \description{ The number of days (when daily data is provided) that are part of a spell @@ -84,8 +89,11 @@ exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) class(exp) <- 's2dv_cube' -TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3) +TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3, + start = list(21, 4), + end = list(21, 6)) } \seealso{ diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index b09ae53..840700a 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -58,7 +58,10 @@ computation.} \value{ An 's2dv_cube' object containing in element \code{data} the total number of the corresponding units of the data frequency that a variable is -exceeding a threshold during a period. +exceeding a threshold during a period. A new element called 'time_bounds' will +be added into the 'attrs' element in the 's2dv_cube' object. It consists of a +list containing two elements, the start and end dates of the aggregated period +with the same dimensions of 'Dates' element. } \description{ The Total Time of a variable exceeding (or not) a Threshold. It returns the @@ -83,7 +86,7 @@ indices for heat stress can be obtained by using this function: } \examples{ exp <- NULL -exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*280), +exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, c(member = 5, sdate = 3, ftime = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), @@ -91,7 +94,9 @@ exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) class(exp) <- 's2dv_cube' -DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 280) +DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 23, start = list(21, 4), + end = list(21, 6)) } diff --git a/man/CST_WindCapacityFactor.Rd b/man/CST_WindCapacityFactor.Rd index 638f5b8..84c057d 100644 --- a/man/CST_WindCapacityFactor.Rd +++ b/man/CST_WindCapacityFactor.Rd @@ -60,14 +60,23 @@ below). \examples{ wind <- NULL wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), - c(member = 10, lat = 2, lon = 5)) + c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) wind$coords <- list(lat = c(40, 41), lon = 1:5) variable <- list(varName = 'sfcWind', metadata = list(sfcWind = list(level = 'Surface'))) wind$attrs <- list(Variable = variable, Datasets = 'synthetic', when = Sys.time(), Dates = '1990-01-01 00:00:00') +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +wind$attrs$Dates <- Dates class(wind) <- 's2dv_cube' -WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") +WCF <- CST_WindCapacityFactor(wind, IEC_class = "III", + start = list(21, 4), end = list(21, 6)) } \references{ diff --git a/man/CST_WindPowerDensity.Rd b/man/CST_WindPowerDensity.Rd index c33bd8d..4b04aed 100644 --- a/man/CST_WindPowerDensity.Rd +++ b/man/CST_WindPowerDensity.Rd @@ -14,8 +14,8 @@ CST_WindPowerDensity( ) } \arguments{ -\item{wind}{An s2dv_cube object with instantaneous wind speeds expressed in m/s -obtained from CST_Load or s2dv_cube functions from CSTools pacakge.} +\item{wind}{An 's2dv_cube' object with instantaneous wind speeds expressed in +m/s obtained from CST_Load or s2dv_cube functions from CSTools pacakge.} \item{ro}{A scalar, or alternatively a multidimensional array with the same dimensions as wind, with the air density expressed in kg/m^3. By default it @@ -53,14 +53,23 @@ it will give inaccurate results if used with period means. \examples{ wind <- NULL wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), - c(member = 10, lat = 2, lon = 5)) + c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) wind$coords <- list(lat = c(40, 41), lon = 1:5) variable <- list(varName = 'sfcWind', metadata = list(sfcWind = list(level = 'Surface'))) wind$attrs <- list(Variable = variable, Datasets = 'synthetic', when = Sys.time(), Dates = '1990-01-01 00:00:00') +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +wind$attrs$Dates <- Dates class(wind) <- 's2dv_cube' -WCF <- CST_WindPowerDensity(wind) +WPD <- CST_WindPowerDensity(wind, start = list(21, 4), + end = list(21, 6)) } \author{ diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 0f55937..614b65c 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -17,10 +17,9 @@ PeriodAccumulation( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{dates}{A multidimensional array of datesW with named dimensions matching -the dimensions on parameter 'data'. By default it is NULL, to select a -period this parameter must be provided and it needs to have temporal -dimensions.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/PeriodMean.Rd b/man/PeriodMean.Rd index fffb332..f52db40 100644 --- a/man/PeriodMean.Rd +++ b/man/PeriodMean.Rd @@ -17,9 +17,9 @@ PeriodMean( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/QThreshold.Rd b/man/QThreshold.Rd index 2af6e5f..ba023d8 100644 --- a/man/QThreshold.Rd +++ b/man/QThreshold.Rd @@ -10,7 +10,7 @@ QThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -23,9 +23,9 @@ QThreshold( units as parameter 'data' and with the common dimensions of the element 'data' of the same length.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -82,7 +82,17 @@ and memb_dim parameters: \examples{ threshold = 25 data <- array(rnorm(5 * 3 * 20 * 2, mean = 26), - c(member = 5, sdate = 3, time = 20, lon = 2)) -thres_q <- QThreshold(data, threshold) + c(member = 5, sdate = 3, time = 214, lon = 2)) + +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) + +thres_q <- QThreshold(data, threshold, dates = Dates, time_dim = 'time', + start = list(21, 4), end = list(21, 6)) } diff --git a/man/Threshold.Rd b/man/Threshold.Rd index db59817..d254cbe 100644 --- a/man/Threshold.Rd +++ b/man/Threshold.Rd @@ -10,7 +10,7 @@ Threshold( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", memb_dim = "member", sdate_dim = "sdate", na.rm = FALSE, @@ -21,11 +21,11 @@ Threshold( \item{data}{A multidimensional array with named dimensions.} \item{threshold}{A single scalar or vector indicating the relative -threshold(s).} +threshold(s). It must contain values between 0 and 1.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/TotalSpellTimeExceedingThreshold.Rd b/man/TotalSpellTimeExceedingThreshold.Rd index 276423b..10124de 100644 --- a/man/TotalSpellTimeExceedingThreshold.Rd +++ b/man/TotalSpellTimeExceedingThreshold.Rd @@ -36,9 +36,9 @@ are used it has to be a vector of a pair of two logical operators: c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -86,9 +86,19 @@ different behaviour consider to modify the 'data' input by substituting NA values by values exceeding the threshold. } \examples{ -data <- array(rnorm(120), c(member = 1, sdate = 2, ftime = 20, lat = 4)) -threshold <- array(rnorm(4), c(lat = 4)) -total <- TotalSpellTimeExceedingThreshold(data, threshold, spell = 6) +data <- array(1:100, c(member = 5, sdate = 3, ftime = 214, lon = 2)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) + +threshold <- array(1:4, c(lat = 4)) +total <- TotalSpellTimeExceedingThreshold(data, threshold, dates = Dates, + spell = 6, start = list(21, 4), + end = list(21, 6)) } \seealso{ diff --git a/man/TotalTimeExceedingThreshold.Rd b/man/TotalTimeExceedingThreshold.Rd index 2068475..4dc00d0 100644 --- a/man/TotalTimeExceedingThreshold.Rd +++ b/man/TotalTimeExceedingThreshold.Rd @@ -34,9 +34,9 @@ are used it has to be a vector of a pair of two logical operators: c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to define the initial date of the period to select from the data by providing a list of two elements: the initial @@ -62,7 +62,8 @@ computation.} \value{ A multidimensional array with named dimensions containing the total number of the corresponding units of the data frequency that a variable is -exceeding a threshold during a period. +exceeding a threshold during a period with dimensions of the input parameter +'data' except the dimension where the indicator has been computed. } \description{ The Total Time of a variable exceeding (or not) a Threshold. It returns the @@ -86,8 +87,16 @@ indices for heat stress can be obtained by using this function: } } \examples{ -exp <- array(abs(rnorm(5 * 3 * 214 * 2)*280), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) -DOT <- TotalTimeExceedingThreshold(exp, threshold = 300, time_dim = 'ftime') +data <- array(rnorm(5 * 3 * 214 * 2)*23, + c(member = 5, sdate = 3, ftime = 214, lon = 2)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +DOT <- TotalTimeExceedingThreshold(data, threshold = 23, dates = Dates, + start = list(21, 4), end = list(21, 6)) } diff --git a/man/WindCapacityFactor.Rd b/man/WindCapacityFactor.Rd index 69549a8..3ddeec6 100644 --- a/man/WindCapacityFactor.Rd +++ b/man/WindCapacityFactor.Rd @@ -10,7 +10,7 @@ WindCapacityFactor( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", ncores = NULL ) } @@ -25,9 +25,9 @@ respectively. Classes \code{'I/II'} and \code{'II/III'} indicate intermediate turbines that fit both classes. More details of the five turbines and a plot of its power curves can be found in Lledó et al. (2019).} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -65,8 +65,19 @@ different power curves that span different IEC classes can be selected (see below). } \examples{ -wind <- rweibull(n = 100, shape = 2, scale = 6) -WCF <- WindCapacityFactor(wind, IEC_class = "III") +wind <- array(rweibull(n = 32100, shape = 2, scale = 6), + c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) + +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) + +WCF <- WindCapacityFactor(wind, IEC_class = "III", dates = Dates, + start = list(21, 4), end = list(21, 6)) } \references{ diff --git a/man/WindPowerDensity.Rd b/man/WindPowerDensity.Rd index 8e3c8e3..9b935bc 100644 --- a/man/WindPowerDensity.Rd +++ b/man/WindPowerDensity.Rd @@ -10,7 +10,7 @@ WindPowerDensity( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", ncores = NULL ) } @@ -22,9 +22,9 @@ speeds expressed in m/s.} dimensions as wind, with the air density expressed in kg/m^3. By default it takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -57,8 +57,17 @@ It is computed as 0.5*ro*wspd^3. As this function is non-linear, it will give inaccurate results if used with period means. } \examples{ -wind <- rweibull(n = 100, shape = 2, scale = 6) -WPD <- WindPowerDensity(wind) +wind <- array(rweibull(n = 32100, shape = 2, scale = 6), + c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +WPD <- WindPowerDensity(wind, dates = Dates, start = list(21, 4), + end = list(21, 6)) } \author{ diff --git a/tests/testthat/test-AccumulationExceedingThreshold.R b/tests/testthat/test-AccumulationExceedingThreshold.R index 0331e8e..baa2c50 100644 --- a/tests/testthat/test-AccumulationExceedingThreshold.R +++ b/tests/testthat/test-AccumulationExceedingThreshold.R @@ -1,4 +1,7 @@ ############################################## + +library(CSTools) + # dat1 dat1 <- 1:20 @@ -234,7 +237,6 @@ test_that("4. Output checks", { }) ############################################## -library(CSTools) test_that("5. Seasonal forecasts", { exp <- CSTools::lonlat_temp$exp @@ -260,24 +262,25 @@ test_that("5. Seasonal forecasts", { as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) + dim(Dates) <- c(sdate = 3, ftime = 214) GDD <- AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime', start = list(1, 4), end = list(31, 10), na.rm = TRUE) expect_equal( round(GDD[,1,1,1]), - c(538, 367, 116, 519, 219, 282) + c(549, 387, 125, 554, 245, 282) ) expect_equal( dim(GDD), - c(member = 6, sdate = 3, lat =4, lon = 4) + c(member = 6, sdate = 3, lat = 4, lon = 4) ) expect_error( AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, start = list(1, 4), end = list(31, 10), time_dim = 'time'), "Parameter 'time_dim' is not found in 'data' dimension." ) expect_equal( - all(is.na(AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime',start = list(1, 4), end = list(31, 10)))), - all(is.na(c(NA, NA))) + !any(is.na(AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime',start = list(1, 4), end = list(31, 10)))), + !any(is.na(c(1, 1))) ) # test the 'diff' @@ -294,7 +297,6 @@ test_that("5. Seasonal forecasts", { AccumulationExceedingThreshold(input_1, threshold_1), 204 ) - expect_equal( AccumulationExceedingThreshold(input_2, threshold_2, op = '<'), -105 @@ -304,3 +306,47 @@ test_that("5. Seasonal forecasts", { -55 ) }) + +############################################## +test_that("6. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_AccumulationExceedingThreshold(data = exp, threshold = mean(exp$data), + time_dim = 'ftime', start = list(10, 03), + end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) diff --git a/tests/testthat/test-QThreshold.R b/tests/testthat/test-QThreshold.R index deb35df..3599bd9 100644 --- a/tests/testthat/test-QThreshold.R +++ b/tests/testthat/test-QThreshold.R @@ -1,5 +1,21 @@ + +library(CSTools) + +# dat1 +threshold <- 26 +dat1 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, ftime = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates1 <- dates0 +dim(dates1) <- c(sdate = 3, ftime = 214) + ############################################## -test_that("Sanity checks", { +test_that("1. Sanity checks", { expect_error( QThreshold(NULL), "Parameter 'data' cannot be NULL." @@ -104,13 +120,23 @@ test_that("Sanity checks", { dim(res), c(sdate = 3, ftime = 52) ) - + # test start and end + expect_warning( + QThreshold(dat1, threshold = 26, dates = dates0, start = list(21, 4), + end = list(21, 6)), + paste0("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(QThreshold(dat1, threshold = 26, dates = dates1, start = list(21, 4), + end = list(21, 6))), + c(sdate = 3, member = 5, ftime = 52, lon = 2) + ) }) ############################################## -library(CSTools) -test_that("Seasonal forecasts", { +test_that("2. Seasonal forecasts", { obs <- CSTools::lonlat_temp$obs$data - 248 obs_percentile <- QThreshold(obs, threshold = 35) expect_equal( @@ -142,3 +168,5 @@ test_that("Seasonal forecasts", { c(0.6, 0.4, 0.6, 0.6, 0.4, 0.4) ) }) + +############################################## diff --git a/tests/testthat/test-Threshold.R b/tests/testthat/test-Threshold.R index 84e4e0d..258e438 100644 --- a/tests/testthat/test-Threshold.R +++ b/tests/testthat/test-Threshold.R @@ -1,5 +1,21 @@ + +library(CSTools) + +# dat1 +threshold <- 0.9 +dat1 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, ftime = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates1 <- dates0 +dim(dates1) <- c(sdate = 3, ftime = 214) + ############################################## -test_that("Sanity checks", { +test_that("1. Sanity checks", { expect_error( Threshold(NULL), "Parameter 'data' cannot be NULL." @@ -60,9 +76,23 @@ test_that("Sanity checks", { dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), c(probs = 2) ) + # test start and end + expect_warning( + Threshold(dat1, threshold = 0.9, dates = dates0, start = list(21, 4), + end = list(21, 6)), + paste0("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(Threshold(dat1, threshold = 0.8, dates = dates1, start = list(21, 4), + end = list(21, 6))), + c(ftime = 52, lon = 2) + ) }) -test_that("Seasonal forecasts", { +############################################## + +test_that("2. Seasonal forecasts", { exp <- CSTools::lonlat_temp$exp$data thresholdP <- Threshold(exp, threshold = 0.9) expect_equal( diff --git a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R index 36e46cf..f76b457 100644 --- a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R @@ -240,7 +240,7 @@ test_that("4. Output checks", { }) -########################################################################### +################################################################## test_that("5. Seasonal Forecasts", { exp <- CSTools::lonlat_temp$exp @@ -263,3 +263,47 @@ test_that("5. Seasonal Forecasts", { WSDI1$data[3,3,3,], c(rep(0, 53))) }) + +################################################################## + +test_that("6. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMean(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) \ No newline at end of file diff --git a/tests/testthat/test-TotalTimeExceedingThreshold.R b/tests/testthat/test-TotalTimeExceedingThreshold.R index 1c3ca19..4a10b1b 100644 --- a/tests/testthat/test-TotalTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalTimeExceedingThreshold.R @@ -40,7 +40,7 @@ thres4_7 <- rnorm(5, 20) set.seed(2) thres4_8 <- rnorm(5, 25) -########################################################################### +############################################################# test_that("1. Sanity checks", { # data @@ -137,7 +137,7 @@ test_that("1. Sanity checks", { }) -########################################################################### +####################################################### test_that("2. Output checks", { expect_equal( @@ -231,7 +231,7 @@ test_that("4. Output checks", { ########################################################################### -test_that("Seasonal forecasts", { +test_that("5. Seasonal forecasts", { # compare with scalar fixed threshold exp <- CSTools::lonlat_temp$exp obs <- CSTools::lonlat_temp$obs @@ -252,3 +252,47 @@ test_that("Seasonal forecasts", { c(3, 3, 3, 3, 3, 3) ) }) + +################################################################## + +test_that("6. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMean(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) diff --git a/tests/testthat/test-WindCapacityFactor.R b/tests/testthat/test-WindCapacityFactor.R index bcecdbc..6fec014 100644 --- a/tests/testthat/test-WindCapacityFactor.R +++ b/tests/testthat/test-WindCapacityFactor.R @@ -12,7 +12,19 @@ wind$attrs <- list(Variable = variable, Datasets = 'synthetic', class(wind) <- 's2dv_cube' WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") -########################################################################### +# dat2 +dat2 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, ftime = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates2 <- dates0 +dim(dates2) <- c(sdate = 3, ftime = 214) + +################################################### test_that("1. Input checks", { # Check 's2dv_cube' expect_error( @@ -35,7 +47,7 @@ test_that("1. Input checks", { ) }) -########################################################################### +#################################################### test_that("2. Output checks", { expect_equal( CST_WindCapacityFactor(wind = wind)$attrs$Variable$varName, @@ -45,5 +57,17 @@ test_that("2. Output checks", { dim(CST_WindCapacityFactor(wind = wind)$data), c(member = 10, lat = 2, lon = 5) ) + # test start and end + expect_warning( + WindCapacityFactor(wind = dat2, IEC_class = "III", dates = dates0, + start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(WindCapacityFactor(wind = dat2, IEC_class = "III", dates = dates2, + start = list(21, 4), end = list(21, 6))), + c(member = 5, sdate = 3, ftime = 52, lon = 2) + ) }) diff --git a/tests/testthat/test-WindPowerDensity.R b/tests/testthat/test-WindPowerDensity.R index 184b062..a5abd4d 100644 --- a/tests/testthat/test-WindPowerDensity.R +++ b/tests/testthat/test-WindPowerDensity.R @@ -11,6 +11,18 @@ wind$attrs <- list(Variable = variable, Datasets = 'synthetic', when = Sys.time(), Dates = '1990-01-01 00:00:00') class(wind) <- 's2dv_cube' +# dat2 +dat2 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, ftime = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates2 <- dates0 +dim(dates2) <- c(sdate = 3, ftime = 214) + ########################################################################### test_that("1. Input checks", { # Check 's2dv_cube' @@ -44,5 +56,17 @@ test_that("2. Output checks", { dim(CST_WindPowerDensity(wind = wind)$data), c(member = 10, lat = 2, lon = 5) ) + # test start and end + expect_warning( + WindPowerDensity(wind = dat2, dates = dates0, + start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(WindPowerDensity(wind = dat2, dates = dates2, + start = list(21, 4), end = list(21, 6))), + c(member = 5, sdate = 3, ftime = 52, lon = 2) + ) }) -- GitLab From e9f952eedfad50a9fa796428d816078bbe1787bc Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 20 Jun 2023 09:51:45 +0200 Subject: [PATCH 20/87] Improve output description in documentation --- R/AccumulationExceedingThreshold.R | 1 + R/PeriodAccumulation.R | 10 ++++++---- R/PeriodMean.R | 10 ++++++---- R/TotalTimeExceedingThreshold.R | 10 ++++++---- man/CST_PeriodAccumulation.Rd | 10 ++++++---- man/CST_PeriodMean.Rd | 10 ++++++---- man/CST_TotalTimeExceedingThreshold.Rd | 10 ++++++---- 7 files changed, 37 insertions(+), 24 deletions(-) diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index d3c7147..636b211 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -53,6 +53,7 @@ #'be added into the 'attrs' element in the 's2dv_cube' object. It consists of a #'list containing two elements, the start and end dates of the aggregated period #'with the same dimensions of 'Dates' element. +#' #'@examples #'exp <- NULL #'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index c8e976e..9bd33e5 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -31,10 +31,12 @@ #' computation. #' #'@return A 's2dv_cube' object containing the indicator in the element -#'\code{data}. A new element called 'time_bounds' will be added into -#' the 'attrs' element in the 's2dv_cube' object. It consists of a list -#' containing two elements, the start and end dates of the aggregated period -#' with the same dimensions of 'Dates' element. +#'\code{data} with dimensions of the input parameter 'data' except the dimension +#'where the accumulation has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. #' #'@examples #'exp <- NULL diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 6acea60..3e7619d 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -31,10 +31,12 @@ #' computation. #' #'@return An 's2dv_cube' object containing the indicator in the element -#' \code{data}. A new element called 'time_bounds' will be added into -#' the 'attrs' element in the 's2dv_cube' object. It consists of a list -#' containing two elements, the start and end dates of the aggregated period -#' with the same dimensions of 'Dates' element. +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the mean has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. #' #'@examples #'exp <- NULL diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index 49fa988..057bb8b 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -54,10 +54,12 @@ #' #'@return An 's2dv_cube' object containing in element \code{data} the total #'number of the corresponding units of the data frequency that a variable is -#'exceeding a threshold during a period. A new element called 'time_bounds' will -#'be added into the 'attrs' element in the 's2dv_cube' object. It consists of a -#'list containing two elements, the start and end dates of the aggregated period -#'with the same dimensions of 'Dates' element. +#'exceeding a threshold during a period with dimensions of the input parameter +#''data' except the dimension where the indicator has been computed. A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. #' #'@examples #'exp <- NULL diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 71122d6..0878399 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -41,10 +41,12 @@ computation.} } \value{ A 's2dv_cube' object containing the indicator in the element -\code{data}. A new element called 'time_bounds' will be added into - the 'attrs' element in the 's2dv_cube' object. It consists of a list - containing two elements, the start and end dates of the aggregated period - with the same dimensions of 'Dates' element. +\code{data} with dimensions of the input parameter 'data' except the dimension +where the accumulation has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index d0e1ba8..025acfd 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -41,10 +41,12 @@ computation.} } \value{ An 's2dv_cube' object containing the indicator in the element - \code{data}. A new element called 'time_bounds' will be added into - the 'attrs' element in the 's2dv_cube' object. It consists of a list - containing two elements, the start and end dates of the aggregated period - with the same dimensions of 'Dates' element. +\code{data} with dimensions of the input parameter 'data' except the +dimension where the mean has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. } \description{ Period Mean computes the average (mean) of a given variable in a period. diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index 840700a..2449014 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -58,10 +58,12 @@ computation.} \value{ An 's2dv_cube' object containing in element \code{data} the total number of the corresponding units of the data frequency that a variable is -exceeding a threshold during a period. A new element called 'time_bounds' will -be added into the 'attrs' element in the 's2dv_cube' object. It consists of a -list containing two elements, the start and end dates of the aggregated period -with the same dimensions of 'Dates' element. +exceeding a threshold during a period with dimensions of the input parameter +'data' except the dimension where the indicator has been computed. A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. } \description{ The Total Time of a variable exceeding (or not) a Threshold. It returns the -- GitLab From 292e1e2d1aeaf8c7ec5e27009ef897334c83563c Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 10:25:46 +0200 Subject: [PATCH 21/87] Update time_dim and improve example --- R/PeriodAccumulation.R | 2 +- R/PeriodMean.R | 15 ++++++++++++--- man/PeriodAccumulation.Rd | 2 +- man/PeriodMean.Rd | 15 ++++++++++++--- 4 files changed, 26 insertions(+), 8 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 9bd33e5..8f1fb7f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -168,7 +168,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 3e7619d..3b1cf7f 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -146,13 +146,22 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'indicator in the element \code{data}. #' #'@examples -#'exp <- array(rnorm(56), dim = c(member = 7, ftime = 8)) -#'SA <- PeriodMean(exp, time_dim = 'ftime') +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'SA <- PeriodMean(data, dates = Dates, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply #'@export PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, ncores = NULL) { + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 614b65c..0260648 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -9,7 +9,7 @@ PeriodAccumulation( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", na.rm = FALSE, ncores = NULL ) diff --git a/man/PeriodMean.Rd b/man/PeriodMean.Rd index f52db40..d02a0ab 100644 --- a/man/PeriodMean.Rd +++ b/man/PeriodMean.Rd @@ -9,7 +9,7 @@ PeriodMean( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", na.rm = FALSE, ncores = NULL ) @@ -59,7 +59,16 @@ this function: } } \examples{ -exp <- array(rnorm(56), dim = c(member = 7, ftime = 8)) -SA <- PeriodMean(exp, time_dim = 'ftime') +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +SA <- PeriodMean(data, dates = Dates, start = list(01, 12), end = list(01, 01)) } -- GitLab From 9eb3e4aecb2444fc1a3b6771b835633b11d6b90e Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 11:27:51 +0200 Subject: [PATCH 22/87] Improve check when start and end are provided but dates is NULL; add test for this --- R/PeriodAccumulation.R | 8 ++++++-- R/PeriodMean.R | 13 +++++++------ R/QThreshold.R | 9 +++++++-- R/Threshold.R | 8 ++++++-- R/TotalSpellTimeExceedingThreshold.R | 7 +++++-- R/TotalTimeExceedingThreshold.R | 7 +++++-- R/WindCapacityFactor.R | 8 ++++++-- R/WindPowerDensity.R | 8 ++++++-- tests/testthat/test-PeriodAccumulation.R | 11 +++++++++-- tests/testthat/test-PeriodMean.R | 16 ++++++++++++---- tests/testthat/test-QThreshold.R | 7 +++++++ tests/testthat/test-Threshold.R | 7 +++++++ .../test-TotalSpellTimeExceedingThreshold.R | 7 +++++++ .../testthat/test-TotalTimeExceedingThreshold.R | 7 +++++++ tests/testthat/test-WindCapacityFactor.R | 7 +++++++ tests/testthat/test-WindPowerDensity.R | 7 +++++++ 16 files changed, 111 insertions(+), 26 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 8f1fb7f..965534f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -180,8 +180,12 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, dim(data) <- length(data) names(dim(data)) <- time_dim } - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 3b1cf7f..fd8fd7a 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -173,13 +173,14 @@ PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, dim(data) <- length(data) names(data) <- time_dim } - if (is.null(dates)) { - warning("Parameter 'dates' is NULL and the Average of the ", - "full data provided in 'data' is computed.") - } else { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { - stop("Parameter 'start' and 'end' must be lists indicating the ", + stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } if (!is.null(dim(dates))) { diff --git a/R/QThreshold.R b/R/QThreshold.R index 0d069bb..c39a14b 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -217,8 +217,12 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (is.null(memb_dim)) { memb_dim <- 99999 } - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") @@ -244,6 +248,7 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, } } } + if (length(threshold) == 1) { if (memb_dim %in% names(dim(data))) { probs <- Apply(list(data), target_dims = c(memb_dim, sdate_dim), diff --git a/R/Threshold.R b/R/Threshold.R index d76cbfa..b4e9638 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -157,8 +157,12 @@ Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (is.null(names(dim(data)))) { stop("Parameter 'data' must have named dimensions.") } - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index 5d649b4..5cf2e1d 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -352,8 +352,11 @@ TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', } } # dates - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index 057bb8b..8a8b7ed 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -351,8 +351,11 @@ TotalTimeExceedingThreshold <- function(data, threshold, op = '>', } } # dates - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index 906ade3..7f32139 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -175,8 +175,12 @@ WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", ) pc_file <- system.file("power_curves", pc_files[IEC_class], package = "CSIndicators", mustWork = T) pc <- read_pc(pc_file) - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index e9c70f6..181e509 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -136,8 +136,12 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #'@export WindPowerDensity <- function(wind, ro = 1.225, dates = NULL, start = NULL, end = NULL, time_dim = 'ftime', ncores = NULL) { - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 74bb45d..6898a93 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -27,20 +27,27 @@ test_that("1. Sanity Checks", { PeriodAccumulation(1:10), 55 ) - data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) expect_equal( PeriodAccumulation(data), array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4)) ) # Test dates warning expect_warning( - PeriodAccumulation(array(1:10, c(time = 10)), + PeriodAccumulation(array(1:10, c(ftime = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", "are not NULL. All data will be used.") ) + # start and end when dates is not provided + expect_warning( + PeriodAccumulation(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ############################################## diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index 18b5995..cd9f5fe 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -18,14 +18,15 @@ test_that("1. Sanity Checks", { ) expect_error( PeriodMean(1, dates = '2000-01-01', end = 3, start = 4), - "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end.") + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) suppressWarnings( expect_equal( - PeriodMean(array(1:10, c(time = 10))), + PeriodMean(array(1:10, c(ftime = 10))), 5.5 ) ) - data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) suppressWarnings( expect_equal( PeriodMean(data), @@ -35,13 +36,20 @@ test_that("1. Sanity Checks", { ) # Test dates warning expect_warning( - PeriodMean(array(1:10, c(time = 10)), + PeriodMean(array(1:10, c(ftime = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", "are not NULL. All data will be used.") ) + # start and end when dates is not provided + expect_warning( + PeriodMean(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ############################################## diff --git a/tests/testthat/test-QThreshold.R b/tests/testthat/test-QThreshold.R index 3599bd9..57883b1 100644 --- a/tests/testthat/test-QThreshold.R +++ b/tests/testthat/test-QThreshold.R @@ -132,6 +132,13 @@ test_that("1. Sanity checks", { end = list(21, 6))), c(sdate = 3, member = 5, ftime = 52, lon = 2) ) + # start and end when dates is not provided + expect_warning( + QThreshold(array(1:61, dim = c(ftime = 61, sdate = 3)), threshold = 25, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ############################################## diff --git a/tests/testthat/test-Threshold.R b/tests/testthat/test-Threshold.R index 258e438..7cb83cf 100644 --- a/tests/testthat/test-Threshold.R +++ b/tests/testthat/test-Threshold.R @@ -88,6 +88,13 @@ test_that("1. Sanity checks", { end = list(21, 6))), c(ftime = 52, lon = 2) ) + # start and end when dates is not provided + expect_warning( + Threshold(array(1:366, dim = c(ftime = 61, sdate = 3, member = 2)), + threshold = 0.8, start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ############################################## diff --git a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R index f76b457..b66c5ae 100644 --- a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R @@ -142,6 +142,13 @@ test_that("1. Sanity checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + TotalSpellTimeExceedingThreshold(array(1:10, c(ftime = 10)), threshold = 5, spell = 2, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ########################################################################### diff --git a/tests/testthat/test-TotalTimeExceedingThreshold.R b/tests/testthat/test-TotalTimeExceedingThreshold.R index 4a10b1b..c025c3e 100644 --- a/tests/testthat/test-TotalTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalTimeExceedingThreshold.R @@ -134,6 +134,13 @@ test_that("1. Sanity checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + TotalTimeExceedingThreshold(array(1:10, c(ftime = 10)), threshold = 5, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) diff --git a/tests/testthat/test-WindCapacityFactor.R b/tests/testthat/test-WindCapacityFactor.R index 6fec014..3afa27e 100644 --- a/tests/testthat/test-WindCapacityFactor.R +++ b/tests/testthat/test-WindCapacityFactor.R @@ -45,6 +45,13 @@ test_that("1. Input checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + WindCapacityFactor(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) #################################################### diff --git a/tests/testthat/test-WindPowerDensity.R b/tests/testthat/test-WindPowerDensity.R index a5abd4d..999235a 100644 --- a/tests/testthat/test-WindPowerDensity.R +++ b/tests/testthat/test-WindPowerDensity.R @@ -44,6 +44,13 @@ test_that("1. Input checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + WindPowerDensity(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ########################################################################### -- GitLab From 8777fc856ee4baff0106f407110a3aadbdf5245d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 16:11:11 +0200 Subject: [PATCH 23/87] Add return to PeriodMean --- R/PeriodMean.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/PeriodMean.R b/R/PeriodMean.R index fd8fd7a..2a85ceb 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -195,6 +195,7 @@ PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, } total <- Apply(list(data), target_dims = time_dim, fun = mean, na.rm = na.rm, ncores = ncores)$output1 + return(total) } -- GitLab From 18c77dfe194af21ea7f877dbde1f3b19215538dd Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 16:28:29 +0200 Subject: [PATCH 24/87] Add functions to compute bioclimatic indicators; add unit tests --- R/PeriodFun.R | 190 +++++++++++++++++++++++ R/PeriodMax.R | 205 +++++++++++++++++++++++++ R/PeriodMin.R | 205 +++++++++++++++++++++++++ R/PeriodVariance.R | 219 +++++++++++++++++++++++++++ tests/testthat/test-PeriodFun.R | 120 +++++++++++++++ tests/testthat/test-PeriodMax.R | 123 +++++++++++++++ tests/testthat/test-PeriodMin.R | 119 +++++++++++++++ tests/testthat/test-PeriodVariance.R | 118 +++++++++++++++ 8 files changed, 1299 insertions(+) create mode 100644 R/PeriodFun.R create mode 100644 R/PeriodMax.R create mode 100644 R/PeriodMin.R create mode 100644 R/PeriodVariance.R create mode 100644 tests/testthat/test-PeriodFun.R create mode 100644 tests/testthat/test-PeriodMax.R create mode 100644 tests/testthat/test-PeriodMin.R create mode 100644 tests/testthat/test-PeriodVariance.R diff --git a/R/PeriodFun.R b/R/PeriodFun.R new file mode 100644 index 0000000..9c33ba2 --- /dev/null +++ b/R/PeriodFun.R @@ -0,0 +1,190 @@ +#'Period Function on 's2dv_cube' objects +#' +#'Period Fun computes a calculation of a given variable in a period. +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in +#' package CSTools. +#'@param fun An atomic function to compute a calculation over a period. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the mean has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'SA <- CST_PeriodFun(exp, fun = mean, start = list(01, 12), +#' end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodFun <- function(data, fun, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodFun(data = data$data, fun = fun, dates = Dates, start = start, + end = end, time_dim = time_dim, na.rm = na.rm, + ncores = ncores) + + data$data <- total + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period Function on multidimensional array objects +#' +#'Period Fun computes a calculation of a given variable in a period. +#' +#'@param data A multidimensional array with named dimensions. +#'@param fun An atomic function to compute a calculation over a period. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'SA <- PeriodFun(data, fun = mean, dates = Dates, start = list(01, 12), +#' end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodFun <- function(data, fun, dates = NULL, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(data) <- time_dim + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, fun = fun, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + + diff --git a/R/PeriodMax.R b/R/PeriodMax.R new file mode 100644 index 0000000..0d47033 --- /dev/null +++ b/R/PeriodMax.R @@ -0,0 +1,205 @@ +#'Period Max on 's2dv_cube' objects +#' +#'Period Max computes the maximum (max) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest +#' Month. The maximum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years +#' (normal).} +#' \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest +#' Month. This index identifies the total precipitation +#' that prevails during the wettest month.} +#'} +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in +#' package CSTools. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the max has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'res <- CST_PeriodMax(exp, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodMax <- function(data, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodMax(data = data$data, dates = Dates, start = start, end = end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + data$data <- total + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period max on multidimensional array objects +#' +#'Period max computes the average (max) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest +#' Month. The maximum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years +#' (normal).} +#' \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest +#' Month. This index identifies the total precipitation +#' that prevails during the wettest month.} +#'} +#' +#'@param data A multidimensional array with named dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'res <- PeriodMax(data, dates = Dates, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodMax <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(data) <- time_dim + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, fun = max, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + + diff --git a/R/PeriodMin.R b/R/PeriodMin.R new file mode 100644 index 0000000..f5ea5b0 --- /dev/null +++ b/R/PeriodMin.R @@ -0,0 +1,205 @@ +#'Period Min on 's2dv_cube' objects +#' +#'Period Min computes the average (min) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest +#' Month. The minimum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years +#' (normal).} +#' \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest +#' Month. This index identifies the total precipitation +#' that prevails during the driest month.} +#'} +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in +#' package CSTools. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the min has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'res <- CST_PeriodMin(exp, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodMin <- function(data, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodMin(data = data$data, dates = Dates, start = start, end = end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + data$data <- total + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period Min on multidimensional array objects +#' +#'Period Min computes the average (min) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest +#' Month. The minimum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years +#' (normal).} +#' \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest +#' Month. This index identifies the total precipitation +#' that prevails during the driest month.} +#'} +#' +#'@param data A multidimensional array with named dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'res <- PeriodMin(data, dates = Dates, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodMin <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(data) <- time_dim + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, fun = min, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + + diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R new file mode 100644 index 0000000..b9f3cff --- /dev/null +++ b/R/PeriodVariance.R @@ -0,0 +1,219 @@ +#'Period Variance on 's2dv_cube' objects +#' +#'Period Variance computes the average (var) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item\code{BIO4}{(Providing temperature data) Temperature Seasonality +#' (Standard Deviation). The amount of temperature variation +#' over a given year (or averaged years) based on the standard +#' deviation (variation) of monthly temperature averages. } +#' \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality +#' (CV). This is a measure of the variation in +#' monthly precipitation totals over the course of the year. +#' This index is the ratio of the standard deviation of the +#' monthly total precipitation to the mean monthly total +#' precipitation (also known as the coefficient of variation) +#' and is expressed as a percentage} +#'} +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in +#' package CSTools. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the var has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'res <- CST_PeriodVariance(exp, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodVariance <- function(data, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodVariance(data = data$data, dates = Dates, start = start, end = end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + data$data <- total + data$dims <- dim(total) + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period Variance on multidimensional array objects +#' +#'Period Variance computes the average (var) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item\code{BIO4}{(Providing temperature data) Temperature Seasonality +#' (Standard Deviation). The amount of temperature variation +#' over a given year (or averaged years) based on the standard +#' deviation (variation) of monthly temperature averages. } +#' \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality +#' (CV). This is a measure of the variation in +#' monthly precipitation totals over the course of the year. +#' This index is the ratio of the standard deviation of the +#' monthly total precipitation to the mean monthly total +#' precipitation (also known as the coefficient of variation) +#' and is expressed as a percentage} +#'} +#' +#'@param data A multidimensional array with named dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'ftime'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'res <- PeriodVariance(data, dates = Dates, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodVariance <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(data) <- time_dim + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, + fun = .periodvariance, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + +.periodvariance <- function(data, na.rm) { + var <- sum((data - mean(data, na.rm = na.rm))^2) / (length(data)-1) + return(var) +} + + diff --git a/tests/testthat/test-PeriodFun.R b/tests/testthat/test-PeriodFun.R new file mode 100644 index 0000000..c743aee --- /dev/null +++ b/tests/testthat/test-PeriodFun.R @@ -0,0 +1,120 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + expect_error( + PeriodFun('x'), + "Parameter 'data' must be numeric." + ) + suppressWarnings( + expect_equal( + PeriodFun(array(1, c(x = 1)), fun = mean, time_dim = 'x'), + 1 + ) + ) + expect_error( + PeriodFun(data = NULL, fun = mean), + "Parameter 'data' cannot be NULL." + ) + expect_error( + PeriodFun(1, fun = mean, dates = '2000-01-01', end = 3, start = 4), + paste0("Parameter 'start' and 'end' must be lists indicating the day ", + "and the month of the period start and end.") + ) + expect_equal( + PeriodFun(array(1:10, c(ftime = 10)), fun = mean), + 5.5 + ) + data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + expect_equal( + PeriodFun(data, fun = min), + array(c(1, 2, 7, 8, 13, 14, 19, 20), + c(sdate = 2, lon = 4)) + ) + # Test dates warning + expect_warning( + PeriodFun(array(1:10, c(ftime = 10)), fun = mean, + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodFun(array(1:10, c(ftime = 10)), fun = sum, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(min(exp$data[1,1,21:82,1]), min(exp$data[1,2,21:82,1]), + min(exp$data[1,3,21:82,1]), min(exp$data[1,1,21:82,2]), + min(exp$data[1,2,21:82,2]), min(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodFun(exp, fun = min, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodFun(data = CSTools::lonlat_prec, fun = min, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-PeriodMax.R b/tests/testthat/test-PeriodMax.R new file mode 100644 index 0000000..967b086 --- /dev/null +++ b/tests/testthat/test-PeriodMax.R @@ -0,0 +1,123 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + expect_error( + PeriodMax('x'), + "Parameter 'data' must be numeric." + ) + suppressWarnings( + expect_equal( + PeriodMax(array(1, c(x = 1)), time_dim = 'x'), + 1 + ) + ) + expect_error( + PeriodMax(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + PeriodMax(1, dates = '2000-01-01', end = 3, start = 4), + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) + suppressWarnings( + expect_equal( + PeriodMax(array(1:10, c(ftime = 10))), + 10 + ) + ) + data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + suppressWarnings( + expect_equal( + PeriodMax(data), + array(c(5, 6, 11, 12, 17, 18, 23, 24), + c(sdate = 2, lon = 4)) + ) + ) + # Test dates warning + expect_warning( + PeriodMax(array(1:10, c(ftime = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodMax(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(max(exp$data[1,1,21:82,1]), max(exp$data[1,2,21:82,1]), + max(exp$data[1,3,21:82,1]), max(exp$data[1,1,21:82,2]), + max(exp$data[1,2,21:82,2]), max(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodMax(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMax(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-PeriodMin.R b/tests/testthat/test-PeriodMin.R new file mode 100644 index 0000000..da91a3c --- /dev/null +++ b/tests/testthat/test-PeriodMin.R @@ -0,0 +1,119 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + expect_error( + PeriodMin('x'), + "Parameter 'data' must be numeric." + ) + suppressWarnings( + expect_equal( + PeriodMin(array(1, c(x = 1)), time_dim = 'x'), + 1 + ) + ) + expect_error( + PeriodMin(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + PeriodMin(1, dates = '2000-01-01', end = 3, start = 4), + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) + expect_equal( + PeriodMin(array(1:10, c(ftime = 10))), + 1 + ) + data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + expect_equal( + PeriodMin(data), + array(c(1, 2, 7, 8, 13, 14, 19, 20), + c(sdate = 2, lon = 4)) + ) + # Test dates warning + expect_warning( + PeriodMin(array(1:10, c(ftime = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodMin(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(min(exp$data[1,1,21:82,1]), min(exp$data[1,2,21:82,1]), + min(exp$data[1,3,21:82,1]), min(exp$data[1,1,21:82,2]), + min(exp$data[1,2,21:82,2]), min(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodMin(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMin(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-PeriodVariance.R b/tests/testthat/test-PeriodVariance.R new file mode 100644 index 0000000..1ac78c1 --- /dev/null +++ b/tests/testthat/test-PeriodVariance.R @@ -0,0 +1,118 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + expect_error( + PeriodVariance('x'), + "Parameter 'data' must be numeric." + ) + expect_equal( + PeriodVariance(array(1:2, c(x = 2)), time_dim = 'x'), + 0.5 + ) + expect_error( + PeriodVariance(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + PeriodVariance(1, dates = '2000-01-01', end = 3, start = 4), + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) + expect_equal( + PeriodVariance(array(1:10, c(ftime = 10))), + 9.166667, + tolerance = 0.001 + ) + data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + expect_equal( + PeriodVariance(data), + array(rep(4, 8), + c(sdate = 2, lon = 4)) + ) + # Test dates warning + expect_warning( + PeriodVariance(array(1:10, c(ftime = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodVariance(array(1:10, c(ftime = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(var(exp$data[1,1,21:82,1]), var(exp$data[1,2,21:82,1]), + var(exp$data[1,3,21:82,1]), var(exp$data[1,1,21:82,2]), + var(exp$data[1,2,21:82,2]), var(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodVariance(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodVariance(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + -- GitLab From 5fcc11fad521548fba24eca96d3581699dab00ea Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 16:29:40 +0200 Subject: [PATCH 25/87] Update documentation --- NAMESPACE | 9 +++++ man/CST_PeriodFun.Rd | 75 ++++++++++++++++++++++++++++++++++ man/CST_PeriodMax.Rd | 81 +++++++++++++++++++++++++++++++++++++ man/CST_PeriodMin.Rd | 81 +++++++++++++++++++++++++++++++++++++ man/CST_PeriodVariance.Rd | 85 +++++++++++++++++++++++++++++++++++++++ man/PeriodFun.Rd | 70 ++++++++++++++++++++++++++++++++ man/PeriodMax.Rd | 76 ++++++++++++++++++++++++++++++++++ man/PeriodMin.Rd | 76 ++++++++++++++++++++++++++++++++++ man/PeriodVariance.Rd | 80 ++++++++++++++++++++++++++++++++++++ 9 files changed, 633 insertions(+) create mode 100644 man/CST_PeriodFun.Rd create mode 100644 man/CST_PeriodMax.Rd create mode 100644 man/CST_PeriodMin.Rd create mode 100644 man/CST_PeriodVariance.Rd create mode 100644 man/PeriodFun.Rd create mode 100644 man/PeriodMax.Rd create mode 100644 man/PeriodMin.Rd create mode 100644 man/PeriodVariance.Rd diff --git a/NAMESPACE b/NAMESPACE index d80accb..f02cee5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,11 @@ export(CST_AbsToProbs) export(CST_AccumulationExceedingThreshold) export(CST_MergeRefToExp) export(CST_PeriodAccumulation) +export(CST_PeriodFun) +export(CST_PeriodMax) export(CST_PeriodMean) +export(CST_PeriodMin) +export(CST_PeriodVariance) export(CST_QThreshold) export(CST_SelectPeriodOnData) export(CST_Threshold) @@ -16,7 +20,11 @@ export(CST_WindCapacityFactor) export(CST_WindPowerDensity) export(MergeRefToExp) export(PeriodAccumulation) +export(PeriodFun) +export(PeriodMax) export(PeriodMean) +export(PeriodMin) +export(PeriodVariance) export(QThreshold) export(SelectPeriodOnData) export(SelectPeriodOnDates) @@ -26,6 +34,7 @@ export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) import(multiApply) +importFrom(ClimProjDiags,Subset) importFrom(stats,approxfun) importFrom(stats,ecdf) importFrom(stats,quantile) diff --git a/man/CST_PeriodFun.Rd b/man/CST_PeriodFun.Rd new file mode 100644 index 0000000..1ffe32b --- /dev/null +++ b/man/CST_PeriodFun.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodFun.R +\name{CST_PeriodFun} +\alias{CST_PeriodFun} +\title{Period Function on 's2dv_cube' objects} +\usage{ +CST_PeriodFun( + data, + fun, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in +package CSTools.} + +\item{fun}{An atomic function to compute a calculation over a period.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the mean has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Fun computes a calculation of a given variable in a period. +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +SA <- CST_PeriodFun(exp, fun = mean, start = list(01, 12), + end = list(01, 01)) + +} diff --git a/man/CST_PeriodMax.Rd b/man/CST_PeriodMax.Rd new file mode 100644 index 0000000..02a4a8a --- /dev/null +++ b/man/CST_PeriodMax.Rd @@ -0,0 +1,81 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMax.R +\name{CST_PeriodMax} +\alias{CST_PeriodMax} +\title{Period Max on 's2dv_cube' objects} +\usage{ +CST_PeriodMax( + data, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in +package CSTools.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the max has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Max computes the maximum (max) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest + Month. The maximum monthly temperature occurrence over a + given year (time-series) or averaged span of years + (normal).} + \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest + Month. This index identifies the total precipitation + that prevails during the wettest month.} +} +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +res <- CST_PeriodMax(exp, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/CST_PeriodMin.Rd b/man/CST_PeriodMin.Rd new file mode 100644 index 0000000..7076ccd --- /dev/null +++ b/man/CST_PeriodMin.Rd @@ -0,0 +1,81 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMin.R +\name{CST_PeriodMin} +\alias{CST_PeriodMin} +\title{Period Min on 's2dv_cube' objects} +\usage{ +CST_PeriodMin( + data, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in +package CSTools.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the min has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Min computes the average (min) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest + Month. The minimum monthly temperature occurrence over a + given year (time-series) or averaged span of years + (normal).} + \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest + Month. This index identifies the total precipitation + that prevails during the driest month.} +} +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +res <- CST_PeriodMin(exp, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/CST_PeriodVariance.Rd b/man/CST_PeriodVariance.Rd new file mode 100644 index 0000000..fa68197 --- /dev/null +++ b/man/CST_PeriodVariance.Rd @@ -0,0 +1,85 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodVariance.R +\name{CST_PeriodVariance} +\alias{CST_PeriodVariance} +\title{Period Variance on 's2dv_cube' objects} +\usage{ +CST_PeriodVariance( + data, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in +package CSTools.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the var has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Variance computes the average (var) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item\code{BIO4}{(Providing temperature data) Temperature Seasonality + (Standard Deviation). The amount of temperature variation + over a given year (or averaged years) based on the standard + deviation (variation) of monthly temperature averages. } + \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality + (CV). This is a measure of the variation in + monthly precipitation totals over the course of the year. + This index is the ratio of the standard deviation of the + monthly total precipitation to the mean monthly total + precipitation (also known as the coefficient of variation) + and is expressed as a percentage} +} +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +res <- CST_PeriodVariance(exp, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/PeriodFun.Rd b/man/PeriodFun.Rd new file mode 100644 index 0000000..9378273 --- /dev/null +++ b/man/PeriodFun.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodFun.R +\name{PeriodFun} +\alias{PeriodFun} +\title{Period Function on multidimensional array objects} +\usage{ +PeriodFun( + data, + fun, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{fun}{An atomic function to compute a calculation over a period.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period Fun computes a calculation of a given variable in a period. +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +SA <- PeriodFun(data, fun = mean, dates = Dates, start = list(01, 12), + end = list(01, 01)) + +} diff --git a/man/PeriodMax.Rd b/man/PeriodMax.Rd new file mode 100644 index 0000000..26e62a4 --- /dev/null +++ b/man/PeriodMax.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMax.R +\name{PeriodMax} +\alias{PeriodMax} +\title{Period max on multidimensional array objects} +\usage{ +PeriodMax( + data, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period max computes the average (max) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest + Month. The maximum monthly temperature occurrence over a + given year (time-series) or averaged span of years + (normal).} + \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest + Month. This index identifies the total precipitation + that prevails during the wettest month.} +} +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +res <- PeriodMax(data, dates = Dates, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/PeriodMin.Rd b/man/PeriodMin.Rd new file mode 100644 index 0000000..72d6c78 --- /dev/null +++ b/man/PeriodMin.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMin.R +\name{PeriodMin} +\alias{PeriodMin} +\title{Period Min on multidimensional array objects} +\usage{ +PeriodMin( + data, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period Min computes the average (min) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest + Month. The minimum monthly temperature occurrence over a + given year (time-series) or averaged span of years + (normal).} + \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest + Month. This index identifies the total precipitation + that prevails during the driest month.} +} +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +res <- PeriodMin(data, dates = Dates, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/PeriodVariance.Rd b/man/PeriodVariance.Rd new file mode 100644 index 0000000..be4a243 --- /dev/null +++ b/man/PeriodVariance.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodVariance.R +\name{PeriodVariance} +\alias{PeriodVariance} +\title{Period Variance on multidimensional array objects} +\usage{ +PeriodVariance( + data, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "ftime", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'ftime'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period Variance computes the average (var) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item\code{BIO4}{(Providing temperature data) Temperature Seasonality + (Standard Deviation). The amount of temperature variation + over a given year (or averaged years) based on the standard + deviation (variation) of monthly temperature averages. } + \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality + (CV). This is a measure of the variation in + monthly precipitation totals over the course of the year. + This index is the ratio of the standard deviation of the + monthly total precipitation to the mean monthly total + precipitation (also known as the coefficient of variation) + and is expressed as a percentage} +} +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, ftime = 3) +res <- PeriodVariance(data, dates = Dates, start = list(01, 12), end = list(01, 01)) + +} -- GitLab From 3adf7275da5a2eb200dea5a9c210606e4f330295 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 18:08:24 +0200 Subject: [PATCH 26/87] Include publication in README and DESCRIPTION --- DESCRIPTION | 4 ++-- README.md | 6 +++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4151ba4..a05a3b5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,7 +22,7 @@ Description: Set of generalised tools for the flexible computation of climate provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with 'CSTools'. This package was developed in the context of H2020 MED-GOLD (776467) and - S2S4E (776787) projects. Lledó et al. (2019) . + S2S4E (776787) projects. Lledó et al. (2019) . Pérez-Zanón et al. (2023) . Depends: R (>= 3.6.0) Imports: @@ -40,4 +40,4 @@ URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 RoxygenNote: 7.2.0 -Config/testthat/edition: 3 \ No newline at end of file +Config/testthat/edition: 3 diff --git a/README.md b/README.md index 5521a51..6607398 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,11 @@ CSIndicators #### Sectoral Indicators for Climate Services Based on Sub-Seasonal to Decadal Climate Predictions -Set of generalised tools for the flexible computation of climate related indicators defined by the user. Each method represents a specific mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate service application (agriculture, food security, energy, water management…). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with [CSTools](https://earth.bsc.es/gitlab/external/cstools). +Set of generalised tools for the flexible computation of climate related indicators defined by the user. Each method represents a specific mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate service application (agriculture, food security, energy, water management…). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with [CSTools](https://earth.bsc.es/gitlab/external/cstools). + +A scientific publication was published in the Climate Services Journal, and it can be cited as follows: + +> Pérez-Zanón, N., Ho, A. Chou, C., Lledó, L., Marcos-Matamoros, R., Rifà, E. and González-Reviriego, N. (2023). CSIndicators: Get tailored climate indicators for applications in your sector. Climate Services. https://doi.org/10.1016/j.cliser.2023.100393 Installation ------------ -- GitLab From 797d8eedabff618e5c5966b4c6af664aae37f56c Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 21 Jun 2023 18:10:29 +0200 Subject: [PATCH 27/87] Improve description with a new space --- DESCRIPTION | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a05a3b5..77a2156 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,7 +22,9 @@ Description: Set of generalised tools for the flexible computation of climate provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with 'CSTools'. This package was developed in the context of H2020 MED-GOLD (776467) and - S2S4E (776787) projects. Lledó et al. (2019) . Pérez-Zanón et al. (2023) . + S2S4E (776787) projects. + Lledó et al. (2019) . + Pérez-Zanón et al. (2023) . Depends: R (>= 3.6.0) Imports: -- GitLab From 710f49ed8e21dc0510873066468c50eb0c5e4a88 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 28 Jun 2023 13:17:12 +0200 Subject: [PATCH 28/87] Correct parameter 'na.rm' in Standardization call, it was not included; corrected documentation for 'params'; added check for 'params' dimensions --- R/PeriodSPEI.R | 67 +++++++++++++++++--------------- man/CST_PeriodSPEI.Rd | 11 +++--- tests/testthat/test-PeriodSPEI.R | 24 +++++++++++- 3 files changed, 64 insertions(+), 38 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 077137c..f947531 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -39,11 +39,12 @@ #' used as starting and end points. #'@param params A multidimensional array with named dimensions for computing the #' SPEI. This option overrides computation of fitting parameters. It needs -#' to be of same time dimension (specified in 'time_dim') of 'exp' and a -#' dimension named 'coef' with the length of the coefficients needed for the -#' used distribution (for 'Gamma' coef dimension is of lenght 2, for -#' 'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a -#' leadtime dimension (specified in 'leadtime_dim') of length 1. +#' to have the following dimensions: same leadtime dimension of 'exp' +#' (specified in 'leadtime_dim'); time dimension of length 1 (specified in +#' 'time_dim'); and a dimension named 'coef' with the length of the +#' coefficients needed for the used distribution (for 'Gamma' coef dimension is +#' of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length 3). It can't +#' have member dimension (specified in 'memb_dim'). #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the #' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided @@ -617,16 +618,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop(paste0("Cannot compute accumulation of ", accum, " months because ", "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) } - ## params - if (!is.null(params)) { - if (!is.numeric(params)) { - stop("Parameter 'params' must be numeric.") - } - if (!all(c(time_dim, leadtime_dim, 'coef') %in% names(dim(params)))) { - stop("Parameter 'params' must be a multidimensional array with named ", - "dimensions: 'time_dim', 'leadtime_dim' and 'coef'.") - } - } ## standardization if (!is.logical(standardization)) { @@ -678,9 +669,29 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'ncores' must be a positive integer.") } } - # Data preparation - - # complete dates + ## params + if (!is.null(params)) { + if (!is.numeric(params)) { + stop("Parameter 'params' must be numeric.") + } + if (!all(c(time_dim, leadtime_dim, 'coef') %in% names(dim(params)))) { + stop("Parameter 'params' must be a multidimensional array with named ", + "dimensions: '", time_dim, "', '", leadtime_dim, "' and 'coef'.") + } + if (distribution == "Gamma") { + if (dim(params)['coef'] != 2) { + stop("For '", distribution, "' distribution, params array should have ", + "'coef' dimension of length 2.") + } + } else { + if (dim(params)['coef'] != 3) { + stop("For '", distribution, "' distribution, params array should have ", + "'coef' dimension of length 3.") + } + } + } + + # Complete dates dates_monthly <- NULL k = 0 for (dates in .return2list(dates_exp, dates_expcor)) { @@ -736,9 +747,8 @@ PeriodSPEI <- function(exp, dates_exp, lat, handle_infinity = handle_infinity, param_error = param_error, method = method, distribution = distribution, - fit = fit, ncores = ncores) + fit = fit, na.rm = na.rm, ncores = ncores) params <- spei_dat$params - pos <- match(names(dim(data[[1]])), names(dim(spei_dat[[1]]))) spei_dat[[1]] <- aperm(spei_dat[[1]], pos) @@ -972,11 +982,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, # with the values repeated each time_dim and leadtime_dim params <- aperm(params, c(2,3,1)) names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') - } else { - if (dim(params)['coef'] != length(coef)) { - stop(paste0("Params array should have 'coef' dimension of length ", - length(coef), ".")) - } } spei <- Apply(data = list(data = data, params = params), @@ -985,13 +990,11 @@ PeriodSPEI <- function(exp, dates_exp, lat, fun = .standardization, coef = coef, leadtime_dim = leadtime_dim, - time_dim = time_dim, - memb_dim = memb_dim, - handle_infinity = handle_infinity, - cross_validation = cross_validation, - method = method, distribution = distribution, fit = fit, - ref_period = ref_period, param_error = param_error, - na.rm = na.rm, + time_dim = time_dim, memb_dim = memb_dim, + ref_period = ref_period, handle_infinity = handle_infinity, + cross_validation = cross_validation, param_error = param_error, + method = method, distribution = distribution, + fit = fit, na.rm = na.rm, output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), params = c(time_dim, leadtime_dim, 'coef')), ncores = ncores) diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 2a7aaa6..8e8ab19 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -66,11 +66,12 @@ used as starting and end points.} \item{params}{A multidimensional array with named dimensions for computing the SPEI. This option overrides computation of fitting parameters. It needs -to be of same time dimension (specified in 'time_dim') of 'exp' and a -dimension named 'coef' with the length of the coefficients needed for the -used distribution (for 'Gamma' coef dimension is of lenght 2, for -'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a -leadtime dimension (specified in 'leadtime_dim') of length 1.} +to have the following dimensions: same leadtime dimension of 'exp' +(specified in 'leadtime_dim'); time dimension of length 1 (specified in +'time_dim'); and a dimension named 'coef' with the length of the +coefficients needed for the used distribution (for 'Gamma' coef dimension is +of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length 3). It can't +have member dimension (specified in 'memb_dim').} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 85a1427..c6b8075 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -34,6 +34,8 @@ lat <- c(40,40.1) exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) +params1 <- array(abs(rnorm(100)), dim = c(syear = 1, time = 3, latitude = 2, + longitude = 1, coef = 3)) # dat2 dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) @@ -182,6 +184,8 @@ test_that("2. Output checks", { dates_exp = dates_exp) res4 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, dates_exp = dates_exp, standardization = FALSE) + res5 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + params = params1) # output dims expect_equal( names(res1), @@ -223,8 +227,25 @@ test_that("2. Output checks", { # memb_dim # lat_dim # accum + res11 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, accum = 2, + dates_exp = dates_exp, na.rm = TRUE) + expect_equal( + res11$exp[1,2,1,1,][1:4], + c(-0.5553128, 0.4689562, -0.4682003, -0.9956847), + tolerance = 0.0001 + ) # ref_period # params + expect_error( + PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + params = array(abs(rnorm(100)), dim = dimscor)), + paste0("Parameter 'params' must be a multidimensional array with named ", + "dimensions: 'syear', 'time' and 'coef'.") + ) + expect_equal( + dim(res5$params), + c(syear = 1, time = 3, coef = 3, latitude = 2, longitude = 1) + ) # standarization # cross_validation expect_warning( @@ -245,7 +266,7 @@ test_that("2. Output checks", { ) expect_equal( dim(res_crossval_T$params), - dims + c(syear = 6, time = 3, coef = 3, latitude = 2, longitude = 1) ) # cross_validation = FALSE expect_equal( @@ -286,6 +307,7 @@ test_that("2. Output checks", { res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, dates_exp = dates_exp, handle_infinity = FALSE) # na.rm - + # ncores }) -- GitLab From 4a8dd49ac07d1bb54b23d404b023179b5c4b2130 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 29 Jun 2023 14:23:44 +0200 Subject: [PATCH 29/87] Add in documentation that in result, the Dates correspond to the beginning of the aggregated time period --- R/AccumulationExceedingThreshold.R | 10 ++++++---- R/PeriodAccumulation.R | 13 +++++++------ R/PeriodMean.R | 11 ++++++----- R/TotalSpellTimeExceedingThreshold.R | 9 +++++---- R/TotalTimeExceedingThreshold.R | 11 ++++++----- man/CST_AccumulationExceedingThreshold.Rd | 10 ++++++---- man/CST_PeriodAccumulation.Rd | 13 +++++++------ man/CST_PeriodMean.Rd | 11 ++++++----- man/CST_TotalSpellTimeExceedingThreshold.Rd | 9 +++++---- man/CST_TotalTimeExceedingThreshold.Rd | 11 ++++++----- 10 files changed, 60 insertions(+), 48 deletions(-) diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index 636b211..083b76c 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -49,10 +49,12 @@ #' #'@return An 's2dv_cube' object containing the aggregated values in the element #'\code{data} with dimensions of the input parameter 'data' except the dimension -#'where the indicator has been computed. A new element called 'time_bounds' will -#'be added into the 'attrs' element in the 's2dv_cube' object. It consists of a -#'list containing two elements, the start and end dates of the aggregated period -#'with the same dimensions of 'Dates' element. +#'where the indicator has been computed. The 'Dates' array is updated to +#'the dates corresponding to the beginning of the aggregated time period. A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. #' #'@examples #'exp <- NULL diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 965534f..1a8fea0 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -30,13 +30,14 @@ #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' -#'@return A 's2dv_cube' object containing the indicator in the element +#'@return An 's2dv_cube' object containing the indicator in the element #'\code{data} with dimensions of the input parameter 'data' except the dimension -#'where the accumulation has been computed (specified with 'time_dim'). A new -#'element called 'time_bounds' will be added into the 'attrs' element in the -#''s2dv_cube' object. It consists of a list containing two elements, the start -#'and end dates of the aggregated period with the same dimensions of 'Dates' -#'element. +#'where the accumulation has been computed (specified with 'time_dim'). The +#''Dates' array is updated to the dates corresponding to the beginning of the +#'aggregated time period. A new element called 'time_bounds' will be added into +#'the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 2a85ceb..f848fda 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -32,11 +32,12 @@ #' #'@return An 's2dv_cube' object containing the indicator in the element #'\code{data} with dimensions of the input parameter 'data' except the -#'dimension where the mean has been computed (specified with 'time_dim'). A new -#'element called 'time_bounds' will be added into the 'attrs' element in the -#''s2dv_cube' object. It consists of a list containing two elements, the start -#'and end dates of the aggregated period with the same dimensions of 'Dates' -#'element. +#'dimension where the mean has been computed (specified with 'time_dim'). The +#''Dates' array is updated to the dates corresponding to the beginning of the +#'aggregated time period. A new element called 'time_bounds' will be added into +#'the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index 5cf2e1d..38a3ff4 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -50,10 +50,11 @@ #'@return An 's2dv_cube' object containing the number of days that are part of a #'spell within a threshold in element \code{data} with dimensions of the input #'parameter 'data' except the dimension where the indicator has been computed. -#'A new element called 'time_bounds' will be added into the 'attrs' element in -#'the 's2dv_cube' object. It consists of a list containing two elements, the -#'start and end dates of the aggregated period with the same dimensions of -#''Dates' element. +#'The 'Dates' array is updated to the dates corresponding to the beginning of +#'the aggregated time period. A new element called 'time_bounds' will be added +#'into the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index 8a8b7ed..94d2c53 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -55,11 +55,12 @@ #'@return An 's2dv_cube' object containing in element \code{data} the total #'number of the corresponding units of the data frequency that a variable is #'exceeding a threshold during a period with dimensions of the input parameter -#''data' except the dimension where the indicator has been computed. A new -#'element called 'time_bounds' will be added into the 'attrs' element in the -#''s2dv_cube' object. It consists of a list containing two elements, the start -#'and end dates of the aggregated period with the same dimensions of 'Dates' -#'element. +#''data' except the dimension where the indicator has been computed. The +#''Dates' array is updated to the dates corresponding to the beginning of the +#'aggregated time period. A new element called 'time_bounds' will be added into +#'the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL diff --git a/man/CST_AccumulationExceedingThreshold.Rd b/man/CST_AccumulationExceedingThreshold.Rd index f14c33b..ff02e4c 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -63,10 +63,12 @@ computation.} \value{ An 's2dv_cube' object containing the aggregated values in the element \code{data} with dimensions of the input parameter 'data' except the dimension -where the indicator has been computed. A new element called 'time_bounds' will -be added into the 'attrs' element in the 's2dv_cube' object. It consists of a -list containing two elements, the start and end dates of the aggregated period -with the same dimensions of 'Dates' element. +where the indicator has been computed. The 'Dates' array is updated to +the dates corresponding to the beginning of the aggregated time period. A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. } \description{ The accumulation (sum) of a variable in the days (or time steps) that the diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 0878399..77f4a38 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -40,13 +40,14 @@ not (FALSE).} computation.} } \value{ -A 's2dv_cube' object containing the indicator in the element +An 's2dv_cube' object containing the indicator in the element \code{data} with dimensions of the input parameter 'data' except the dimension -where the accumulation has been computed (specified with 'time_dim'). A new -element called 'time_bounds' will be added into the 'attrs' element in the -'s2dv_cube' object. It consists of a list containing two elements, the start -and end dates of the aggregated period with the same dimensions of 'Dates' -element. +where the accumulation has been computed (specified with 'time_dim'). The +'Dates' array is updated to the dates corresponding to the beginning of the +aggregated time period. A new element called 'time_bounds' will be added into +the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index 025acfd..0aa4aa3 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -42,11 +42,12 @@ computation.} \value{ An 's2dv_cube' object containing the indicator in the element \code{data} with dimensions of the input parameter 'data' except the -dimension where the mean has been computed (specified with 'time_dim'). A new -element called 'time_bounds' will be added into the 'attrs' element in the -'s2dv_cube' object. It consists of a list containing two elements, the start -and end dates of the aggregated period with the same dimensions of 'Dates' -element. +dimension where the mean has been computed (specified with 'time_dim'). The +'Dates' array is updated to the dates corresponding to the beginning of the +aggregated time period. A new element called 'time_bounds' will be added into +the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ Period Mean computes the average (mean) of a given variable in a period. diff --git a/man/CST_TotalSpellTimeExceedingThreshold.Rd b/man/CST_TotalSpellTimeExceedingThreshold.Rd index 69dee16..0715414 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -58,10 +58,11 @@ computation.} An 's2dv_cube' object containing the number of days that are part of a spell within a threshold in element \code{data} with dimensions of the input parameter 'data' except the dimension where the indicator has been computed. -A new element called 'time_bounds' will be added into the 'attrs' element in -the 's2dv_cube' object. It consists of a list containing two elements, the -start and end dates of the aggregated period with the same dimensions of -'Dates' element. +The 'Dates' array is updated to the dates corresponding to the beginning of +the aggregated time period. A new element called 'time_bounds' will be added +into the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ The number of days (when daily data is provided) that are part of a spell diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index 2449014..4a1f736 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -59,11 +59,12 @@ computation.} An 's2dv_cube' object containing in element \code{data} the total number of the corresponding units of the data frequency that a variable is exceeding a threshold during a period with dimensions of the input parameter -'data' except the dimension where the indicator has been computed. A new -element called 'time_bounds' will be added into the 'attrs' element in the -'s2dv_cube' object. It consists of a list containing two elements, the start -and end dates of the aggregated period with the same dimensions of 'Dates' -element. +'data' except the dimension where the indicator has been computed. The +'Dates' array is updated to the dates corresponding to the beginning of the +aggregated time period. A new element called 'time_bounds' will be added into +the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ The Total Time of a variable exceeding (or not) a Threshold. It returns the -- GitLab From 1096e69c87fd71b09b914de90dd9d67882dbf344 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 29 Jun 2023 15:13:05 +0200 Subject: [PATCH 30/87] Undo changes in default value of time_dim; CST functions have ftime, simplified functions have time --- R/PeriodAccumulation.R | 2 +- R/PeriodMean.R | 4 ++-- R/QThreshold.R | 4 ++-- R/Threshold.R | 4 ++-- R/WindCapacityFactor.R | 4 ++-- R/WindPowerDensity.R | 4 ++-- man/PeriodAccumulation.Rd | 2 +- man/PeriodMean.Rd | 4 ++-- man/QThreshold.Rd | 4 ++-- man/Threshold.Rd | 4 ++-- man/WindCapacityFactor.Rd | 4 ++-- man/WindPowerDensity.Rd | 4 ++-- 12 files changed, 22 insertions(+), 22 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 1a8fea0..3b0d33d 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -169,7 +169,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") diff --git a/R/PeriodMean.R b/R/PeriodMean.R index f848fda..abc585a 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -135,7 +135,7 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -162,7 +162,7 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + time_dim = 'time', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") diff --git a/R/QThreshold.R b/R/QThreshold.R index c39a14b..c5089df 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -145,7 +145,7 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -178,7 +178,7 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #'@import multiApply #'@export QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # Initial checks ## data diff --git a/R/Threshold.R b/R/Threshold.R index b4e9638..73e3715 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -107,7 +107,7 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -136,7 +136,7 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, #'@importFrom stats quantile #'@export Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', sdate_dim = 'sdate', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index 7f32139..760dba0 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -135,7 +135,7 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -164,7 +164,7 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #'@export WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", "III"), dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { IEC_class <- match.arg(IEC_class) pc_files <- c( "I" = "Enercon_E70_2.3MW.txt", diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index 181e509..3eba59a 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -111,7 +111,7 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -135,7 +135,7 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #' #'@export WindPowerDensity <- function(wind, ro = 1.225, dates = NULL, start = NULL, - end = NULL, time_dim = 'ftime', ncores = NULL) { + end = NULL, time_dim = 'time', ncores = NULL) { if (!is.null(start) && !is.null(end)) { if (is.null(dates)) { diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 0260648..614b65c 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -9,7 +9,7 @@ PeriodAccumulation( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) diff --git a/man/PeriodMean.Rd b/man/PeriodMean.Rd index d02a0ab..cd1fcef 100644 --- a/man/PeriodMean.Rd +++ b/man/PeriodMean.Rd @@ -9,7 +9,7 @@ PeriodMean( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/QThreshold.Rd b/man/QThreshold.Rd index ba023d8..efc48cf 100644 --- a/man/QThreshold.Rd +++ b/man/QThreshold.Rd @@ -10,7 +10,7 @@ QThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -39,7 +39,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} diff --git a/man/Threshold.Rd b/man/Threshold.Rd index d254cbe..dc9d2a2 100644 --- a/man/Threshold.Rd +++ b/man/Threshold.Rd @@ -10,7 +10,7 @@ Threshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", na.rm = FALSE, @@ -39,7 +39,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} diff --git a/man/WindCapacityFactor.Rd b/man/WindCapacityFactor.Rd index 3ddeec6..a0a7ce5 100644 --- a/man/WindCapacityFactor.Rd +++ b/man/WindCapacityFactor.Rd @@ -10,7 +10,7 @@ WindCapacityFactor( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -41,7 +41,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/WindPowerDensity.Rd b/man/WindPowerDensity.Rd index 9b935bc..8b72009 100644 --- a/man/WindPowerDensity.Rd +++ b/man/WindPowerDensity.Rd @@ -10,7 +10,7 @@ WindPowerDensity( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -38,7 +38,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} -- GitLab From 6f95d8e143cbf58ee7db64f2a3082163cb95096a Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 5 Jul 2023 17:38:31 +0200 Subject: [PATCH 31/87] Develop SPEI in order that NA from accumulation are not used to compute standardization, then added again NA --- R/PeriodSPEI.R | 81 +++++++++++---- tests/testthat/test-PeriodSPEI.R | 172 ++++++++++++++++++++++++------- 2 files changed, 194 insertions(+), 59 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index f947531..8a0b7e2 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -410,9 +410,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, first_dims <- dims[[1]] all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) if (!all_equal) { - stop("Parameter 'exp' variables needs to have the same dimension names.") + stop("Parameter 'exp' variables need to have the same dimensions.") } + ## exp_cor if (!is.null(exp_cor)) { if (!inherits(exp_cor, 'list')) { @@ -429,7 +430,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, first_dimscor <- dimscor[[1]] all_equal <- all(sapply(dimscor[-1], function(x) identical(first_dimscor, x))) if (!all_equal) { - stop("Parameter 'exp_cor' variables needs to have the same dimension names.") + stop("Parameter 'exp_cor' variables need to have the same dimensions.") } } @@ -437,14 +438,20 @@ PeriodSPEI <- function(exp, dates_exp, lat, if (!is.numeric(lat)) { stop("Parameter 'lat' must be numeric.") } + if (!lat_dim %in% names(dims[[1]])) { + stop("Parameter 'exp' must have 'lat_dim' dimension.") + } if (any(sapply(dims, FUN = function(x) x[lat_dim] != length(lat)))) { stop("Parameter 'lat' needs to have the same length of latitudinal", "dimension of all the variables arrays in 'exp'.") } if (!is.null(exp_cor)) { + if (!lat_dim %in% names(dimscor[[1]])) { + stop("Parameter 'exp_cor' must have 'lat_dim' dimension.") + } if (any(sapply(dimscor, FUN = function(x) x[lat_dim] != length(lat)))) { stop("Parameter 'lat' needs to have the same length of latitudinal", - "dimension of all the variables arrays in 'exp'.") + "dimension of all the variables arrays in 'exp'.") } } @@ -562,7 +569,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, } ## memb_dim if (!is.character(memb_dim) | length(memb_dim) != 1) { - stop("Parameter 'time_dim' must be a character string.") + stop("Parameter 'memb_dim' must be a character string.") } if (!all(sapply(exp, function(x) memb_dim %in% names(dim(x))))) { stop("Parameter 'memb_dim' is not found in 'exp' dimension.") @@ -592,6 +599,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'dates_exp' is not of the correct class, ", "only 'Date' and 'POSIXct' classes are accepted.") } + if (!time_dim %in% names(dim(dates_exp)) | !leadtime_dim %in% names(dim(dates_exp))) { + stop("Parameter 'dates_exp' must have 'time_dim' and 'leadtime_dim' ", + "dimension.") + } if (!all(dim(exp[[1]])[c(time_dim, leadtime_dim)] == dim(dates_exp)[c(time_dim, leadtime_dim)])) { stop("Parameter 'dates_exp' needs to have the same length as 'time_dim' ", @@ -607,6 +618,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Element 'Dates' in 'exp_cor' is not of the correct class, ", "only 'Date' and 'POSIXct' classes are accepted.") } + if (!time_dim %in% names(dim(dates_expcor)) | !leadtime_dim %in% names(dim(dates_expcor))) { + stop("Parameter 'dates_expcor' must have 'time_dim' and 'leadtime_dim' ", + "dimension.") + } if (!all(dim(exp_cor[[1]])[c(time_dim, leadtime_dim)] == dim(dates_expcor)[c(time_dim, leadtime_dim)])) { stop("Parameter 'dates_expcor' needs to have the same length as ", @@ -738,21 +753,21 @@ PeriodSPEI <- function(exp, dates_exp, lat, ncores = ncores) # Standardization if (standardization) { - spei_dat <- .Standardization(data = data_accum, params = params, - accum = accum, time_dim = time_dim, - leadtime_dim = leadtime_dim, - memb_dim = memb_dim, - ref_period = ref_period, - cross_validation = cross_validation, - handle_infinity = handle_infinity, - param_error = param_error, - method = method, distribution = distribution, - fit = fit, na.rm = na.rm, ncores = ncores) - params <- spei_dat$params - pos <- match(names(dim(data[[1]])), names(dim(spei_dat[[1]]))) - spei_dat[[1]] <- aperm(spei_dat[[1]], pos) - - spei_res[[k]] <- spei_dat[[1]] + spei <- .Standardization(data = data_accum, params = params, + accum = accum, time_dim = time_dim, + leadtime_dim = leadtime_dim, + memb_dim = memb_dim, + ref_period = ref_period, + cross_validation = cross_validation, + handle_infinity = handle_infinity, + param_error = param_error, + method = method, distribution = distribution, + fit = fit, na.rm = na.rm, ncores = ncores) + params <- spei$params + pos <- match(names(dim(data[[1]])), names(dim(spei[[1]]))) + spei[[1]] <- aperm(spei[[1]], pos) + + spei_res[[k]] <- spei[[1]] } else { pos <- match(names(dim(data[[1]])), names(dim(data_accum))) data_accum <- aperm(data_accum, pos) @@ -961,6 +976,18 @@ PeriodSPEI <- function(exp, dates_exp, lat, method = 'parametric', distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = FALSE, ncores = NULL) { + # Remove NA data due to accumulation + if (accum > 1) { + data <- ClimProjDiags::Subset(x = data, along = leadtime_dim, + indices = accum:dim(data)[leadtime_dim], + drop = FALSE) + if (!is.null(params)) { + params <- ClimProjDiags::Subset(x = params, along = leadtime_dim, + indices = accum:dim(params)[leadtime_dim], + drop = FALSE) + } + } + nleadtime <- dim(data)[leadtime_dim] ntime <- dim(data)[time_dim] @@ -995,11 +1022,23 @@ PeriodSPEI <- function(exp, dates_exp, lat, cross_validation = cross_validation, param_error = param_error, method = method, distribution = distribution, fit = fit, na.rm = na.rm, - output_dims = list(data_spei = c(leadtime_dim, time_dim, memb_dim), + output_dims = list(spei = c(leadtime_dim, time_dim, memb_dim), params = c(time_dim, leadtime_dim, 'coef')), ncores = ncores) - return(spei) # spei is a list of data_spei and params + # Add again NA values due to accumulation + if (accum > 1) { + for (s in 1:length(spei)) { + spei[[s]] <- Apply(data = list(spei[[s]]), target_dims = leadtime_dim, + fun = function(x, accum = 1, leadtime_dim = 'time') { + res <- c(rep(NA, accum-1), x) + dim(res) <- length(res) + names(dim(res)) <- leadtime_dim + return(res) + }, accum = accum, leadtime_dim = leadtime_dim)$output1 + } + } + return(spei) } .standardization <- function(data, params, coef, leadtime_dim = 'time', diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index c6b8075..4e42859 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -4,6 +4,19 @@ cube1 <- NULL cube1$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) class(cube1) <- 's2dv_cube' +# cube2 +cube2 <- NULL +cube2$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube2) <- 's2dv_cube' +cube2$coords <- list(lat = 1:2) + +# cube3 +cube3 <- NULL +cube3$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube3) <- 's2dv_cube' +cube3$coords <- list(lat = 1:2) +cube3$attrs$Dates <- as.Date(c(paste0(2010:2014, "-08-16"))) + # dat1 dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) @@ -23,7 +36,7 @@ set.seed(3) expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) + paste0(2010:2015, "-10-16"))) dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) dates_expcor <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), @@ -38,26 +51,26 @@ params1 <- array(abs(rnorm(100)), dim = c(syear = 1, time = 3, latitude = 2, longitude = 1, coef = 3)) # dat2 -dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) -dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) +dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) +dimscor2 <- c(styear = 1, ftime = 3, lat = 2, lon = 1, member = 15) set.seed(1) -exp_tas <- array(rnorm(100, 17.34, 9.18), dim = dims) +exp_tas <- array(rnorm(100, 17.34, 9.18), dim = dims2) set.seed(2) -exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims2) set.seed(1) -expcor_tas <- array(rnorm(100, 17.23, 9.19), dim = dimscor) +expcor_tas <- array(rnorm(100, 17.23, 9.19), dim = dimscor2) set.seed(2) -expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) +expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor2) -dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), +dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16"))) -dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +dim(dates_exp2) <- c(sday = 1, sweek = 1, styear = 6, ftime = 3) -dates_expcor <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), +dates_expcor2 <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), paste0(2020, "-10-16"))) -dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) +dim(dates_expcor2) <- c(sday = 1, sweek = 1, styear = 1, ftime = 3) lat <- c(40,40.1) @@ -67,6 +80,7 @@ exp_cor2 <- list('tas' = expcor_tas, 'prlr' = expcor_prlr) ############################################## test_that("1. Initial checks CST_PeriodSPEI", { + # Check 's2dv_cube' expect_error( CST_PeriodSPEI(exp = NULL), "Parameter 'exp' cannot be NULL." @@ -75,11 +89,25 @@ test_that("1. Initial checks CST_PeriodSPEI", { CST_PeriodSPEI(exp = array(10)), "Parameter 'exp' must be a list of 's2dv_cube' class." ) + # latitude expect_error( CST_PeriodSPEI(exp = list(cube1)), paste0("Spatial coordinate names of parameter 'exp' do not match any ", "of the names accepted by the package.") ) + # Dates + expect_error( + CST_PeriodSPEI(exp = list(cube2)), + paste0("Element 'Dates' is not found in 'attrs' list of 'exp'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") + ) + expect_error( + CST_PeriodSPEI(exp = list(cube3), exp_cor = list(cube2)), + paste0("Element 'Dates' is not found in 'attrs' list of 'exp_cor'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") + ) }) ############################################## @@ -95,9 +123,19 @@ test_that("1. Initial checks PeriodSPEI", { "Parameter 'exp' needs to be a named list with the variable names." ) expect_error( - PeriodSPEI(exp = list('tasmax' = array(10))), + PeriodSPEI(exp = list(tasmax = array(10))), "Parameter 'exp' needs to be a list of arrays with dimension names." ) + expect_error( + PeriodSPEI(exp = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 11)))), + "Parameter 'exp' variables need to have the same dimensions." + ) + expect_error( + PeriodSPEI(exp = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(ftime = 10)))), + "Parameter 'exp' variables need to have the same dimensions." + ) # exp_cor expect_error( PeriodSPEI(exp = exp1, exp_cor = 1), @@ -112,6 +150,20 @@ test_that("1. Initial checks PeriodSPEI", { PeriodSPEI(exp = exp1, exp_cor = list('tasmax' = array(10))), "Parameter 'exp_cor' needs to be a list of arrays with dimension names." ) + expect_error( + PeriodSPEI(exp = exp1, exp_cor = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 11)))), + "Parameter 'exp_cor' variables need to have the same dimensions." + ) + expect_error( + PeriodSPEI(exp = exp1, lat = 'lat'), + "Parameter 'lat' must be numeric." + ) + expect_error( + PeriodSPEI(exp = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 10))), lat = 1:2), + "Parameter 'exp' must have 'lat_dim' dimension." + ) # exp (2) expect_warning( PeriodSPEI(exp = exp1, pet_method = '1', dates_exp = dates_exp, lat = lat), @@ -120,55 +172,95 @@ test_that("1. Initial checks PeriodSPEI", { ) # time_dim expect_error( - PeriodSPEI(exp = exp1, time_dim = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, time_dim = 1, dates_exp = dates_exp, lat = lat), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, + dates_exp = dates_exp2, dates_expcor = dates_expcor2, + lat_dim = 'lat', pet_method = 'thornthwaite'), + "Parameter 'time_dim' is not found in 'exp' dimension." ) # leadtime_dim expect_error( - PeriodSPEI(exp = exp1, time_dim = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, leadtime_dim = 1, dates_exp = dates_exp, lat = lat), + "Parameter 'leadtime_dim' must be a character string." + ) + expect_error( + PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, + dates_exp = dates_exp2, dates_expcor = dates_expcor2, + lat_dim = 'lat', time_dim = 'ftime', pet_method = 'thornthwaite'), + "Parameter 'leadtime_dim' is not found in 'exp' dimension." ) # memb_dim expect_error( - PeriodSPEI(exp = exp1, memb_dim = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, memb_dim = 1, dates_exp = dates_exp, lat = lat), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, + dates_exp = dates_exp2, dates_expcor = dates_expcor2, + lat_dim = 'lat', time_dim = 'ftime', leadtime_dim = 'styear', + pet_method = 'thornthwaite'), + "Parameter 'memb_dim' is not found in 'exp' dimension." ) # lat_dim expect_error( PeriodSPEI(exp = exp1, lat_dim = 1, dates_exp = dates_exp, lat = lat) ) + expect_error( + PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, + dates_exp = dates_exp2, dates_expcor = dates_expcor2), + "Parameter 'exp' must have 'lat_dim' dimension." + ) # accum expect_error( - PeriodSPEI(exp = exp1, accum = 10, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, accum = 10, dates_exp = dates_exp, lat = lat), + "Cannot compute accumulation of 10 months because loaded data has only 3 months." ) # standardization expect_error( - PeriodSPEI(exp = exp1, standardization = 10, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, standardization = 10, dates_exp = dates_exp, lat = lat), + "Parameter 'standardization' must be a logical value." ) # param_error expect_error( - PeriodSPEI(exp = exp1, param_error = TRUE, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, param_error = TRUE, dates_exp = dates_exp, lat = lat), + "Parameter 'param_error' must be a numeric value." ) # handle_infinity expect_error( - PeriodSPEI(exp = exp1, handle_infinity = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, handle_infinity = 1, dates_exp = dates_exp, lat = lat), + "Parameter 'handle_infinity' must be a logical value." ) # cross_validation expect_error( - PeriodSPEI(exp = exp1, cross_validation = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, cross_validation = 1, dates_exp = dates_exp, lat = lat), + "Parameter 'cross_validation' must be a logical value." ) # method expect_error( - PeriodSPEI(exp = exp1, method = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, method = 1, dates_exp = dates_exp, lat = lat), + paste0("Parameter 'method' must be a character string containing one ", + "of the following methods: 'parametric' or 'non-parametric'.") ) # distribution expect_error( - PeriodSPEI(exp = exp1, distribution = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, distribution = 1, dates_exp = dates_exp, lat = lat), + paste0("Parameter 'distribution' must be a character string containing one ", + "of the following distributions: 'log-Logistic', 'Gamma' or ", + "'PearsonIII'.") ) # fit expect_error( - PeriodSPEI(exp = exp1, fit = 1, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, fit = 1, dates_exp = dates_exp, lat = lat), + paste0("Parameter 'fit' must be a character string containing one of ", + "the following fit methods: 'max-lik', 'ub-pwm', 'pp-pwm'.") ) # ncores expect_error( - PeriodSPEI(exp = exp1, ncores = 1.5, dates_exp = dates_exp, lat = lat) + PeriodSPEI(exp = exp1, ncores = 1.5, dates_exp = dates_exp, lat = lat), + "Parameter 'ncores' must be a positive integer." ) }) @@ -182,10 +274,6 @@ test_that("2. Output checks", { standardization = FALSE) res3 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, dates_exp = dates_exp) - res4 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, standardization = FALSE) - res5 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - params = params1) # output dims expect_equal( names(res1), @@ -199,10 +287,6 @@ test_that("2. Output checks", { names(res3), c('exp', 'params') ) - expect_equal( - names(res4), - c('exp') - ) expect_equal( dim(res1[[1]]), dims @@ -222,10 +306,6 @@ test_that("2. Output checks", { # exp # exp_cor # pet - # time_dim - # leadtime_dim - # memb_dim - # lat_dim # accum res11 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, accum = 2, dates_exp = dates_exp, na.rm = TRUE) @@ -236,6 +316,8 @@ test_that("2. Output checks", { ) # ref_period # params + res5 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + params = params1) expect_error( PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, params = array(abs(rnorm(100)), dim = dimscor)), @@ -247,6 +329,16 @@ test_that("2. Output checks", { c(syear = 1, time = 3, coef = 3, latitude = 2, longitude = 1) ) # standarization + res4 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, + dates_exp = dates_exp, standardization = FALSE) + expect_equal( + names(res4), + c('exp') + ) + expect_equal( + dim(res4$exp), + c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) + ) # cross_validation expect_warning( PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, @@ -281,9 +373,13 @@ test_that("2. Output checks", { res6 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, pet_method = c('hargreaves_modified', 'hargreaves')) + + # time_dim, leadtime_dim, memb_dim, lat_dim res7 <- PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - pet_method = c('thornthwaite', 'thornthwaite')) + dates_exp = dates_exp2, dates_expcor = dates_expcor2, + pet_method = c('thornthwaite', 'thornthwaite'), + lat_dim = 'lat', time_dim = 'styear', + leadtime_dim = 'ftime', memb_dim = 'member') # method - ok res8 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, -- GitLab From 903fca855b13d9249612ee8cb22b77fa5e0ebd04 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 11 Jul 2023 16:20:35 +0200 Subject: [PATCH 32/87] Add memb_dim to MergeRefToExp; Improve function --- NAMESPACE | 1 + R/MergeRefToExp.R | 243 ++++++++++++++++++++++++++------------- man/CST_MergeRefToExp.Rd | 5 + man/MergeRefToExp.Rd | 13 ++- 4 files changed, 179 insertions(+), 83 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index d80accb..8795a86 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) import(multiApply) +importFrom(s2dv,InsertDim) importFrom(stats,approxfun) importFrom(stats,ecdf) importFrom(stats,quantile) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 434cae3..534bb55 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -33,6 +33,9 @@ #' specified. This dimension is required to subset the data in a requested period. #'@param sdate_dim A character string indicating the name of the dimension in #' which the initialization dates are stored. +#'@param memb_dim A character string indicating the name of the member +#' dimension. If the data are not ensemble ones, set as NULL. The default +#' value is 'member'. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #'@return A 's2dv_cube' object containing the indicator in the element @@ -63,7 +66,7 @@ #'@export CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, time_dim = 'ftime', sdate_dim = 'sdate', - ncores = NULL) { + memb_dim = 'member', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data1, 's2dv_cube')) { stop("Parameter 'ref' must be of the class 's2dv_cube'.") @@ -72,74 +75,74 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, stop("Parameter 'data' must be of the class 's2dv_cube'.") } # Dates subset of data1 - dates1 <- NULL if (!is.null(start1) && !is.null(end1)) { if (is.null(dim(data1$attrs$Dates))) { warning("Dimensions in 'data1' element 'attrs$Dates' are missed and ", "all data would be used.") - start <- NULL - end <- NULL - } else { - dates1 <- data1$attrs$Dates + start1 <- NULL + end1 <- NULL } } # Dates subset of data2 - dates2 <- NULL if (!is.null(start2) && !is.null(end2)) { if (is.null(dim(data2$attrs$Dates))) { warning("Dimensions in 'data2' element 'attrs$Dates' are missed and ", "all data would be used.") - start <- NULL - end <- NULL - } else { - dates2 <- data2$attrs$Dates + start2 <- NULL + end2 <- NULL } } + dates1 <- data1$attrs$Dates + dates2 <- data2$attrs$Dates + data1$data <- MergeRefToExp(data1 = data1$data, dates1 = dates1, start1 = start1, end1 = end1, data2 = data2$data, dates2 = dates2, - start2, end2, time_dim = time_dim, + start2, end2, time_dim = time_dim, + memb_dim = memb_dim, sdate_dim = sdate_dim, ncores = ncores) + data1$dims <- dim(data1$data) + if (!is.null(dates1)) { - data1$attrs$Dates <- SelectPeriodOnDates(dates1, start = start1, end = end1, - time_dim = time_dim) + if (!is.null(start1) && !is.null(end1)) { + dates1 <- SelectPeriodOnDates(dates1, start = start1, end = end1, + time_dim = time_dim) + } } if (!is.null(dates2)) { - data2$attrs$Dates <- SelectPeriodOnDates(dates2, start = start2, - end = end2, time_dim = time_dim) + if ((!is.null(start2) && !is.null(end2))) { + dates2 <- SelectPeriodOnDates(dates2, start = start2, + end = end2, time_dim = time_dim) + } } # TO DO CONCATENATE DATES - remove_dates1_dim <- FALSE - remove_dates2_dim <- FALSE - if (!is.null(data1$attrs$Dates) & !is.null(data2$attrs$Dates)) { - if (is.null(dim(data1$attrs$Dates))) { - remove_dates1_dim <- TRUE - dim(data1$attrs$Dates) <- length(data1$attrs$Dates) - names(dim(data1$attrs$Dates)) <- time_dim + remove_dates_dim <- FALSE + + if (!is.null(dates1) & !is.null(dates2)) { + if (is.null(dim(dates1))) { + remove_dates_dim <- TRUE + dim(dates1) <- length(dates1) + names(dim(dates1)) <- time_dim } - if (is.null(dim(data2$attrs$Dates))) { - remove_dates2_dim <- TRUE - dim(data2$attrs$Dates) <- length(data2$attrs$Dates) - names(dim(data2$attrs$Dates)) <- time_dim + if (is.null(dim(dates2))) { + remove_dates_dim <- TRUE + dim(dates2) <- length(dates2) + names(dim(dates2)) <- time_dim } } - res <- Apply(list(data1$attrs$Dates, data2$attrs$Dates), target_dims = time_dim, - c, output_dims = time_dim, ncores = ncores)$output1 - if (inherits(data1$attrs$Dates, 'Date')) { + res <- Apply(list(dates1, dates2), target_dims = time_dim, + 'c', output_dims = time_dim, ncores = ncores)$output1 + if (inherits(dates1, 'Date')) { data1$attrs$Dates <- as.Date(res, origin = '1970-01-01') } else { data1$attrs$Dates <- as.POSIXct(res*3600*24, origin = '1970-01-01', tz = 'UTC') } - if (remove_dates1_dim) { + if (remove_dates_dim) { dim(data1$attrs$Dates) <- NULL } - if (remove_dates2_dim) { - dim(data2$attrs$Dates) <- NULL - } - return(data1) } @@ -177,6 +180,9 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #' period. #'@param sdate_dim A character string indicating the name of the dimension in #' which the initialization dates are stored. +#'@param memb_dim A character string indicating the name of the member +#' dimension. If the data are not ensemble ones, set as NULL. The default +#' value is 'member'. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' @@ -199,57 +205,89 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #' time_dim = 'time') #' #'@import multiApply +#'@importFrom s2dv InsertDim #'@export -MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, - end2, time_dim = 'ftime', sdate_dim = 'sdate', - ncores = NULL) { +MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, + dates2, start2 = NULL, end2 = NULL, + time_dim = 'ftime', sdate_dim = 'sdate', + memb_dim = 'member', ncores = NULL) { # Input checks # data - if (!is.array(data1)) { - dim(data1) <- c(length(data1)) - names(dim(data1)) <- time_dim + if (!is.array(data1) | !is.array(data2)) { + stop("Parameters 'data1' and 'data2' must be arrays.") } - if (!is.array(data2)) { - dim(data2) <- c(length(data2)) - names(dim(data2)) <- time_dim + if (is.null(names(dim(data1))) | is.null(names(dim(data2)))) { + stop("Parameters 'data1' and 'data2' must have named dimensions.") } - # dates - if (!is.null(dates1) & !is.null(dates2)) { - if (is.null(dim(dates1))) { - warning("Dimensions in 'dates1' element are missed and ", - "all data would be used.") - dim(dates1) <- length(dates1) - names(dim(dates1)) <- time_dim + # time_dim + if (!is.character(time_dim)) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data1)) | !time_dim %in% names(dim(data2))) { + stop("Parameter 'time_dim' is not found in 'data1' or 'data2' dimension ", + "names.") + } + # memb_dim + if (!is.null(memb_dim)) { + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string.") } - if (is.null(dim(dates2))) { - warning("Dimensions in 'dates2' element are missed and ", - "all data would be used.") - dim(dates2) <- length(dates2) - names(dim(dates2)) <- time_dim + if (!memb_dim %in% names(dim(data1)) & !memb_dim %in% names(dim(data2))) { + stop("Parameter 'memb_dim' is not found in 'data1' or 'data2' dimension. ", + "Set it to NULL if there is no member dimension.") + } + if (memb_dim %in% names(dim(data1))) { + if (dim(data1)[memb_dim] == 1) { + print('memb_dim removed data1') + data1 <- array(data1, dim = dim(data1)[-which(names(dim(data1)) == memb_dim)]) + } + } + if (memb_dim %in% names(dim(data2))) { + if (dim(data2)[memb_dim] == 1) { + print('memb_dim removed data2') + data2 <- array(data2, dim = dim(data2)[-which(names(dim(data2)) == memb_dim)]) + } + } + # Add NA to fill member_dim + if (memb_dim %in% names(dim(data1)) & memb_dim %in% names(dim(data2))) { + if (dim(data1)[memb_dim] != dim(data2)[memb_dim]) { + if (dim(data1)[memb_dim] > dim(data2)[memb_dim]) { + data2 <- Apply(list(data2), target_dims = memb_dim, + fun = function(x, length_new_dim) { + return(c(x, rep(NA, length_new_dim - length(x)))) + }, length_new_dim = dim(data1)[memb_dim], + output_dims = memb_dim)$output1 + } else { + data1 <- Apply(list(data1), target_dims = memb_dim, + fun = function(x, length_new_dim) { + return(c(x, rep(NA, length_new_dim - length(x)))) + }, length_new_dim = dim(data2)[memb_dim], + output_dims = memb_dim)$output1 + } + } } - data1 <- SelectPeriodOnData(data1, dates = dates1, start = start1, - end = end1, time_dim = time_dim, ncores = ncores) } - # Check if data2 has dimension sdate_dim and it should be added to data1: - if ((sdate_dim %in% names(dim(data2))) && dim(data2)[sdate_dim] > 1 && - !sdate_dim %in% names(dim(data1))) { - dim(data1) <- c(length(data1)/dim(data2)[sdate_dim], dim(data2)[sdate_dim]) - names(dim(data1)) <- c(time_dim, sdate_dim) - } - # Check if data1 has dimension sdate_dim and it should be added to data2: - if ((sdate_dim %in% names(dim(data1))) && dim(data1)[sdate_dim] > 1 && - !sdate_dim %in% names(dim(data2))) { - dim(data2) <- c(length(data2)/dim(data1)[sdate_dim], dim(data1)[sdate_dim]) - names(dim(data2)) <- c(time_dim, sdate_dim) - } + # # Check if data2 has dimension sdate_dim and it should be added to data1: + # if ((sdate_dim %in% names(dim(data2))) && dim(data2)[sdate_dim] > 1 && + # !sdate_dim %in% names(dim(data1))) { + # dim(data1) <- c(length(data1)/dim(data2)[sdate_dim], dim(data2)[sdate_dim]) + # names(dim(data1)) <- c(time_dim, sdate_dim) + # } + # # Check if data1 has dimension sdate_dim and it should be added to data2: + # if ((sdate_dim %in% names(dim(data1))) && dim(data1)[sdate_dim] > 1 && + # !sdate_dim %in% names(dim(data2))) { + # dim(data2) <- c(length(data2)/dim(data1)[sdate_dim], dim(data1)[sdate_dim]) + # names(dim(data2)) <- c(time_dim, sdate_dim) + # } + # Check if data1 needs to be extended to the length of the dimensions of data2: if (length(dim(data2)) != length(dim(data1))) { dif_dims <- which(names(dim(data2)) %in% names(dim(data1)) == FALSE) if (length(dif_dims) > 0) { for (i in dif_dims) { - data1 <- .insertdim(data1, posdim = i, lendim = dim(data2)[i], - name = names(dim(data2))[i]) + data1 <- InsertDim(data1, posdim = length(dim(data1)), lendim = dim(data2)[i], + name = names(dim(data2))[i]) } } } @@ -258,18 +296,65 @@ MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, dif_dims <- which(names(dim(data1)) %in% names(dim(data2)) == FALSE) if (length(dif_dims) > 0) { for (i in dif_dims) { - data2 <- .insertdim(data2, posdim = i, lendim = dim(data1)[i], - name = names(dim(data1))[i]) + data2 <- InsertDim(data2, posdim = length(dim(data1)), lendim = dim(data1)[i], + name = names(dim(data1))[i]) } } } - if (!is.null(dates2)) { - data2 <- SelectPeriodOnData(data2, dates = dates2, start = start2, - end = end2, time_dim = time_dim, ncores = ncores) + + # dates1 + if (!is.null(start1) & !is.null(end1)) { + if (is.null(dates1)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start1), is.list(end1)))) { + stop("Parameter 'start1' and 'end1' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates1))) { + data1 <- SelectPeriodOnData(data = data1, dates = dates1, start = start1, + end = end1, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates1' must have named dimensions if 'start' and ", + "'end' are not NULL. All 'data1' will be used.") + } + } } + # dates2 + if (!is.null(start2) & !is.null(end2)) { + if (is.null(dates2)) { + warning("Parameter 'dates2' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start2), is.list(end2)))) { + stop("Parameter 'start2' and 'end2' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates2))) { + data2 <- SelectPeriodOnData(data = data2, dates = dates2, start = start2, + end = end2, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates2' must have named dimensions if 'start2' and ", + "'end2' are not NULL. All 'data2' will be used.") + } + } + } + + data1dims <- names(dim(data1)) + data2dims <- names(dim(data2)) + data1 <- Apply(list(data1, data2), target_dims = time_dim, fun = 'c', output_dims = time_dim, ncores = ncores)$output1 + if (all(names(dim(data1)) %in% data1dims)) { + pos <- match(names(dim(data1)), data1dims) + data1 <- aperm(data1, pos) + } + if (all(names(dim(data1)) %in% data2dims)) { + pos <- match(names(dim(data1)), data2dims) + data1 <- aperm(data1, pos) + } return(data1) } - - diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index 9f9a3b9..c15ab9e 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -13,6 +13,7 @@ CST_MergeRefToExp( end2, time_dim = "ftime", sdate_dim = "sdate", + memb_dim = "member", ncores = NULL ) } @@ -47,6 +48,10 @@ specified. This dimension is required to subset the data in a requested period.} \item{sdate_dim}{A character string indicating the name of the dimension in which the initialization dates are stored.} +\item{memb_dim}{A character string indicating the name of the member +dimension. If the data are not ensemble ones, set as NULL. The default +value is 'member'.} + \item{ncores}{An integer indicating the number of cores to use in parallel computation.} } diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index e6b40c8..c446a10 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -7,14 +7,15 @@ MergeRefToExp( data1, dates1, - start1, - end1, + start1 = NULL, + end1 = NULL, data2, dates2, - start2, - end2, + start2 = NULL, + end2 = NULL, time_dim = "ftime", sdate_dim = "sdate", + memb_dim = "member", ncores = NULL ) } @@ -54,6 +55,10 @@ period.} \item{sdate_dim}{A character string indicating the name of the dimension in which the initialization dates are stored.} +\item{memb_dim}{A character string indicating the name of the member +dimension. If the data are not ensemble ones, set as NULL. The default +value is 'member'.} + \item{ncores}{An integer indicating the number of cores to use in parallel computation.} } -- GitLab From 3c1bb67ed22caf98ccd136df2ee46c2deed8830a Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 12 Jul 2023 16:15:31 +0200 Subject: [PATCH 33/87] Improved development of MergeRefToExp; improved documentation; added unit tests for the new development --- DESCRIPTION | 2 +- R/MergeRefToExp.R | 213 ++++++++++++++++++---------- man/CST_MergeRefToExp.Rd | 43 ++++-- man/MergeRefToExp.Rd | 54 ++++--- tests/testthat/test-MergeRefToExp.R | 150 ++++++++++++++++++-- 5 files changed, 341 insertions(+), 121 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4151ba4..4e20983 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,4 @@ URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 RoxygenNote: 7.2.0 -Config/testthat/edition: 3 \ No newline at end of file +Config/testthat/edition: 3 diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 534bb55..4f8e16f 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -11,10 +11,19 @@ #'references) could be added at the end of the forecast lead time to cover the #'desired period (e.g.: until the end of summer). #' -#'@param data1 An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. -#'@param data2 An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data1 An 's2dv_cube' object with the element 'data' being a +#' multidimensional array of with named dimensions matching the dimensions of +#' parameter 'data2'. Dimensions with the same name in the 'data2' parameter +#' must have the same length or length 1; except for the dimension specified +#' with 'memb_dim', which can be different and in the result will be filled +#' with NA values. It can also have additional dimensions with different names +#' in 'data2'. +#'@param data2 An 's2dv_cube' object with the element 'data' being a +#' multidimensional array of dates with named dimensions matching +#' the dimensions on parameter 'data1'. Dimensions with the same name in the +#' 'data1' parameter must have the same length or length 1, except for the +#' dimension specified with 'memb_dim', which can be different and in the +#' result will be filled with NA values. #'@param start1 A list to define the initial date of the period to select from #' data1 by providing a list of two elements: the initial date of the period #' and the initial month of the period. @@ -30,16 +39,24 @@ #'@param time_dim A character string indicating the name of the temporal #' dimension. By default, it is set to 'ftime'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be -#' specified. This dimension is required to subset the data in a requested period. -#'@param sdate_dim A character string indicating the name of the dimension in -#' which the initialization dates are stored. +#' specified. This dimension is required to subset the data in a requested +#' period. #'@param memb_dim A character string indicating the name of the member #' dimension. If the data are not ensemble ones, set as NULL. The default #' value is 'member'. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #'@return A 's2dv_cube' object containing the indicator in the element -#' \code{data}. +#'\code{data}. The element \code{data} will be a multidimensional array with +#'dimensions named from the combination of 'data1' and 'data2'. The resulting +#'dimensions will be the following: all the same common dimensions between the +#'two arrays plus the different dimensions of each array. If there is any +#'different common dimension but in a dataset it has length 1, it will be added +#'with the maximum dimension. If memb_dim is used, the dimension of the maximum +#'value corresponding to memb_dim of the two data sets will be added; the +#'difference between the dimensions of the set members will be filled with NA. +#'The other elements of the 's2dv_cube' will be updated with the combined +#'information of both datasets. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), @@ -64,15 +81,16 @@ #' #'@import multiApply #'@export -CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, - time_dim = 'ftime', sdate_dim = 'sdate', - memb_dim = 'member', ncores = NULL) { +CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, + start2 = NULL, end2 = NULL, + time_dim = 'ftime', memb_dim = 'member', + ncores = NULL) { # Check 's2dv_cube' if (!inherits(data1, 's2dv_cube')) { - stop("Parameter 'ref' must be of the class 's2dv_cube'.") + stop("Parameter 'data1' must be of the class 's2dv_cube'.") } if (!inherits(data2, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube'.") + stop("Parameter 'data2' must be of the class 's2dv_cube'.") } # Dates subset of data1 if (!is.null(start1) && !is.null(end1)) { @@ -96,14 +114,37 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, dates1 <- data1$attrs$Dates dates2 <- data2$attrs$Dates + # data data1$data <- MergeRefToExp(data1 = data1$data, dates1 = dates1, start1 = start1, end1 = end1, data2 = data2$data, dates2 = dates2, start2, end2, time_dim = time_dim, - memb_dim = memb_dim, - sdate_dim = sdate_dim, ncores = ncores) + memb_dim = memb_dim, ncores = ncores) + # dims data1$dims <- dim(data1$data) + # coords + for (i_dim in names(dim(data1$data))) { + if (length(data1$coords[[i_dim]]) != dim(data1$data)[i_dim]) { + data1$coords[[i_dim]] <- NULL + data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] + attr(data1$coords[[i_dim]], 'indices') <- TRUE + } else if (length(data1$coords[[i_dim]]) == length(data2$coords[[i_dim]])) { + if (any(as.vector(data1$coords[[i_dim]]) != as.vector(data2$coords[[i_dim]]))) { + data1$coords[[i_dim]] <- NULL + data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] + attr(data1$coords[[i_dim]], 'indices') <- TRUE + } else if (!identical(attributes(data1$coords[[i_dim]]), attributes(data2$coords[[i_dim]]))) { + attributes(data1$coords[[i_dim]]) <- NULL + } + } else { + data1$coords[[i_dim]] <- NULL + data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] + attr(data1$coords[[i_dim]], 'indices') <- TRUE + } + } + + # Dates if (!is.null(dates1)) { if (!is.null(start1) && !is.null(end1)) { dates1 <- SelectPeriodOnDates(dates1, start = start1, end = end1, @@ -117,7 +158,6 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, } } - # TO DO CONCATENATE DATES remove_dates_dim <- FALSE if (!is.null(dates1) & !is.null(dates2)) { @@ -134,15 +174,31 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, } res <- Apply(list(dates1, dates2), target_dims = time_dim, 'c', output_dims = time_dim, ncores = ncores)$output1 + if (inherits(dates1, 'Date')) { data1$attrs$Dates <- as.Date(res, origin = '1970-01-01') } else { - data1$attrs$Dates <- as.POSIXct(res*3600*24, origin = '1970-01-01', tz = 'UTC') + data1$attrs$Dates <- as.POSIXct(res, origin = '1970-01-01', tz = 'UTC') } if (remove_dates_dim) { dim(data1$attrs$Dates) <- NULL } + + # Variable + data1$attrs$Variable$varName <- unique(data1$attrs$Variable$varName, + data2$attrs$Variable$varName) + data1$attrs$Variable$metadata <- intersect(data1$attrs$Variable, data2$attrs$Variable)[[2]] + + # source_files + data1$attrs$source_files <- c(data1$attrs$source_files, data2$attrs$source_files) + + # Datasets + data1$attrs$Datasets <- c(data1$attrs$Datasets, data2$attrs$Datasets) + + # when + data1$attrs$when <- Sys.time() + return(data1) } @@ -155,12 +211,21 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #'compute the indicator. The function \code{MergeObs2Exp} takes care of this #'steps. #' -#'@param data1 A multidimensional array with named dimensions. -#'@param dates1 A vector of dates or a multidimensional array of dates with -#' named dimensions matching the dimensions on parameter 'data1'. -#'@param data2 A multidimensional array with named dimensions. -#'@param dates2 A vector of dates or a multidimensional array of dates with -#' named dimensions matching the dimensions on parameter 'data2'. +#'@param data1 A multidimensional array of with named dimensions matching the +#' dimensions of parameter 'data2'. Dimensions with the same name in the +#' 'data2' parameter must have the same length or length 1; except for the +#' dimension specified with 'memb_dim', which can be different and in the +#' result will be filled with NA values. It can also have additional dimensions +#' with different names in 'data2'. +#'@param dates1 A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data1'. +#'@param data2 A multidimensional array of dates with named dimensions matching +#' the dimensions on parameter 'data1'. Dimensions with the same name in the +#' 'data1' parameter must have the same length or length 1, except for the +#' dimension specified with 'memb_dim', which can be different and in the +#' result will be filled with NA values. +#'@param dates2 A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data2'. #'@param start1 A list to define the initial date of the period to select from #' data1 by providing a list of two elements: the initial date of the period #' and the initial month of the period. @@ -178,39 +243,44 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. -#'@param sdate_dim A character string indicating the name of the dimension in -#' which the initialization dates are stored. #'@param memb_dim A character string indicating the name of the member #' dimension. If the data are not ensemble ones, set as NULL. The default #' value is 'member'. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' -#'@return A multidimensional array with named dimensions. -#' +#'@return A multidimensional array with dimensions named from the combination of +#''data1' and 'data2'. The resulting dimensions will be the following: all the +#'same common dimensions between the two arrays plus the different dimensions of +#'each array. If there is any different common dimension but in a dataset it has +#'length 1, it will be added with the maximum dimension. If memb_dim is used, +#'the dimension of the maximum value corresponding to memb_dim of the two data +#'sets will be added; the difference between the dimensions of the set members +#'will be filled with NA. +#' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), #' seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) -#'dim(data_dates) <- c(time = 154, sdate = 2) +#'dim(data_dates) <- c(ftime = 154, sdate = 2) #'ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day") -#'dim(ref_dates) <- c(time = 350, sdate = 2) -#'ref <- array(1001:1700, c(time = 350, sdate = 2)) -#'data <- array(1:(2*154*2), c(time = 154, sdate = 2, member= 2)) +#'dim(ref_dates) <- c(ftime = 350, sdate = 2) +#'ref <- array(1001:1700, c(ftime = 350, sdate = 2)) +#'data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) #'new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), #' end1 = list(30, 6), data2 = data, dates2 = data_dates, #' start2 = list(1, 7), end = list(21, 9), -#' time_dim = 'time') +#' time_dim = 'ftime') #' #'@import multiApply #'@importFrom s2dv InsertDim #'@export -MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, - dates2, start2 = NULL, end2 = NULL, - time_dim = 'ftime', sdate_dim = 'sdate', - memb_dim = 'member', ncores = NULL) { +MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, + start1 = NULL, end1 = NULL, start2 = NULL, end2 = NULL, + time_dim = 'ftime', memb_dim = 'member', + ncores = NULL) { # Input checks # data if (!is.array(data1) | !is.array(data2)) { @@ -238,13 +308,11 @@ MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, } if (memb_dim %in% names(dim(data1))) { if (dim(data1)[memb_dim] == 1) { - print('memb_dim removed data1') data1 <- array(data1, dim = dim(data1)[-which(names(dim(data1)) == memb_dim)]) } } if (memb_dim %in% names(dim(data2))) { if (dim(data2)[memb_dim] == 1) { - print('memb_dim removed data2') data2 <- array(data2, dim = dim(data2)[-which(names(dim(data2)) == memb_dim)]) } } @@ -268,36 +336,30 @@ MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, } } - # # Check if data2 has dimension sdate_dim and it should be added to data1: - # if ((sdate_dim %in% names(dim(data2))) && dim(data2)[sdate_dim] > 1 && - # !sdate_dim %in% names(dim(data1))) { - # dim(data1) <- c(length(data1)/dim(data2)[sdate_dim], dim(data2)[sdate_dim]) - # names(dim(data1)) <- c(time_dim, sdate_dim) - # } - # # Check if data1 has dimension sdate_dim and it should be added to data2: - # if ((sdate_dim %in% names(dim(data1))) && dim(data1)[sdate_dim] > 1 && - # !sdate_dim %in% names(dim(data2))) { - # dim(data2) <- c(length(data2)/dim(data1)[sdate_dim], dim(data1)[sdate_dim]) - # names(dim(data2)) <- c(time_dim, sdate_dim) - # } - - # Check if data1 needs to be extended to the length of the dimensions of data2: - if (length(dim(data2)) != length(dim(data1))) { - dif_dims <- which(names(dim(data2)) %in% names(dim(data1)) == FALSE) - if (length(dif_dims) > 0) { - for (i in dif_dims) { - data1 <- InsertDim(data1, posdim = length(dim(data1)), lendim = dim(data2)[i], - name = names(dim(data2))[i]) + # Find common dims and remove the ones not needed + name_data1 <- sort(names(dim(data1))) + name_data2 <- sort(names(dim(data2))) + + commondims <- name_data1[name_data1 %in% name_data2] + commondims <- commondims[-which(commondims == time_dim)] + + if (length(commondims) != 0) { + if (!all(dim(data2)[commondims] == dim(data1)[commondims])) { + dif_common <- commondims[!dim(data2)[commondims] == dim(data1)[commondims]] + if (any(dim(data2)[dif_common] == 1)) { + dim_remove <- dif_common[which(dim(data1)[dif_common] == 1)] + dim(data1) <- dim(data1)[-which(names(dim(data1)) == dim_remove)] + dif_common <- dif_common[-which(dif_common == dim_remove)] } - } - } - # Check if data2 needs to be extended to the length of the dimensions of data1: - if (length(dim(data1)) != length(dim(data2))) { - dif_dims <- which(names(dim(data1)) %in% names(dim(data2)) == FALSE) - if (length(dif_dims) > 0) { - for (i in dif_dims) { - data2 <- InsertDim(data2, posdim = length(dim(data1)), lendim = dim(data1)[i], - name = names(dim(data1))[i]) + if (any(dim(data1)[dif_common] == 1)) { + dim_remove <- dif_common[which(dim(data1)[dif_common] == 1)] + dim(data1) <- dim(data1)[-which(names(dim(data1)) == dim_remove)] + dif_common <- dif_common[-which(dif_common == dim_remove)] + } + if (length(dif_common) != 0) { + stop("Parameters 'data1' and 'data2' have common dimension ", + paste0("'", dif_common, sep = "' "), "with different length and ", + "different of length 1.") } } } @@ -307,11 +369,11 @@ MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, if (is.null(dates1)) { warning("Parameter 'dates' is NULL and the average of the ", "full data provided in 'data' is computed.") + } else if (!all(c(is.list(start1), is.list(end1)))) { + warning("Parameter 'start1' and 'end1' must be lists indicating the ", + "day and the month of the period start and end. Full data ", + "will be used.") } else { - if (!any(c(is.list(start1), is.list(end1)))) { - stop("Parameter 'start1' and 'end1' must be lists indicating the ", - "day and the month of the period start and end.") - } if (!is.null(dim(dates1))) { data1 <- SelectPeriodOnData(data = data1, dates = dates1, start = start1, end = end1, time_dim = time_dim, @@ -327,11 +389,11 @@ MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, if (is.null(dates2)) { warning("Parameter 'dates2' is NULL and the average of the ", "full data provided in 'data' is computed.") + } else if (!all(c(is.list(start2), is.list(end2)))) { + warning("Parameter 'start2' and 'end2' must be lists indicating the ", + "day and the month of the period start and end. Full data ", + "will be used.") } else { - if (!any(c(is.list(start2), is.list(end2)))) { - stop("Parameter 'start2' and 'end2' must be lists indicating the ", - "day and the month of the period start and end.") - } if (!is.null(dim(dates2))) { data2 <- SelectPeriodOnData(data = data2, dates = dates2, start = start2, end = end2, time_dim = time_dim, @@ -348,6 +410,7 @@ MergeRefToExp <- function(data1, dates1, start1 = NULL, end1 = NULL, data2, data1 <- Apply(list(data1, data2), target_dims = time_dim, fun = 'c', output_dims = time_dim, ncores = ncores)$output1 + if (all(names(dim(data1)) %in% data1dims)) { pos <- match(names(dim(data1)), data1dims) data1 <- aperm(data1, pos) diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index c15ab9e..f2195f2 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -7,22 +7,30 @@ CST_MergeRefToExp( data1, data2, - start1, - end1, - start2, - end2, + start1 = NULL, + end1 = NULL, + start2 = NULL, + end2 = NULL, time_dim = "ftime", - sdate_dim = "sdate", memb_dim = "member", ncores = NULL ) } \arguments{ -\item{data1}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data1}{An 's2dv_cube' object with the element 'data' being a +multidimensional array of with named dimensions matching the dimensions of +parameter 'data2'. Dimensions with the same name in the 'data2' parameter +must have the same length or length 1; except for the dimension specified +with 'memb_dim', which can be different and in the result will be filled +with NA values. It can also have additional dimensions with different names +in 'data2'.} -\item{data2}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data2}{An 's2dv_cube' object with the element 'data' being a +multidimensional array of dates with named dimensions matching +the dimensions on parameter 'data1'. Dimensions with the same name in the +'data1' parameter must have the same length or length 1, except for the +dimension specified with 'memb_dim', which can be different and in the +result will be filled with NA values.} \item{start1}{A list to define the initial date of the period to select from data1 by providing a list of two elements: the initial date of the period @@ -43,10 +51,8 @@ the final month of the period.} \item{time_dim}{A character string indicating the name of the temporal dimension. By default, it is set to 'ftime'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be -specified. This dimension is required to subset the data in a requested period.} - -\item{sdate_dim}{A character string indicating the name of the dimension in -which the initialization dates are stored.} +specified. This dimension is required to subset the data in a requested +period.} \item{memb_dim}{A character string indicating the name of the member dimension. If the data are not ensemble ones, set as NULL. The default @@ -57,7 +63,16 @@ computation.} } \value{ A 's2dv_cube' object containing the indicator in the element - \code{data}. +\code{data}. The element \code{data} will be a multidimensional array with +dimensions named from the combination of 'data1' and 'data2'. The resulting +dimensions will be the following: all the same common dimensions between the +two arrays plus the different dimensions of each array. If there is any +different common dimension but in a dataset it has length 1, it will be added +with the maximum dimension. If memb_dim is used, the dimension of the maximum +value corresponding to memb_dim of the two data sets will be added; the +difference between the dimensions of the set members will be filled with NA. +The other elements of the 's2dv_cube' will be updated with the combined +information of both datasets. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index c446a10..164606c 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -6,24 +6,37 @@ \usage{ MergeRefToExp( data1, - dates1, + data2, + dates1 = NULL, + dates2 = NULL, start1 = NULL, end1 = NULL, - data2, - dates2, start2 = NULL, end2 = NULL, time_dim = "ftime", - sdate_dim = "sdate", memb_dim = "member", ncores = NULL ) } \arguments{ -\item{data1}{A multidimensional array with named dimensions.} +\item{data1}{A multidimensional array of with named dimensions matching the +dimensions of parameter 'data2'. Dimensions with the same name in the +'data2' parameter must have the same length or length 1; except for the +dimension specified with 'memb_dim', which can be different and in the +result will be filled with NA values. It can also have additional dimensions +with different names in 'data2'.} + +\item{data2}{A multidimensional array of dates with named dimensions matching +the dimensions on parameter 'data1'. Dimensions with the same name in the +'data1' parameter must have the same length or length 1, except for the +dimension specified with 'memb_dim', which can be different and in the +result will be filled with NA values.} + +\item{dates1}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data1'.} -\item{dates1}{A vector of dates or a multidimensional array of dates with -named dimensions matching the dimensions on parameter 'data1'.} +\item{dates2}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data2'.} \item{start1}{A list to define the initial date of the period to select from data1 by providing a list of two elements: the initial date of the period @@ -33,11 +46,6 @@ and the initial month of the period.} data1 by providing a list of two elements: the final day of the period and the final month of the period.} -\item{data2}{A multidimensional array with named dimensions.} - -\item{dates2}{A vector of dates or a multidimensional array of dates with -named dimensions matching the dimensions on parameter 'data2'.} - \item{start2}{A list to define the initial date of the period to select from data2 by providing a list of two elements: the initial date of the period and the initial month of the period.} @@ -52,9 +60,6 @@ matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} -\item{sdate_dim}{A character string indicating the name of the dimension in -which the initialization dates are stored.} - \item{memb_dim}{A character string indicating the name of the member dimension. If the data are not ensemble ones, set as NULL. The default value is 'member'.} @@ -63,7 +68,14 @@ value is 'member'.} computation.} } \value{ -A multidimensional array with named dimensions. +A multidimensional array with dimensions named from the combination of +'data1' and 'data2'. The resulting dimensions will be the following: all the +same common dimensions between the two arrays plus the different dimensions of +each array. If there is any different common dimension but in a dataset it has +length 1, it will be added with the maximum dimension. If memb_dim is used, +the dimension of the maximum value corresponding to memb_dim of the two data +sets will be added; the difference between the dimensions of the set members +will be filled with NA. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from @@ -78,15 +90,15 @@ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) -dim(data_dates) <- c(time = 154, sdate = 2) +dim(data_dates) <- c(ftime = 154, sdate = 2) ref_dates <- seq(as.Date("01-01-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day") -dim(ref_dates) <- c(time = 350, sdate = 2) -ref <- array(1001:1700, c(time = 350, sdate = 2)) -data <- array(1:(2*154*2), c(time = 154, sdate = 2, member= 2)) +dim(ref_dates) <- c(ftime = 350, sdate = 2) +ref <- array(1001:1700, c(ftime = 350, sdate = 2)) +data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), end1 = list(30, 6), data2 = data, dates2 = data_dates, start2 = list(1, 7), end = list(21, 9), - time_dim = 'time') + time_dim = 'ftime') } diff --git a/tests/testthat/test-MergeRefToExp.R b/tests/testthat/test-MergeRefToExp.R index adbdfd6..effae50 100644 --- a/tests/testthat/test-MergeRefToExp.R +++ b/tests/testthat/test-MergeRefToExp.R @@ -1,6 +1,135 @@ ########################################################################### -test_that("Sanity checks", { +# cube1 +dates_data1 <- c(seq(as.Date("11-07-1993", "%d-%m-%Y", tz = 'UTC'), + as.Date("20-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("11-07-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("20-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) +dim(dates_data1) <- c(ftime = 10, sdate = 2) +cube1 <- NULL +cube1$data <- array(1:(2*10*2), c(ftime = 10, sdate = 2, member= 2)) +cube1$attrs$Dates <- dates_data1 +class(cube1) <- 's2dv_cube' +ref_dates1 <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), + as.Date("10-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("10-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) +dim(ref_dates1) <- c(ftime = 10, sdate = 2) +cube_ref <- NULL +cube_ref$data <- array(1001:1700, c(ftime = 10, sdate = 2)) +cube_ref$attrs$Dates <- ref_dates1 +class(cube_ref) <- 's2dv_cube' +start1 <- list(3, 7) +end1 <- list(10, 7) +start2 <- list(11, 7) +end2 <- list(15, 7) + +# dat1 +ref1 <- array(1001:1700, c(ftime = 10, sdate = 2)) +data1 <- array(1:(2*154*2), c(ftime = 11, sdate = 2, member = 2)) + +########################################################################### +test_that("1. Input checks", { + # 's2dv_cube' + expect_error( + CST_MergeRefToExp('a'), + "Parameter 'data1' must be of the class 's2dv_cube'." + ) + expect_error( + CST_MergeRefToExp(cube1, array(10)), + "Parameter 'data2' must be of the class 's2dv_cube'." + ) + # data + expect_error( + MergeRefToExp(10, 10), + "Parameters 'data1' and 'data2' must be arrays." + ) + expect_error( + MergeRefToExp(array(10), array(10)), + "Parameters 'data1' and 'data2' must have named dimensions." + ) + # time_dim + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, time_dim = 'time'), + paste0("Parameter 'time_dim' is not found in 'data1' or 'data2' dimension ", + "names.") + ) + # memb_dim + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, memb_dim = 1), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, memb_dim = 'time'), + paste0("Parameter 'memb_dim' is not found in 'data1' or 'data2' dimension. ", + "Set it to NULL if there is no member dimension.") + ) + # common dimensions + expect_error( + MergeRefToExp(data1 = array(1:12, c(sdate = 2, ftime = 2, var = 3)), + data2 = array(1:16, c(sdate = 2, ftime = 2, var = 4)), + memb_dim = NULL), + paste0("Parameters 'data1' and 'data2' have common dimension 'var' ", + "with different length and different of length 1.") + ) + # dates + expect_warning( + MergeRefToExp(data1 = array(1:4, c(sdate = 2, ftime = 2, lat = 1)), + data2 = array(1:16, c(sdate = 2, ftime = 2, lat = 4)), + memb_dim = NULL, start1 = list(1, 1), end1 = list(3, 1), + start2 = NULL, end2 = NULL), + paste0("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + ) + expect_warning( + MergeRefToExp(data1 = ref1, + data2 = data1, dates1 = ref_dates1, dates2 = dates_data1, + start1 = c(3, 7), end1 = end1, + start2 = start2, end2 = end2), + paste0("Parameter 'start1' and 'end1' must be lists indicating the ", + "day and the month of the period start and end. Full data ", + "will be used.") + ) + expect_warning( + MergeRefToExp(data1 = ref1, + data2 = data1, dates1 = as.vector(ref_dates1), + dates2 = dates_data1, start1 = start1, end1 = end1, + start2 = start2, end2 = end2), + paste0("Parameter 'dates1' must have named dimensions if 'start' and ", + "'end' are not NULL. All 'data1' will be used.") + ) +}) + +########################################################################### + +test_that("2. Output checks", { + res1 <- CST_MergeRefToExp(data1 = cube_ref, data2 = cube1, + start1 = start1, end1 = end1, + start2 = start2, end2 = end2) + # dims + expect_equal( + dim(res1$data), + res1$dims + ) + # coords + expect_equal( + names(dim(res1$data)), + names(res1$coords) + ) + # Dates + expect_equal( + dim(res1$data)[c('ftime', 'sdate')], + dim(res1$attrs$Dates) + ) +}) + +########################################################################### + +test_that("3. Output checks", { data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1993", "%d-%m-%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), @@ -19,12 +148,12 @@ test_that("Sanity checks", { data$attrs$Dates <- data_dates class(data) <- 's2dv_cube' -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), - end1 = list(30, 6), start2 = list(1, 7), - end2 = list(21, 9))$attrs$Dates, - SelectPeriodOnDates(ref_dates, start = list(21, 6), end = list(21,9))) -) + suppressWarnings( + expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), + end1 = list(30, 6), start2 = list(1, 7), + end2 = list(21, 9))$attrs$Dates, + SelectPeriodOnDates(ref_dates, start = list(21, 6), end = list(21,9))) + ) output <- array(c(1172:1181, 1:83, 1537:1546, 155:237, 1172:1181, 309:391, 1537:1546, 463:545), c(ftime = 93, sdate = 2, member = 2)) @@ -33,7 +162,8 @@ suppressWarnings( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), end1 = list(30, 6), start2 = list(1, 7), end2 = list(21, 9))$data, - output) + output + ) # issue 13: One lead time @@ -81,11 +211,11 @@ suppressWarnings( end2 = list(31, 7))$data, output ) - }) -test_that("Seasonal", { +########################################################################### +test_that("4. Test Seasonal", { dates <- NULL hcst.inityear <- 1993 hcst.endyear <- 2017 -- GitLab From 0a670a068a579d5d5cc7ca0227ea573eaaf058fc Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 14 Jul 2023 12:33:25 +0200 Subject: [PATCH 34/87] Update description of MergeRefToExp; correct CST_MergeRefToExp imports and description --- R/MergeRefToExp.R | 20 +++++++++++--------- man/CST_MergeRefToExp.Rd | 11 +++++------ man/MergeRefToExp.Rd | 6 +++++- 3 files changed, 21 insertions(+), 16 deletions(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 4f8e16f..abbdbe1 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -4,12 +4,11 @@ #'June 21st to September 21st). If the initialization forecast date is later #'than the one required for the indicator (e.g.: July 1st), the user may want to #'merge past observations, or other references, to the forecast (or hindcast) -#'to compute the indicator. The function \code{MergeObs2Exp} takes care of this -#'steps. If the forecast simulation doesn't cover the required period because it -#'is initialized too early (e.g.: Initialization on November 1st the forecast -#'covers until the beginning of June next year), a climatology (or other -#'references) could be added at the end of the forecast lead time to cover the -#'desired period (e.g.: until the end of summer). +#'to compute the indicator. If the forecast simulation doesn't cover the +#'required period because it is initialized too early (e.g.: Initialization on +#'November 1st the forecast covers until the beginning of June next year), a +#'climatology (or other references) could be added at the end of the forecast +#'lead time to cover the desired period (e.g.: until the end of summer). #' #'@param data1 An 's2dv_cube' object with the element 'data' being a #' multidimensional array of with named dimensions matching the dimensions of @@ -78,8 +77,7 @@ #'new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, #' start1 = list(21, 6), end1 = list(30, 6), #' start2 = list(1, 7), end2 = list(21, 9)) -#' -#'@import multiApply +#' #'@export CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, start2 = NULL, end2 = NULL, @@ -209,7 +207,11 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #'than the one required for the indicator (e.g.: July 1st), the user may want to #'merge past observations, or other reference, to the forecast (or hindcast) to #'compute the indicator. The function \code{MergeObs2Exp} takes care of this -#'steps. +#'steps. If the forecast simulation doesn't cover the required period because it +#'is initialized too early (e.g.: Initialization on November 1st the forecast +#'covers until the beginning of June next year), a climatology (or other +#'references) could be added at the end of the forecast lead time to cover the +#'desired period (e.g.: until the end of summer). #' #'@param data1 A multidimensional array of with named dimensions matching the #' dimensions of parameter 'data2'. Dimensions with the same name in the diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index f2195f2..67f35a9 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -79,12 +79,11 @@ Some indicators are defined for specific temporal periods (e.g.: summer from June 21st to September 21st). If the initialization forecast date is later than the one required for the indicator (e.g.: July 1st), the user may want to merge past observations, or other references, to the forecast (or hindcast) -to compute the indicator. The function \code{MergeObs2Exp} takes care of this -steps. If the forecast simulation doesn't cover the required period because it -is initialized too early (e.g.: Initialization on November 1st the forecast -covers until the beginning of June next year), a climatology (or other -references) could be added at the end of the forecast lead time to cover the -desired period (e.g.: until the end of summer). +to compute the indicator. If the forecast simulation doesn't cover the +required period because it is initialized too early (e.g.: Initialization on +November 1st the forecast covers until the beginning of June next year), a +climatology (or other references) could be added at the end of the forecast +lead time to cover the desired period (e.g.: until the end of summer). } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index 164606c..bd79c2f 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -83,7 +83,11 @@ June 21st to September 21st). If the initialization forecast date is later than the one required for the indicator (e.g.: July 1st), the user may want to merge past observations, or other reference, to the forecast (or hindcast) to compute the indicator. The function \code{MergeObs2Exp} takes care of this -steps. +steps. If the forecast simulation doesn't cover the required period because it +is initialized too early (e.g.: Initialization on November 1st the forecast +covers until the beginning of June next year), a climatology (or other +references) could be added at the end of the forecast lead time to cover the +desired period (e.g.: until the end of summer). } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), -- GitLab From bf9e36fefe8288f05934b7b0ca3aad788e407131 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 14 Jul 2023 14:23:14 +0200 Subject: [PATCH 35/87] Correct error of adding metadata to the resultant s2dv_cube --- R/MergeRefToExp.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index abbdbe1..8efa04f 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -186,7 +186,10 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, # Variable data1$attrs$Variable$varName <- unique(data1$attrs$Variable$varName, data2$attrs$Variable$varName) - data1$attrs$Variable$metadata <- intersect(data1$attrs$Variable, data2$attrs$Variable)[[2]] + names_metadata <- names(data1$attrs$Variable$metadata) + data1$attrs$Variable$metadata <- intersect(data1$attrs$Variable$metadata, + data2$attrs$Variable$metadata) + names(data1$attrs$Variable$metadata) <- names_metadata # source_files data1$attrs$source_files <- c(data1$attrs$source_files, data2$attrs$source_files) @@ -196,6 +199,12 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, # when data1$attrs$when <- Sys.time() + + # load_parameters (TO DO: remove with CST_Start) + if (!is.null(c(data1$attrs$load_parameters, data2$attrs$load_parameters))) { + data1$attrs$load_parameters <- list(data1 = data1$attrs$load_parameters, + data2 = data2$attrs$load_parameters) + } return(data1) } -- GitLab From 656acdd712d6d0bb789dee80f91db286784302d0 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 14 Jul 2023 14:35:14 +0200 Subject: [PATCH 36/87] Improve 's2dv_cube' attributes with adding not repeated metadata (added unique()) --- R/MergeRefToExp.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 8efa04f..ab626f9 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -192,10 +192,10 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, names(data1$attrs$Variable$metadata) <- names_metadata # source_files - data1$attrs$source_files <- c(data1$attrs$source_files, data2$attrs$source_files) + data1$attrs$source_files <- unique(c(data1$attrs$source_files, data2$attrs$source_files)) # Datasets - data1$attrs$Datasets <- c(data1$attrs$Datasets, data2$attrs$Datasets) + data1$attrs$Datasets <- unique(c(data1$attrs$Datasets, data2$attrs$Datasets)) # when data1$attrs$when <- Sys.time() -- GitLab From a632e22e5235decefb906c1de817a03fe8234b46 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 18 Jul 2023 18:22:17 +0200 Subject: [PATCH 37/87] Correct development with only allowing memb_dim and time_dim to be different between data1 and data2; improved documentation; added unit tests --- NAMESPACE | 1 - R/MergeRefToExp.R | 248 +++++++++++++--------------- man/CST_MergeRefToExp.Rd | 71 ++++---- man/MergeRefToExp.Rd | 83 +++++----- tests/testthat/test-MergeRefToExp.R | 95 ++++++++--- 5 files changed, 262 insertions(+), 236 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 8795a86..d80accb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,7 +26,6 @@ export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) import(multiApply) -importFrom(s2dv,InsertDim) importFrom(stats,approxfun) importFrom(stats,ecdf) importFrom(stats,quantile) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index ab626f9..03425c8 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -3,59 +3,58 @@ #'Some indicators are defined for specific temporal periods (e.g.: summer from #'June 21st to September 21st). If the initialization forecast date is later #'than the one required for the indicator (e.g.: July 1st), the user may want to -#'merge past observations, or other references, to the forecast (or hindcast) -#'to compute the indicator. If the forecast simulation doesn't cover the -#'required period because it is initialized too early (e.g.: Initialization on -#'November 1st the forecast covers until the beginning of June next year), a -#'climatology (or other references) could be added at the end of the forecast -#'lead time to cover the desired period (e.g.: until the end of summer). +#'merge past observations, or other references, to the forecast (or hindcast) to +#'compute the indicator. If the forecast simulation doesn't cover the required +#'period because it is initialized too early (e.g.: Initialization on November +#'1st the forecast covers until the beginning of June next year), a climatology +#'(or other references) could be added at the end of the forecast lead time to +#'cover the desired period (e.g.: until the end of summer). #' #'@param data1 An 's2dv_cube' object with the element 'data' being a -#' multidimensional array of with named dimensions matching the dimensions of -#' parameter 'data2'. Dimensions with the same name in the 'data2' parameter -#' must have the same length or length 1; except for the dimension specified -#' with 'memb_dim', which can be different and in the result will be filled -#' with NA values. It can also have additional dimensions with different names -#' in 'data2'. +#' multidimensional array with named dimensions. All dimensions must be +#' equal to 'data2' dimensions except for the ones specified with 'memb_dim' +#' and 'time_dim'. If 'start1' and 'end1' are used to subset a period, the +#' Dates must be stored in element '$attrs$Dates' of the object. Dates must +#' have same time dimensions as element 'data'. #'@param data2 An 's2dv_cube' object with the element 'data' being a -#' multidimensional array of dates with named dimensions matching -#' the dimensions on parameter 'data1'. Dimensions with the same name in the -#' 'data1' parameter must have the same length or length 1, except for the -#' dimension specified with 'memb_dim', which can be different and in the -#' result will be filled with NA values. +#' multidimensional array of named dimensions matching the dimensions of +#' parameter 'data1'. All dimensions must be equal to 'data1' except for the +#' ones specified with 'memb_dim' and 'time_dim'. If 'start2' and 'end2' are +#' used to subset a period, the Dates must be stored in element '$attrs$Dates' +#' of the object. Dates must have same time dimensions as element 'data'. #'@param start1 A list to define the initial date of the period to select from -#' data1 by providing a list of two elements: the initial date of the period +#' 'data1' by providing a list of two elements: the initial date of the period #' and the initial month of the period. #'@param end1 A list to define the final date of the period to select from -#' data1 by providing a list of two elements: the final day of the period and +#' 'data1' by providing a list of two elements: the final day of the period and #' the final month of the period. #'@param start2 A list to define the initial date of the period to select from -#' data2 by providing a list of two elements: the initial date of the period +#' 'data2' by providing a list of two elements: the initial date of the period #' and the initial month of the period. #'@param end2 A list to define the final date of the period to select from -#' data2 by providing a list of two elements: the final day of the period and +#' 'data2' by providing a list of two elements: the final day of the period and #' the final month of the period. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name -#' matching the dimensions provided in the object \code{data$data} can be -#' specified. This dimension is required to subset the data in a requested +#' dimension that will be used to combine the two arrays. By default, it is set +#' to 'ftime'. Also, it will be used to subset the data in a requested #' period. #'@param memb_dim A character string indicating the name of the member #' dimension. If the data are not ensemble ones, set as NULL. The default #' value is 'member'. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. -#'@return A 's2dv_cube' object containing the indicator in the element -#'\code{data}. The element \code{data} will be a multidimensional array with -#'dimensions named from the combination of 'data1' and 'data2'. The resulting -#'dimensions will be the following: all the same common dimensions between the -#'two arrays plus the different dimensions of each array. If there is any -#'different common dimension but in a dataset it has length 1, it will be added -#'with the maximum dimension. If memb_dim is used, the dimension of the maximum -#'value corresponding to memb_dim of the two data sets will be added; the -#'difference between the dimensions of the set members will be filled with NA. -#'The other elements of the 's2dv_cube' will be updated with the combined -#'information of both datasets. +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data}. The element \code{data} will be a multidimensional array created +#'from the combination of 'data1' and 'data2'. The resulting array will contain +#'the following dimensions: the original dimensions of the input data, which are +#'common to both arrays and for the 'time_dim' dimension, the sum of the +#'corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, +#'regarding member dimension, two different situations can occur: (1) in the +#'case that one of the arrays does not have member dimension or is equal to 1, +#'the result will contain the repeated values of itself; (2) in the case that +#'both arrays have member dimension and is greater than 1, all combinations of +#'member dimension will be returned. The other elements of the 's2dv_cube' will +#'be updated with the combined information of both datasets. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), @@ -64,7 +63,7 @@ #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) #'dim(data_dates) <- c(ftime = 154, sdate = 2) #'data <- NULL -#'data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member= 2)) +#'data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) #'data$attrs$Dates<- data_dates #'class(data) <- 's2dv_cube' #'ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), @@ -132,7 +131,8 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, data1$coords[[i_dim]] <- NULL data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] attr(data1$coords[[i_dim]], 'indices') <- TRUE - } else if (!identical(attributes(data1$coords[[i_dim]]), attributes(data2$coords[[i_dim]]))) { + } else if (!identical(attributes(data1$coords[[i_dim]]), + attributes(data2$coords[[i_dim]]))) { attributes(data1$coords[[i_dim]]) <- NULL } } else { @@ -214,60 +214,61 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #'Some indicators are defined for specific temporal periods (e.g.: summer from #'June 21st to September 21st). If the initialization forecast date is later #'than the one required for the indicator (e.g.: July 1st), the user may want to -#'merge past observations, or other reference, to the forecast (or hindcast) to -#'compute the indicator. The function \code{MergeObs2Exp} takes care of this -#'steps. If the forecast simulation doesn't cover the required period because it -#'is initialized too early (e.g.: Initialization on November 1st the forecast -#'covers until the beginning of June next year), a climatology (or other -#'references) could be added at the end of the forecast lead time to cover the -#'desired period (e.g.: until the end of summer). +#'merge past observations, or other references, to the forecast (or hindcast) to +#'compute the indicator. If the forecast simulation doesn't cover the required +#'period because it is initialized too early (e.g.: Initialization on November +#'1st the forecast covers until the beginning of June next year), a climatology +#'(or other references) could be added at the end of the forecast lead time to +#'cover the desired period (e.g.: until the end of summer). #' -#'@param data1 A multidimensional array of with named dimensions matching the -#' dimensions of parameter 'data2'. Dimensions with the same name in the -#' 'data2' parameter must have the same length or length 1; except for the -#' dimension specified with 'memb_dim', which can be different and in the -#' result will be filled with NA values. It can also have additional dimensions -#' with different names in 'data2'. +#'@param data1 A multidimensional array with named dimensions. All dimensions +#' must be equal to 'data2' dimensions except for the ones specified with +#' 'memb_dim' and 'time_dim'. #'@param dates1 A multidimensional array of dates with named dimensions matching -#' the temporal dimensions on parameter 'data1'. -#'@param data2 A multidimensional array of dates with named dimensions matching -#' the dimensions on parameter 'data1'. Dimensions with the same name in the -#' 'data1' parameter must have the same length or length 1, except for the -#' dimension specified with 'memb_dim', which can be different and in the -#' result will be filled with NA values. +#' the temporal dimensions of parameter 'data1'. The common dimensions must be +#' equal to 'data1' dimensions. +#'@param data2 A multidimensional array of named dimensions matching the +#' dimensions of parameter 'data1'. All dimensions must be equal to 'data1' +#' except for the ones specified with 'memb_dim' and 'time_dim'. #'@param dates2 A multidimensional array of dates with named dimensions matching -#' the temporal dimensions on parameter 'data2'. +#' the temporal dimensions on parameter 'data2'. The common dimensions must be +#' equal to 'data2' dimensions. #'@param start1 A list to define the initial date of the period to select from -#' data1 by providing a list of two elements: the initial date of the period -#' and the initial month of the period. +#' 'data1' by providing a list of two elements: the initial date of the period +#' and the initial month of the period. The initial date of the period must be +#' included in the 'dates1' array. #'@param end1 A list to define the final date of the period to select from -#' data1 by providing a list of two elements: the final day of the period and -#' the final month of the period. +#' 'data1' by providing a list of two elements: the final day of the period and +#' the final month of the period. The final date of the period must be +#' included in the 'dates1' array. #'@param start2 A list to define the initial date of the period to select from -#' data2 by providing a list of two elements: the initial date of the period -#' and the initial month of the period. +#' 'data2' by providing a list of two elements: the initial date of the period +#' and the initial month of the period. The initial date of the period must be +#' included in the 'dates2' array. #'@param end2 A list to define the final date of the period to select from -#' data2 by providing a list of two elements: the final day of the period and -#' the final month of the period. +#' 'data2' by providing a list of two elements: the final day of the period and +#' the final month of the period. The final date of the period must be +#' included in the 'dates2' array. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name -#' matching the dimensions provided in the object \code{data$data} can be -#' specified. This dimension is required to subset the data in a requested +#' dimension that will be used to combine the two arrays. By default, it is set +#' to 'ftime'. Also, it will be used to subset the data in a requested #' period. #'@param memb_dim A character string indicating the name of the member -#' dimension. If the data are not ensemble ones, set as NULL. The default -#' value is 'member'. +#' dimension. If the 'data1' and 'data2' have no member dimension, set it as +#' NULL. It is set as 'member' by default. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' -#'@return A multidimensional array with dimensions named from the combination of -#''data1' and 'data2'. The resulting dimensions will be the following: all the -#'same common dimensions between the two arrays plus the different dimensions of -#'each array. If there is any different common dimension but in a dataset it has -#'length 1, it will be added with the maximum dimension. If memb_dim is used, -#'the dimension of the maximum value corresponding to memb_dim of the two data -#'sets will be added; the difference between the dimensions of the set members -#'will be filled with NA. +#'@return A multidimensional array created from the combination of 'data1' and +#''data2'. The resulting array will contain the following dimensions: the +#'original dimensions of the input data, which are common to both arrays and for +#'the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' +#'and 'data2'. If 'memb_dim' is not null, regarding member dimension, two +#'different situations can occur: (1) in the case that one of the arrays does +#'not have member dimension or is equal to 1, the result will contain the +#'repeated values of itself; (2) in the case that both arrays have member +#'dimension and is greater than 1, all combinations of member dimension will be +#'returned. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), @@ -286,21 +287,20 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #' time_dim = 'ftime') #' #'@import multiApply -#'@importFrom s2dv InsertDim #'@export MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, start1 = NULL, end1 = NULL, start2 = NULL, end2 = NULL, time_dim = 'ftime', memb_dim = 'member', ncores = NULL) { # Input checks - # data + ## data1 and data2 if (!is.array(data1) | !is.array(data2)) { stop("Parameters 'data1' and 'data2' must be arrays.") } if (is.null(names(dim(data1))) | is.null(names(dim(data2)))) { stop("Parameters 'data1' and 'data2' must have named dimensions.") } - # time_dim + ## time_dim if (!is.character(time_dim)) { stop("Parameter 'time_dim' must be a character string.") } @@ -308,7 +308,9 @@ MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, stop("Parameter 'time_dim' is not found in 'data1' or 'data2' dimension ", "names.") } - # memb_dim + ## memb_dim + data1dims <- names(dim(data1)) + data2dims <- names(dim(data2)) if (!is.null(memb_dim)) { if (!is.character(memb_dim)) { stop("Parameter 'memb_dim' must be a character string.") @@ -317,65 +319,41 @@ MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, stop("Parameter 'memb_dim' is not found in 'data1' or 'data2' dimension. ", "Set it to NULL if there is no member dimension.") } - if (memb_dim %in% names(dim(data1))) { - if (dim(data1)[memb_dim] == 1) { - data1 <- array(data1, dim = dim(data1)[-which(names(dim(data1)) == memb_dim)]) - } - } - if (memb_dim %in% names(dim(data2))) { - if (dim(data2)[memb_dim] == 1) { - data2 <- array(data2, dim = dim(data2)[-which(names(dim(data2)) == memb_dim)]) - } - } - # Add NA to fill member_dim - if (memb_dim %in% names(dim(data1)) & memb_dim %in% names(dim(data2))) { + if ((memb_dim %in% names(dim(data1)) & memb_dim %in% names(dim(data2)))) { if (dim(data1)[memb_dim] != dim(data2)[memb_dim]) { - if (dim(data1)[memb_dim] > dim(data2)[memb_dim]) { - data2 <- Apply(list(data2), target_dims = memb_dim, - fun = function(x, length_new_dim) { - return(c(x, rep(NA, length_new_dim - length(x)))) - }, length_new_dim = dim(data1)[memb_dim], - output_dims = memb_dim)$output1 + if (dim(data1)[memb_dim] == 1) { + data1 <- array(data1, dim = dim(data1)[-which(names(dim(data1)) == memb_dim)]) + } else if (dim(data2)[memb_dim] == 1) { + data2 <- array(data2, dim = dim(data2)[-which(names(dim(data2)) == memb_dim)]) } else { + memb_dim1 <- dim(data1)[memb_dim] data1 <- Apply(list(data1), target_dims = memb_dim, - fun = function(x, length_new_dim) { - return(c(x, rep(NA, length_new_dim - length(x)))) - }, length_new_dim = dim(data2)[memb_dim], - output_dims = memb_dim)$output1 + fun = function(x, memb_rep) { + return(rep(x, each = memb_rep)) + }, memb_rep = dim(data2)[memb_dim], + output_dims = memb_dim, ncores = ncores)$output1 + data2 <- Apply(list(data2), target_dims = memb_dim, + fun = function(x, memb_rep) { + return(rep(x, memb_rep)) + }, memb_rep = memb_dim1, + output_dims = memb_dim, ncores = ncores)$output1 } } } } - - # Find common dims and remove the ones not needed + ## data1 and data2 (2) name_data1 <- sort(names(dim(data1))) name_data2 <- sort(names(dim(data2))) - commondims <- name_data1[name_data1 %in% name_data2] - commondims <- commondims[-which(commondims == time_dim)] + name_data1 <- name_data1[-which(name_data1 %in% c(time_dim, memb_dim))] + name_data2 <- name_data2[-which(name_data2 %in% c(time_dim, memb_dim))] - if (length(commondims) != 0) { - if (!all(dim(data2)[commondims] == dim(data1)[commondims])) { - dif_common <- commondims[!dim(data2)[commondims] == dim(data1)[commondims]] - if (any(dim(data2)[dif_common] == 1)) { - dim_remove <- dif_common[which(dim(data1)[dif_common] == 1)] - dim(data1) <- dim(data1)[-which(names(dim(data1)) == dim_remove)] - dif_common <- dif_common[-which(dif_common == dim_remove)] - } - if (any(dim(data1)[dif_common] == 1)) { - dim_remove <- dif_common[which(dim(data1)[dif_common] == 1)] - dim(data1) <- dim(data1)[-which(names(dim(data1)) == dim_remove)] - dif_common <- dif_common[-which(dif_common == dim_remove)] - } - if (length(dif_common) != 0) { - stop("Parameters 'data1' and 'data2' have common dimension ", - paste0("'", dif_common, sep = "' "), "with different length and ", - "different of length 1.") - } - } + if (!identical(length(name_data1), length(name_data2)) | + !identical(dim(data1)[name_data1], dim(data2)[name_data2])) { + stop(paste0("Parameter 'data1' and 'data2' must have same length of ", + "all dimensions except 'memb_dim'.")) } - - # dates1 + ## dates1 if (!is.null(start1) & !is.null(end1)) { if (is.null(dates1)) { warning("Parameter 'dates' is NULL and the average of the ", @@ -395,7 +373,7 @@ MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, } } } - # dates2 + ## dates2 if (!is.null(start2) & !is.null(end2)) { if (is.null(dates2)) { warning("Parameter 'dates2' is NULL and the average of the ", @@ -416,18 +394,14 @@ MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, } } - data1dims <- names(dim(data1)) - data2dims <- names(dim(data2)) - data1 <- Apply(list(data1, data2), target_dims = time_dim, fun = 'c', output_dims = time_dim, ncores = ncores)$output1 if (all(names(dim(data1)) %in% data1dims)) { - pos <- match(names(dim(data1)), data1dims) + pos <- match(data1dims, names(dim(data1))) data1 <- aperm(data1, pos) - } - if (all(names(dim(data1)) %in% data2dims)) { - pos <- match(names(dim(data1)), data2dims) + } else if (all(names(dim(data1)) %in% data2dims)) { + pos <- match(data2dims, names(dim(data1))) data1 <- aperm(data1, pos) } return(data1) diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index 67f35a9..bbca8c4 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -18,40 +18,38 @@ CST_MergeRefToExp( } \arguments{ \item{data1}{An 's2dv_cube' object with the element 'data' being a -multidimensional array of with named dimensions matching the dimensions of -parameter 'data2'. Dimensions with the same name in the 'data2' parameter -must have the same length or length 1; except for the dimension specified -with 'memb_dim', which can be different and in the result will be filled -with NA values. It can also have additional dimensions with different names -in 'data2'.} +multidimensional array with named dimensions. All dimensions must be +equal to 'data2' dimensions except for the ones specified with 'memb_dim' +and 'time_dim'. If 'start1' and 'end1' are used to subset a period, the +Dates must be stored in element '$attrs$Dates' of the object. Dates must +have same time dimensions as element 'data'.} \item{data2}{An 's2dv_cube' object with the element 'data' being a -multidimensional array of dates with named dimensions matching -the dimensions on parameter 'data1'. Dimensions with the same name in the -'data1' parameter must have the same length or length 1, except for the -dimension specified with 'memb_dim', which can be different and in the -result will be filled with NA values.} +multidimensional array of named dimensions matching the dimensions of +parameter 'data1'. All dimensions must be equal to 'data1' except for the +ones specified with 'memb_dim' and 'time_dim'. If 'start2' and 'end2' are +used to subset a period, the Dates must be stored in element '$attrs$Dates' +of the object. Dates must have same time dimensions as element 'data'.} \item{start1}{A list to define the initial date of the period to select from -data1 by providing a list of two elements: the initial date of the period +'data1' by providing a list of two elements: the initial date of the period and the initial month of the period.} \item{end1}{A list to define the final date of the period to select from -data1 by providing a list of two elements: the final day of the period and +'data1' by providing a list of two elements: the final day of the period and the final month of the period.} \item{start2}{A list to define the initial date of the period to select from -data2 by providing a list of two elements: the initial date of the period +'data2' by providing a list of two elements: the initial date of the period and the initial month of the period.} \item{end2}{A list to define the final date of the period to select from -data2 by providing a list of two elements: the final day of the period and +'data2' by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name -matching the dimensions provided in the object \code{data$data} can be -specified. This dimension is required to subset the data in a requested +dimension that will be used to combine the two arrays. By default, it is set +to 'ftime'. Also, it will be used to subset the data in a requested period.} \item{memb_dim}{A character string indicating the name of the member @@ -62,28 +60,29 @@ value is 'member'.} computation.} } \value{ -A 's2dv_cube' object containing the indicator in the element -\code{data}. The element \code{data} will be a multidimensional array with -dimensions named from the combination of 'data1' and 'data2'. The resulting -dimensions will be the following: all the same common dimensions between the -two arrays plus the different dimensions of each array. If there is any -different common dimension but in a dataset it has length 1, it will be added -with the maximum dimension. If memb_dim is used, the dimension of the maximum -value corresponding to memb_dim of the two data sets will be added; the -difference between the dimensions of the set members will be filled with NA. -The other elements of the 's2dv_cube' will be updated with the combined -information of both datasets. +An 's2dv_cube' object containing the indicator in the element +\code{data}. The element \code{data} will be a multidimensional array created +from the combination of 'data1' and 'data2'. The resulting array will contain +the following dimensions: the original dimensions of the input data, which are +common to both arrays and for the 'time_dim' dimension, the sum of the +corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, +regarding member dimension, two different situations can occur: (1) in the +case that one of the arrays does not have member dimension or is equal to 1, +the result will contain the repeated values of itself; (2) in the case that +both arrays have member dimension and is greater than 1, all combinations of +member dimension will be returned. The other elements of the 's2dv_cube' will +be updated with the combined information of both datasets. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from June 21st to September 21st). If the initialization forecast date is later than the one required for the indicator (e.g.: July 1st), the user may want to -merge past observations, or other references, to the forecast (or hindcast) -to compute the indicator. If the forecast simulation doesn't cover the -required period because it is initialized too early (e.g.: Initialization on -November 1st the forecast covers until the beginning of June next year), a -climatology (or other references) could be added at the end of the forecast -lead time to cover the desired period (e.g.: until the end of summer). +merge past observations, or other references, to the forecast (or hindcast) to +compute the indicator. If the forecast simulation doesn't cover the required +period because it is initialized too early (e.g.: Initialization on November +1st the forecast covers until the beginning of June next year), a climatology +(or other references) could be added at the end of the forecast lead time to +cover the desired period (e.g.: until the end of summer). } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), @@ -92,7 +91,7 @@ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) dim(data_dates) <- c(ftime = 154, sdate = 2) data <- NULL -data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member= 2)) +data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) data$attrs$Dates<- data_dates class(data) <- 's2dv_cube' ref_dates <- seq(as.Date("01-01-1993", "\%d-\%m-\%Y", tz = 'UTC'), diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index bd79c2f..e22b52d 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -19,75 +19,76 @@ MergeRefToExp( ) } \arguments{ -\item{data1}{A multidimensional array of with named dimensions matching the -dimensions of parameter 'data2'. Dimensions with the same name in the -'data2' parameter must have the same length or length 1; except for the -dimension specified with 'memb_dim', which can be different and in the -result will be filled with NA values. It can also have additional dimensions -with different names in 'data2'.} +\item{data1}{A multidimensional array with named dimensions. All dimensions +must be equal to 'data2' dimensions except for the ones specified with +'memb_dim' and 'time_dim'.} -\item{data2}{A multidimensional array of dates with named dimensions matching -the dimensions on parameter 'data1'. Dimensions with the same name in the -'data1' parameter must have the same length or length 1, except for the -dimension specified with 'memb_dim', which can be different and in the -result will be filled with NA values.} +\item{data2}{A multidimensional array of named dimensions matching the +dimensions of parameter 'data1'. All dimensions must be equal to 'data1' +except for the ones specified with 'memb_dim' and 'time_dim'.} \item{dates1}{A multidimensional array of dates with named dimensions matching -the temporal dimensions on parameter 'data1'.} +the temporal dimensions of parameter 'data1'. The common dimensions must be +equal to 'data1' dimensions.} \item{dates2}{A multidimensional array of dates with named dimensions matching -the temporal dimensions on parameter 'data2'.} +the temporal dimensions on parameter 'data2'. The common dimensions must be +equal to 'data2' dimensions.} \item{start1}{A list to define the initial date of the period to select from -data1 by providing a list of two elements: the initial date of the period -and the initial month of the period.} +'data1' by providing a list of two elements: the initial date of the period +and the initial month of the period. The initial date of the period must be +included in the 'dates1' array.} \item{end1}{A list to define the final date of the period to select from -data1 by providing a list of two elements: the final day of the period and -the final month of the period.} +'data1' by providing a list of two elements: the final day of the period and +the final month of the period. The final date of the period must be +included in the 'dates1' array.} \item{start2}{A list to define the initial date of the period to select from -data2 by providing a list of two elements: the initial date of the period -and the initial month of the period.} +'data2' by providing a list of two elements: the initial date of the period +and the initial month of the period. The initial date of the period must be +included in the 'dates2' array.} \item{end2}{A list to define the final date of the period to select from -data2 by providing a list of two elements: the final day of the period and -the final month of the period.} +'data2' by providing a list of two elements: the final day of the period and +the final month of the period. The final date of the period must be +included in the 'dates2' array.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name -matching the dimensions provided in the object \code{data$data} can be -specified. This dimension is required to subset the data in a requested +dimension that will be used to combine the two arrays. By default, it is set +to 'ftime'. Also, it will be used to subset the data in a requested period.} \item{memb_dim}{A character string indicating the name of the member -dimension. If the data are not ensemble ones, set as NULL. The default -value is 'member'.} +dimension. If the 'data1' and 'data2' have no member dimension, set it as +NULL. It is set as 'member' by default.} \item{ncores}{An integer indicating the number of cores to use in parallel computation.} } \value{ -A multidimensional array with dimensions named from the combination of -'data1' and 'data2'. The resulting dimensions will be the following: all the -same common dimensions between the two arrays plus the different dimensions of -each array. If there is any different common dimension but in a dataset it has -length 1, it will be added with the maximum dimension. If memb_dim is used, -the dimension of the maximum value corresponding to memb_dim of the two data -sets will be added; the difference between the dimensions of the set members -will be filled with NA. +A multidimensional array created from the combination of 'data1' and +'data2'. The resulting array will contain the following dimensions: the +original dimensions of the input data, which are common to both arrays and for +the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' +and 'data2'. If 'memb_dim' is not null, regarding member dimension, two +different situations can occur: (1) in the case that one of the arrays does +not have member dimension or is equal to 1, the result will contain the +repeated values of itself; (2) in the case that both arrays have member +dimension and is greater than 1, all combinations of member dimension will be +returned. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from June 21st to September 21st). If the initialization forecast date is later than the one required for the indicator (e.g.: July 1st), the user may want to -merge past observations, or other reference, to the forecast (or hindcast) to -compute the indicator. The function \code{MergeObs2Exp} takes care of this -steps. If the forecast simulation doesn't cover the required period because it -is initialized too early (e.g.: Initialization on November 1st the forecast -covers until the beginning of June next year), a climatology (or other -references) could be added at the end of the forecast lead time to cover the -desired period (e.g.: until the end of summer). +merge past observations, or other references, to the forecast (or hindcast) to +compute the indicator. If the forecast simulation doesn't cover the required +period because it is initialized too early (e.g.: Initialization on November +1st the forecast covers until the beginning of June next year), a climatology +(or other references) could be added at the end of the forecast lead time to +cover the desired period (e.g.: until the end of summer). } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), diff --git a/tests/testthat/test-MergeRefToExp.R b/tests/testthat/test-MergeRefToExp.R index effae50..57cd425 100644 --- a/tests/testthat/test-MergeRefToExp.R +++ b/tests/testthat/test-MergeRefToExp.R @@ -7,16 +7,16 @@ dates_data1 <- c(seq(as.Date("11-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("20-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) dim(dates_data1) <- c(ftime = 10, sdate = 2) cube1 <- NULL -cube1$data <- array(1:(2*10*2), c(ftime = 10, sdate = 2, member= 2)) +cube1$data <- array(1:(2*10*2), c(ftime = 10, sdate = 2, member = 2)) cube1$attrs$Dates <- dates_data1 class(cube1) <- 's2dv_cube' ref_dates1 <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), - as.Date("10-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), - seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), - as.Date("10-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) + as.Date("10-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("10-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) dim(ref_dates1) <- c(ftime = 10, sdate = 2) cube_ref <- NULL -cube_ref$data <- array(1001:1700, c(ftime = 10, sdate = 2)) +cube_ref$data <- array(1001:1020, c(ftime = 10, sdate = 2)) cube_ref$attrs$Dates <- ref_dates1 class(cube_ref) <- 's2dv_cube' start1 <- list(3, 7) @@ -25,8 +25,13 @@ start2 <- list(11, 7) end2 <- list(15, 7) # dat1 -ref1 <- array(1001:1700, c(ftime = 10, sdate = 2)) -data1 <- array(1:(2*154*2), c(ftime = 11, sdate = 2, member = 2)) +ref1 <- array(1001:1020, c(ftime = 10, sdate = 2, member = 1)) +data1 <- array(1:40, c(ftime = 10, sdate = 2, member = 2)) + + +# dat2 +ref2 <- array(1001:1015, c(ftime = 5, sdate = 1, member = 3)) +data2 <- array(1:6, c(ftime = 3, sdate = 1, member = 2)) ########################################################################### test_that("1. Input checks", { @@ -70,16 +75,23 @@ test_that("1. Input checks", { ) # common dimensions expect_error( - MergeRefToExp(data1 = array(1:12, c(sdate = 2, ftime = 2, var = 3)), + MergeRefToExp(data1 = array(1:12, c(sdate = 2, ftime = 2, dat = 3)), data2 = array(1:16, c(sdate = 2, ftime = 2, var = 4)), memb_dim = NULL), - paste0("Parameters 'data1' and 'data2' have common dimension 'var' ", - "with different length and different of length 1.") + paste0("Parameter 'data1' and 'data2' must have same length of ", + "all dimensions except 'memb_dim'.") + ) + expect_error( + MergeRefToExp(data1 = array(1:12, c(sdate = 2, ftime = 2, dat = 1)), + data2 = array(1:16, c(sdate = 2, ftime = 2)), + memb_dim = NULL), + paste0("Parameter 'data1' and 'data2' must have same length of ", + "all dimensions except 'memb_dim'.") ) # dates expect_warning( MergeRefToExp(data1 = array(1:4, c(sdate = 2, ftime = 2, lat = 1)), - data2 = array(1:16, c(sdate = 2, ftime = 2, lat = 4)), + data2 = array(1:16, c(sdate = 2, ftime = 2, lat = 1)), memb_dim = NULL, start1 = list(1, 1), end1 = list(3, 1), start2 = NULL, end2 = NULL), paste0("Parameter 'dates' is NULL and the average of the ", @@ -106,7 +118,7 @@ test_that("1. Input checks", { ########################################################################### -test_that("2. Output checks", { +test_that("2. Output checks: CST_MergeRefToExp", { res1 <- CST_MergeRefToExp(data1 = cube_ref, data2 = cube1, start1 = start1, end1 = end1, start2 = start2, end2 = end2) @@ -125,11 +137,54 @@ test_that("2. Output checks", { dim(res1$data)[c('ftime', 'sdate')], dim(res1$attrs$Dates) ) + # data + expect_equal( + res1$data[1:8,,1], + res1$data[1:8,,2] + ) }) ########################################################################### -test_that("3. Output checks", { +test_that("3. Output checks: MergeRefToExp", { + # Minimum dimensions + expect_equal( + MergeRefToExp(data1 = array(1:2, c(ftime = 2)), + data2 = array(1, c(ftime = 1)), memb_dim = NULL), + array(c(1,2,1), dim = c(ftime = 3)) + ) + # res2 + res2 <- MergeRefToExp(data1 = ref1, data2 = data1) + ## dims + expect_equal( + dim(res2), + c(ftime = 20, sdate = 2, member = 2) + ) + ## data + expect_equal( + res2[,1,], + array(c(1001:1010, 1:10, 1001:1010, 21:30), dim = c(ftime = 20, member = 2)) + ) + # res3: multiple different members + res3 <- MergeRefToExp(data1 = ref2, data2 = data2) + ## dims + expect_equal( + dim(res3), + c(ftime = 8, sdate = 1, member = 6) + ) + expect_equal( + as.vector(res3[1:5, 1, ]), + c(rep(1001:1005, 2), rep(1006:1010, 2), rep(1011:1015, 2)) + ) + expect_equal( + as.vector(res3[6:8, 1, ]), + rep(c(1:3, 4:6), 3) + ) +}) + +########################################################################### + +test_that("3. Output checks: Dates", { data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1993", "%d-%m-%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), @@ -152,7 +207,7 @@ test_that("3. Output checks", { expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), end1 = list(30, 6), start2 = list(1, 7), end2 = list(21, 9))$attrs$Dates, - SelectPeriodOnDates(ref_dates, start = list(21, 6), end = list(21,9))) + SelectPeriodOnDates(ref_dates, start = list(21, 6), end = list(21,9))) ) output <- array(c(1172:1181, 1:83, 1537:1546, 155:237, 1172:1181, 309:391, @@ -168,9 +223,9 @@ test_that("3. Output checks", { # issue 13: One lead time data_dates <- c(as.Date("01-06-1993", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), + as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-06-1994", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) + as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) dim(data_dates) <- c(ftime = 2, sdate = 2) ref_dates <- c(as.Date("01-05-1993", "%d-%m-%Y", tz = 'UTC'), @@ -193,7 +248,6 @@ test_that("3. Output checks", { as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) dim(res_dates) <- c(ftime = 3, sdate = 2) - expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), end1 = list(31, 5), start2 = list(1, 6), @@ -223,12 +277,11 @@ test_that("4. Test Seasonal", { dates <- c(dates, format(seq(as.Date(paste0("01-04-",year), "%d-%m-%Y", tz = 'UTC'), as.Date(paste0("01-11-",year), "%d-%m-%Y", - tz = 'UTC'), "day"), - "%Y-%m-%d")) + tz = 'UTC'), "day"), "%Y-%m-%d")) } dates <- as.Date(dates, tz = 'UTC') - dim.dates <- c(ftime=215, sweek = 1, sday = 1, - sdate=(hcst.endyear-hcst.inityear)+1) + dim.dates <- c(ftime = 215, sweek = 1, sday = 1, + sdate = (hcst.endyear - hcst.inityear) + 1) dim(dates) <- dim.dates ref <- NULL ref$data <- array(1:(215*25), c(ftime = 215, sdate = 25)) -- GitLab From 0ed82bc291fb826176be5aac5e5176890f19071d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 19 Jul 2023 12:34:58 +0200 Subject: [PATCH 38/87] Include publications: add new section in README and improve DESCRIPTION --- DESCRIPTION | 9 +++++---- README.md | 9 ++++++++- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 77a2156..c40d147 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,10 +21,11 @@ Description: Set of generalised tools for the flexible computation of climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with 'CSTools'. - This package was developed in the context of H2020 MED-GOLD (776467) and - S2S4E (776787) projects. - Lledó et al. (2019) . - Pérez-Zanón et al. (2023) . + This package is described in Pérez-Zanón et al. (2023) + and it was developed in the context of + H2020 MED-GOLD (776467) and S2S4E (776787) projects. See Lledó et al. (2019) + and Chou et al., 2023 + for details. Depends: R (>= 3.6.0) Imports: diff --git a/README.md b/README.md index 6607398..360ecbe 100644 --- a/README.md +++ b/README.md @@ -5,10 +5,17 @@ CSIndicators Set of generalised tools for the flexible computation of climate related indicators defined by the user. Each method represents a specific mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate service application (agriculture, food security, energy, water management…). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with [CSTools](https://earth.bsc.es/gitlab/external/cstools). -A scientific publication was published in the Climate Services Journal, and it can be cited as follows: +How to cite +----------- > Pérez-Zanón, N., Ho, A. Chou, C., Lledó, L., Marcos-Matamoros, R., Rifà, E. and González-Reviriego, N. (2023). CSIndicators: Get tailored climate indicators for applications in your sector. Climate Services. https://doi.org/10.1016/j.cliser.2023.100393 +For details in the methodologies see: + +> Pérez-Zanón, N., Caron, L.-P., Terzago, S., Van Schaeybroeck, B., Lledó, L., Manubens, N., Roulin, E., Alvarez-Castro, M. C., Batté, L., Bretonnière, P.-A., Corti, S., Delgado-Torres, C., Domínguez, M., Fabiano, F., Giuntoli, I., von Hardenberg, J., Sánchez-García, E., Torralba, V., and Verfaillie, D.: Climate Services Toolbox (CSTools) v4.0: from climate forecasts to climate forecast information, Geosci. Model Dev., 15, 6115–6142, https://doi.org/10.5194/gmd-15-6115-2022, 2022. +Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and N. González-Reviriego (2023). Advanced seasonal predictions for vine management based on bioclimatic indicators tailored to the wine sector. Climate Services, 30, 100343, https://doi.org/10.1016/j.cliser.2023.100343. +Lledó, Ll., V. Torralba, A. Soret, J. Ramon and F.J. Doblas-Reyes (2019). Seasonal forecasts of wind power generation. Renewable Energy, 143, 91-100, https://doi.org/10.1016/j.renene.2019.04.135. + Installation ------------ -- GitLab From 008f379d1a844bd713fad3defe5bea6d3935e43c Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 20 Jul 2023 13:20:42 +0200 Subject: [PATCH 39/87] Correct few examples due to time_dim value and add ClimProjDiags in Importd --- DESCRIPTION | 3 ++- R/PeriodMean.R | 4 ++-- R/WindCapacityFactor.R | 7 ++++--- R/WindPowerDensity.R | 7 ++++--- man/PeriodMean.Rd | 4 ++-- man/WindCapacityFactor.Rd | 4 ++-- man/WindPowerDensity.Rd | 4 ++-- 7 files changed, 18 insertions(+), 15 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4e20983..835c96b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,7 +27,8 @@ Depends: R (>= 3.6.0) Imports: multiApply (>= 2.1.1), - stats + stats, + ClimProjDiags Suggests: testthat, CSTools, diff --git a/R/PeriodMean.R b/R/PeriodMean.R index abc585a..db6a78f 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -147,7 +147,7 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'indicator in the element \code{data}. #' #'@examples -#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -156,7 +156,7 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'SA <- PeriodMean(data, dates = Dates, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index 760dba0..76092dd 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -80,7 +80,8 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II WindCapacity <- WindCapacityFactor(wind = wind$data, IEC_class = IEC_class, dates = wind$attrs$Dates, start = start, - end = end, ncores = ncores) + end = end, time_dim = time_dim, + ncores = ncores) wind$data <- WindCapacity wind$dims <- dim(WindCapacity) @@ -146,7 +147,7 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' #'@examples #'wind <- array(rweibull(n = 32100, shape = 2, scale = 6), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) #' #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), @@ -154,7 +155,7 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #' #'WCF <- WindCapacityFactor(wind, IEC_class = "III", dates = Dates, #' start = list(21, 4), end = list(21, 6)) diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index 3eba59a..3944e3d 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -68,7 +68,8 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, } WindPower <- WindPowerDensity(wind = wind$data, ro = ro, dates = wind$attrs$Dates, start = start, - end = end, ncores = ncores) + end = end, time_dim = time_dim, + ncores = ncores) wind$data <- WindPower wind$dims <- dim(WindPower) if ('Variable' %in% names(wind$attrs)) { @@ -122,14 +123,14 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #' #'@examples #'wind <- array(rweibull(n = 32100, shape = 2, scale = 6), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #'WPD <- WindPowerDensity(wind, dates = Dates, start = list(21, 4), #' end = list(21, 6)) #' diff --git a/man/PeriodMean.Rd b/man/PeriodMean.Rd index cd1fcef..9637d58 100644 --- a/man/PeriodMean.Rd +++ b/man/PeriodMean.Rd @@ -59,7 +59,7 @@ this function: } } \examples{ -data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -68,7 +68,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) SA <- PeriodMean(data, dates = Dates, start = list(01, 12), end = list(01, 01)) } diff --git a/man/WindCapacityFactor.Rd b/man/WindCapacityFactor.Rd index a0a7ce5..0b6b958 100644 --- a/man/WindCapacityFactor.Rd +++ b/man/WindCapacityFactor.Rd @@ -66,7 +66,7 @@ below). } \examples{ wind <- array(rweibull(n = 32100, shape = 2, scale = 6), - c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), @@ -74,7 +74,7 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) WCF <- WindCapacityFactor(wind, IEC_class = "III", dates = Dates, start = list(21, 4), end = list(21, 6)) diff --git a/man/WindPowerDensity.Rd b/man/WindPowerDensity.Rd index 8b72009..9ca3234 100644 --- a/man/WindPowerDensity.Rd +++ b/man/WindPowerDensity.Rd @@ -58,14 +58,14 @@ it will give inaccurate results if used with period means. } \examples{ wind <- array(rweibull(n = 32100, shape = 2, scale = 6), - c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) WPD <- WindPowerDensity(wind, dates = Dates, start = list(21, 4), end = list(21, 6)) -- GitLab From 443e5075e9a85a59a4974de5d65469d29e09a630 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 20 Jul 2023 18:16:56 +0200 Subject: [PATCH 40/87] Add new function PeriodPET, improve documentation and add unit tests --- R/PeriodPET.R | 297 +++++++++++++ R/PeriodSPEI.R | 726 ++++++++++++------------------- tests/testthat/test-PeriodPET.R | 178 ++++++++ tests/testthat/test-PeriodSPEI.R | 163 +++++-- 4 files changed, 868 insertions(+), 496 deletions(-) create mode 100644 R/PeriodPET.R create mode 100644 tests/testthat/test-PeriodPET.R diff --git a/R/PeriodPET.R b/R/PeriodPET.R new file mode 100644 index 0000000..fa4079c --- /dev/null +++ b/R/PeriodPET.R @@ -0,0 +1,297 @@ +#'Compute the Potential Evapotranspiration +#' +#'Compute the Potential evapotranspiration (PET) that is the amount of +#'evaporation and transpiration that would occur if a sufficient water source +#'were available. Reference evapotranspiration (ETo) is the amount of +#'evaporation and transpiration from a reference vegetation of grass. They are +#'usually considered equivalent. This set of functions calculate PET or ETo +#'according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +#' +#'@param data A named list with the needed \code{s2dv_cube} objects containing +#' the seasonal forecast experiment in the data element for each variable. +#' Specific variables are needed for each method used in computing the +#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted +#' variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and +#' 'hargreaves_modified' and 'tas', required for method 'thornthwaite'. +#' Variable 'prlr' is always needed. The units for temperature variables +#' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for +#' precipitation ('prlr') need to be in mm/month. +#'@param dates An array of temporal dimensions containing the Dates of +#' 'exp'. It must be of class 'Date' or 'POSIXct'. +#'@param lat A numeric vector containing the latitude values of 'exp'. +#'@param pet_method A character string indicating the method used to compute +#' the potential evapotranspiration. The accepted methods are: +#' 'hargreaves' and 'hargreaves_modified', that require the data to have +#' variables tasmin and tasmax; and 'thornthwaite', that requires variable +#' 'tas'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param lat_dim A character string indicating the name of the latitudinal +#' dimension. By default it is set by 'latitude'. +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@examples +#'dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) +#' +#'exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +#'end_year <- 2012 +#'dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), +#' paste0(2010:end_year, "-09-15"), +#' paste0(2010:end_year, "-10-16")), "UTC") +#'dim(dates_exp) <- c(syear = 3, time = 3) +#' +#'lat <- c(40) +#' +#'exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +#' +#'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) +#' +#'@import SPEI +#'@import lubridate +#'@import multiApply +#'@export +PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', + time_dim = 'syear', leadtime_dim = 'time', + lat_dim = 'latitude', na.rm = FALSE, + ncores = NULL) { + + # Initial checks + ## data + if (!inherits(data, 'list')) { + stop("Parameter 'data' needs to be a named list with the needed variables.") + } + if (is.null(names(data))) { + stop("Parameter 'data' needs to be a named list with the variable names.") + } + if (any(sapply(data, function(x) is.null(names(dim(x)))))) { + stop("Parameter 'data' needs to be a list of arrays with dimension names.") + } + dims <- lapply(data, function(x) dim(x)) + first_dims <- dims[[1]] + all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) + if (!all_equal) { + stop("Parameter 'data' variables need to have the same dimensions.") + } + # lat + if (!is.numeric(lat)) { + stop("Parameter 'lat' must be numeric.") + } + if (!lat_dim %in% names(dims[[1]])) { + stop("Parameter 'data' must have 'lat_dim' dimension.") + } + if (any(sapply(dims, FUN = function(x) x[lat_dim] != length(lat)))) { + stop("Parameter 'lat' needs to have the same length of latitudinal", + "dimension of all the variables arrays in 'data'.") + } + + # data (2) + if (all(c('tasmin', 'tasmax', 'prlr') %in% names(data))) { + # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' + if (!(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + warning("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves_modified'.") + pet_method <- 'hargreaves_modified' + } + } else if (all(c('tasmin', 'tasmax') %in% names(data))) { + if (!(pet_method %in% c('hargreaves'))) { + warning("Parameter 'pet_method' will be set as 'hargreaves'.") + pet_method <- 'hargreaves' + } + } else if (c('tas') %in% names(data)) { + # thornthwaite: 'tas' (mean), 'lat' + if (!(pet_method == 'thornthwaite')) { + warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") + pet_method <- 'thornthwaite' + } + } else { + stop("Parameter 'data' needs to be a named list with accepted ", + "variable names. See documentation.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!all(sapply(data, function(x) time_dim %in% names(dim(x))))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + ## leadtime_dim + if (!is.character(leadtime_dim) | length(leadtime_dim) != 1) { + stop("Parameter 'leadtime_dim' must be a character string.") + } + if (!all(sapply(data, function(x) leadtime_dim %in% names(dim(x))))) { + stop("Parameter 'leadtime_dim' is not found in 'data' dimension.") + } + ## lat_dim + if (!is.character(lat_dim) | length(lat_dim) != 1) { + stop("Parameter 'lat_dim' must be a character string.") + } + if (!all(sapply(data, function(x) lat_dim %in% names(dim(x))))) { + stop("Parameter 'lat_dim' is not found in 'data' dimension.") + } + # dates + if (is.null(dates)) { + stop("Parameter 'dates' is missing, dates must be provided.") + } + if (!(is.Date(dates)) & !(is.POSIXct(dates))) { + stop("Parameter 'dates' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!time_dim %in% names(dim(dates)) | !leadtime_dim %in% names(dim(dates))) { + stop("Parameter 'dates' must have 'time_dim' and 'leadtime_dim' ", + "dimension.") + } + if (!all(dim(data[[1]])[c(time_dim, leadtime_dim)] == + dim(dates)[c(time_dim, leadtime_dim)])) { + stop("Parameter 'dates' needs to have the same length as 'time_dim' ", + "and 'leadtime_dim' as 'data'.") + } + ## na.rm + if (!is.logical(na.rm) | length(na.rm) > 1) { + stop("Parameter 'na.rm' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + # complete dates + dates_monthly <- .datesmask(dates) + + lat_mask <- array(lat, dim = c(1, length(lat))) + names(dim(lat_mask)) <- c('dat', lat_dim) + + # extract mask of NA locations to return to NA the final result + mask_na <- array(1, dim = dim(data[[1]])) + if (pet_method == 'hargreaves') { + varnames <- c('tasmax', 'tasmin') + mask_na[which(is.na(data$tasmax))] <- 0 + mask_na[which(is.na(data$tasmin))] <- 0 + } else if (pet_method == 'hargreaves_modified') { + varnames <- c('tasmax', 'tasmin', 'prlr') + mask_na[which(is.na(data$tasmax))] <- 0 + mask_na[which(is.na(data$tasmin))] <- 0 + mask_na[which(is.na(data$prlr))] <- 0 + } else if (pet_method == 'thornthwaite') { + varnames <- c('tas') + mask_na[which(is.na(data$tas))] <- 0 + } + + # replace NA with 0 + for (dd in 1:length(data)) { + data[[dd]][which(is.na(data[[dd]]))] <- 0 + } + + # prepare data + target_dims_data <- lapply(data[varnames], function(x) rep(c(leadtime_dim, time_dim), 1)) + pet <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), + target_dims = c(list(lat_mask = 'dat'), target_dims_data), + fun = .pet, + dates_monthly = dates_monthly, pet_method = pet_method, + leadtime_dim = leadtime_dim, time_dim = time_dim, + output_dims = c(leadtime_dim, time_dim), + ncores = ncores)$output1 + # reorder dims in pet_estimated + pos <- match(names(dim(data[[1]])), names(dim(pet))) + pet <- aperm(pet, pos) + + # restore original NAs from mask_na + pet[which(mask_na == 0)] <- NA + + return(pet) +} + +.pet <- function(lat_mask, data2, data3 = NULL, data4 = NULL, + dates_monthly, pet_method = 'hargreaves', + leadtime_dim = 'time', time_dim = 'syear') { + + dims <- dim(data2) + + # create a vector from data but adding 0 to achive complete time series + # of the considered period + # (starting in January of the first year) so that the solar radiation + # estimation is computed in each case for the correct month + + if (!is.null(data2)) { + data_tmp <- as.vector(data2) + data2 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data2[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (!is.null(data3)) { + data_tmp <- as.vector(data3) + data3 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data3[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (!is.null(data4)) { + data_tmp <- as.vector(data4) + data4 <- array(0, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data4[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (pet_method == 'hargreaves') { + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = FALSE, verbose = FALSE) + # line to return the vector to the size of the actual original data + pet <- array(pet[which(dates_monthly == 1)], dim = dims) + } + + if (pet_method == 'hargreaves_modified') { + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, + verbose = FALSE) + pet <- array(pet[which(dates_monthly == 1)], dim = dims) + } + + if (pet_method == 'thornthwaite') { + pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, + verbose = FALSE) + # line to return the vector to the size of the actual original data + pet <- array(pet[which(dates_monthly == 1)], dim = dims) + } + return(pet) +} + + +.datesmask <- function(dates) { + ini <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep = '-')) + end <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep = '-')) + daily <- as.Date(ini:end) + monthly <- daily[which(lubridate::day(daily) == 1)] + dates_mask <- array(0, dim = length(monthly)) + for (dd in 1:length(dates)) { + ii <- which(monthly == as.Date(paste(lubridate::year(dates[dd]), + lubridate::month(dates[dd]), + 01, sep = '-'))) + dates_mask[ii] <- 1 + } + return(dates_mask) +} \ No newline at end of file diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 8a0b7e2..9bc1660 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -1,14 +1,42 @@ #'Compute the Standardised Precipitation-Evapotranspiration Index -#' +#' #'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) #'that is a multiscalar drought index based on climatic data. It can be used for #'determining the onset, duration and magnitude of drought conditions with #'respect to normal conditions in a variety of natural and managed systems such -#'as crops, ecosystems, rivers, water resources, etc. The SPI is calculated -#'using monthly (or weekly) precipitation as the input data. The SPEI uses the -#'monthly (or weekly) difference between precipitation and pet. This represents -#'a simple climatic water balance which is calculated at different time scales -#'to obtain the SPEI. +#'as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI +#'is to compare the highest possible evapotranspiration with the current water +#'availability. The SPEI uses the monthly (or weekly) difference between +#'precipitation and potential evapotranspiration. This represents a simple +#'climatic water balance which is calculated at different time scales to obtain +#'the SPEI. This function is build to work be compatible with other tools in +#'that work with 's2dv_cube' object class. The input data must be this object +#'class. If you don't work with 's2dv_cube', see PeriodSPEI. +#' +#'Next, some specifications for the calculation of this indicator will be +#'discussed. On the one hand, the model to be used to calculate potential +#'evapotranspiration is specified with the pet_method parameter (hargreaves, +#'hargraves modified or thornwhite). On the other hand, to choose the time scale +#'in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the +#'accum parameter, where you must indicate the number of time steps you want to +#'accumulate throughout leadtime_dim. Since the accumulation is done for the +#'elapsed time steps, there will be no complete accumulations until reaching the +#'time instant equal to the value of the parameter. For this reason, in the +#'result, we will find that for the dimension where the accumulation has been +#'carried out, the values of the array will be NA since they do not include +#'complete accumulations. Also, there is a parameter to specify if the +#'standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a +#'probability distribution to transform the original values to standardized +#'units that are comparable in space and time and at different SPEI time scales. +#'The na.rm parameter is a logical parameter used to decide whether to remove +#'the NA values from the data before doing the calculation. It must be taken +#'into account that if na.rm == FALSE and there is some NA value in the specific +#'coordinates which the SPEI is computed, standardization cannot be carried out +#'for those coordinates and therefore, the result will be filled with NA for the +#'specific coordinates. However, when na.rm == TRUE, if the amount of data for +#'those specific coordinates is smaller than 4, it will not be possible to carry +#'out because we will not have enough data and the result will be also filled +#'with NAs for that coordinates. #' #'@param exp A named list with the needed \code{s2dv_cube} objects containing #' the seasonal forecast experiment in the data element for each variable. @@ -32,7 +60,9 @@ #'@param lat_dim A character string indicating the name of the latitudinal #' dimension. By default it is set by 'latitude'. #'@param accum An integer value indicating the number of months for the -#' accumulation for each variable. +#' accumulation for each variable. When it is greater than 1, the result will +#' be filled with NA until the accum time_dim dimension number due to the +#' accumulation to previous months. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be @@ -68,33 +98,31 @@ #' default. #'@param distribution A character string indicating the name of the distribution #' function to be used for computing the SPEI. The accepted names are: -#' 'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by -#' default. -#'@param fit A character string indicating the name of the method used for -#' computing the distribution function parameters The accepteed names are: -#' 'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default. +#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +#' 'Gamma' method only works when only precipitation is provided and other +#' variables are 0 because it is positive defined (SPI indicator). #'@param param_error A numeric value with the error accepted. #'@param handle_infinity A logical value wether to return Infinite values (TRUE) #' or not (FALSE). #'@param na.rm A logical value indicating whether NA values should be removed -#' from data. It is FALSE by default. +#' from data. It is FALSE by default. If it is FALSE and there are NA values, +#' (if standardization is TRUE) all values of other dimensions except time_dim +#' and leadtime_dim will be set to NA directly. On the other hand, if it is +#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is +#' not reaching 4 values, it is not enough values to estimate the parameters +#' and the result will include NA. #'@param ncores An integer value indicating the number of cores to use in #' parallel computation. #' -#'@return A list with elements: -#'\itemize{ -#' \item{'exp', if 'standarization' is TRUE an 's2dv_cube' conaining the 'SPEI' -#' in element data from 'exp' array with the same dimensions as 'exp'. -#' If it is FALSE, it is an array with the accumulated values of PET -#' minus 'prlr' data.} -#' \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not -#' NULL. It is an 's2dv_cube' with the SPEI data from 'exp_cor' in -#' element 'data'. If 'standarization' is FALSE, only the accumulated -#' values of PET minus 'prlr' is returned.} -#' \item{'params', returned if 'standarization' is TRUE, it contains the -#' parameters used for the standarization of 'exp' that are used for -#' computing the 'SPEI' for 'exp_cor'.} -#' } +#'@return An 's2dv_cube' object containing the SPEI multidimensional array in +#'element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' +#'will be provided. The parameters of the standardization will only be returned +#'if 'return_params' is TRUE. The SPEI will only be computed if +#''standardization' is TRUE. If 'standardization' is FALSE, only the climatic +#'water balance (precipitation minus evapotranspiration) will be returned. The +#'resultant arrays will have the same dimensions as the initial input data. The +#'other elements in the 's2dv_cube' will be updated with the combined +#'information of the input data arrays. #' #'@examples #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, @@ -147,9 +175,10 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, cross_validation = FALSE, pet_method = 'hargreaves', method = 'parametric', - distribution = 'log-Logistic', fit = 'ub-pwm', + distribution = 'log-Logistic', param_error = -9999, handle_infinity = FALSE, - na.rm = FALSE, ncores = NULL) { + return_params = FALSE, na.rm = FALSE, + ncores = NULL) { # Check 's2dv_cube' if (is.null(exp)) { @@ -199,65 +228,98 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, standardization = standardization, cross_validation = cross_validation, pet_method = pet_method, method = method, - distribution = distribution, fit = fit, - param_error = param_error, - handle_infinity = handle_infinity, na.rm = na.rm, + distribution = distribution, + param_error = param_error, handle_infinity = handle_infinity, + return_params = return_params, na.rm = na.rm, ncores = ncores) - if (is.null(exp_cor)) { + + if (!is.null(exp_cor)) { + source_files_expcor <- lapply(exp_cor, function(x) {x$attrs$source_files}) source_files <- lapply(exp, function(x) {x$attrs$source_files}) - suppressWarnings( - res_exp <- CSTools::s2dv_cube(data = res[[1]], coords = exp[[1]]$coords, - varName = c('SPEI'), - Dates = exp[[1]]$attrs$Dates, - source_files = source_files, - when = Sys.time()) - ) - if (standardization) { - return(list(exp = res_exp, params = res[[2]])) - } else { - return(res_exp) - } + source_files <- c(exp = source_files, exp_cor = source_files_expcor) + coords <- exp_cor[[1]]$coords + Dates <- exp_cor[[1]]$attrs$Dates + metadata <- exp_cor[[1]]$attrs$Variable$metadata + metadata_names <- names(metadata) } else { - source_files_exp <- lapply(exp, function(x) {x$attrs$source_files}) + source_files <- lapply(exp, function(x) {x$attrs$source_files}) + coords <- exp[[1]]$coords + Dates <- exp[[1]]$attrs$Dates + metadata <- exp[[1]]$attrs$Variable$metadata + metadata_names <- names(metadata) + } + + if (standardization) { + varname <- 'SPEI' + } else { + varname <- 'Precipitation minus accumulated PET' + } + + if (return_params & standardization) { + metadata_names <- intersect(names(dim(res[[1]])), metadata_names) suppressWarnings( - res_exp <- CSTools::s2dv_cube(data = res[[1]], coords = exp[[1]]$coords, - varName = c('SPEI'), - Dates = exp[[1]]$attrs$Dates, - source_files = source_files_exp, - when = Sys.time()) + res[[1]] <- CSTools::s2dv_cube(data = res[[1]], coords = coords, + varName = varname, + metadata = metadata[metadata_names], + Dates = Dates, + source_files = source_files, + when = Sys.time()) ) - source_files_expcor <- lapply(exp_cor, function(x) {x$attrs$source_files}) + return(list(spei = res[[1]], params = res[[2]])) + } else { + metadata_names <- intersect(names(dim(res)), metadata_names) suppressWarnings( - res_expcor <- CSTools::s2dv_cube(data = res[[2]], coords = exp_cor[[1]]$coords, - varName = c('SPEI'), - Dates = exp_cor[[1]]$attrs$Dates, - source_files = source_files_expcor, - when = Sys.time()) + res <- CSTools::s2dv_cube(data = res, coords = coords, + varName = varname, + metadata = metadata[metadata_names], + Dates = Dates, + source_files = source_files, + when = Sys.time()) ) - - if (standardization) { - return(list(exp = res_exp, exp_cor = res_expcor, params = res[[3]])) - } else { - return(list(exp = res_exp, exp_cor = res_expcor)) - } + return(res) } - return(res) } #'Compute the Standardised Precipitation-Evapotranspiration Index -#' +#' #'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) #'that is a multiscalar drought index based on climatic data. It can be used for #'determining the onset, duration and magnitude of drought conditions with #'respect to normal conditions in a variety of natural and managed systems such -#'as crops, ecosystems, rivers, water resources, etc. The SPI is calculated -#'using monthly (or weekly) precipitation as the input data. The SPEI uses the -#'monthly (or weekly) difference between precipitation and pet. This represents -#'a simple climatic water balance which is calculated at different time scales -#'to obtain the SPEI. +#'as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI +#'is to compare the highest possible evapotranspiration with the current water +#'availability. The SPEI uses the monthly (or weekly) difference between +#'precipitation and potential evapotranspiration. This represents a simple +#'climatic water balance which is calculated at different time scales to obtain +#'the SPEI. #' -#'@param exp A named list with the needed \code{s2dv_cube} objects containing +#'Next, some specifications for the calculation of this indicator will be +#'discussed. On the one hand, the model to be used to calculate potential +#'evapotranspiration is specified with the pet_method parameter (hargreaves, +#'hargraves modified or thornwhite). On the other hand, to choose the time scale +#'in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the +#'accum parameter, where you must indicate the number of time steps you want to +#'accumulate throughout leadtime_dim. Since the accumulation is done for the +#'elapsed time steps, there will be no complete accumulations until reaching the +#'time instant equal to the value of the parameter. For this reason, in the +#'result, we will find that for the dimension where the accumulation has been +#'carried out, the values of the array will be NA since they do not include +#'complete accumulations. Also, there is a parameter to specify if the +#'standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a +#'probability distribution to transform the original values to standardized +#'units that are comparable in space and time and at different SPEI time scales. +#'The na.rm parameter is a logical parameter used to decide whether to remove +#'the NA values from the data before doing the calculation. It must be taken +#'into account that if na.rm == FALSE and there is some NA value in the specific +#'coordinates which the SPEI is computed, standardization cannot be carried out +#'for those coordinates and therefore, the result will be filled with NA for the +#'specific coordinates. However, when na.rm == TRUE, if the amount of data for +#'those specific coordinates is smaller than 4, it will not be possible to carry +#'out because we will not have enough data and the result will be also filled +#'with NAs for that coordinates. +#' +#'@param exp A named list with multidimensional array objects containing #' the seasonal forecast experiment in the data element for each variable. #' Specific variables are needed for each method used in computing the #' Potential Evapotranspiration. See parameter 'pet_method'. The accepted @@ -269,7 +331,7 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'@param dates_exp An array of temporal dimensions containing the Dates of #' 'exp'. It must be of class 'Date' or 'POSIXct'. #'@param lat A numeric vector containing the latitude values of 'exp'. -#'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each +#'@param exp_cor A named list with multidimensional array objects for each #' variable in which the quantile PeriodSPEI should be applied. If it is not #' specified, the PeriodSPEI is calculated from object 'exp'. #'@param dates_expcor An array of temporal dimensions containing the Dates of @@ -283,8 +345,10 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' computed for individual members. #'@param lat_dim A character string indicating the name of the latitudinal #' dimension. By default it is set by 'latitude'. -#'@param accum An integer value indicating the number of months for the -#' accumulation for each variable. +#'@param accum accum An integer value indicating the number of months for the +#' accumulation for each variable. When it is greater than 1, the result will +#' be filled with NA until the accum time_dim dimension number due to the +#' accumulation to previous months. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be @@ -318,32 +382,31 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' If can be: 'parametric' or 'non-parametric'. #'@param distribution A character string indicating the name of the distribution #' function to be used for computing the SPEI. The accepted names are: -#' 'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by -#' default. -#'@param fit A character string indicating the name of the method used for -#' computing the distribution function parameters The accepteed names are: -#' 'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default. +#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +#' 'Gamma' method only works when only precipitation is provided and other +#' variables are 0 because it is positive defined (SPI indicator). #'@param param_error A numeric value with the error accepted. #'@param handle_infinity A logical value wether to return Infinite values (TRUE) #' or not (FALSE). +#'@param return_params A logical value indicating wether to return parameters +#' array (TRUE) or not (FALSE). It is FALSE by default. #'@param na.rm A logical value indicating whether NA values should be removed -#' from data. It is FALSE by default. +#' from data. It is FALSE by default. If it is FALSE and there are NA values, +#' (if standardization is TRUE) all values of other dimensions except time_dim +#' and leadtime_dim will be set to NA directly. On the other hand, if it is +#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is +#' not reaching 4 values, it is not enough values to estimate the parameters +#' and the result will include NA. #'@param ncores An integer value indicating the number of cores to use in #' parallel computation. #' -#'@return A list with elements: -#'\itemize{ -#' \item{'exp', if 'standarization' is TRUE an array conaining SPEI data from -#' 'exp' array with the same dimensions as 'exp'. If it is FALSE, it -#' is an array with the accumulated values of PET minus 'prlr' data.} -#' \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not -#' NULL. It is an array with the SPEI data from 'exp_cor'. If -#' 'standarization' is FALSE, only the accumulated values of PET minus -#' 'prlr' is returned.} -#' \item{'params', returned if 'standarization' is TRUE, it contains the -#' parameters used for the standarization of 'exp' that are used for -#' computing the 'SPEI' for 'exp_cor'.} -#'} +#'@return An 's2dv_cube' object containing the SPEI multidimensional array in +#'element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' +#'will be provided. The parameters of the standardization will only be returned +#'if 'return_params' is TRUE. The SPEI will only be computed if +#''standardization' is TRUE. If 'standardization' is FALSE, only the climatic +#'water balance (precipitation minus evapotranspiration) will be returned. The +#'resultant arrays will have the same dimensions as the initial input data. #' #'@examples #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, @@ -391,9 +454,9 @@ PeriodSPEI <- function(exp, dates_exp, lat, pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, cross_validation = FALSE, pet_method = 'hargreaves', method = 'parametric', - distribution = 'log-Logistic', fit = 'ub-pwm', + distribution = 'log-Logistic', param_error = -9999, handle_infinity = FALSE, - na.rm = FALSE, ncores = NULL) { + return_params = FALSE, na.rm = FALSE, ncores = NULL) { # Initial checks ## exp @@ -413,7 +476,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'exp' variables need to have the same dimensions.") } - ## exp_cor if (!is.null(exp_cor)) { if (!inherits(exp_cor, 'list')) { @@ -433,53 +495,24 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'exp_cor' variables need to have the same dimensions.") } } - - # lat - if (!is.numeric(lat)) { - stop("Parameter 'lat' must be numeric.") - } - if (!lat_dim %in% names(dims[[1]])) { - stop("Parameter 'exp' must have 'lat_dim' dimension.") - } - if (any(sapply(dims, FUN = function(x) x[lat_dim] != length(lat)))) { - stop("Parameter 'lat' needs to have the same length of latitudinal", - "dimension of all the variables arrays in 'exp'.") - } - if (!is.null(exp_cor)) { - if (!lat_dim %in% names(dimscor[[1]])) { - stop("Parameter 'exp_cor' must have 'lat_dim' dimension.") - } - if (any(sapply(dimscor, FUN = function(x) x[lat_dim] != length(lat)))) { - stop("Parameter 'lat' needs to have the same length of latitudinal", - "dimension of all the variables arrays in 'exp'.") - } - } - # Variable checks ## exp (2) pet <- vector("list", 2) - if (is.null(pet_exp)) { - if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp))) { - # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' - if (!(pet_method[1] %in% c('hargreaves_modified', 'hargreaves'))) { - warning("Parameter 'pet_method' needs to be 'hargreaves' or ", - "'hargreaves_modified'. It is set to 'hargreaves'.") - pet_method[1] <- 'hargreaves' - } - } else if (all(c('tas', 'prlr') %in% names(exp))) { - # thornthwaite: 'tas' (mean), 'lat' - if (!(pet_method[1] == 'thornthwaite')) { - warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") - pet_method[1] <- 'thornthwaite' - } - } else { - stop("Parameter 'exp' needs to be a named list with accepted ", - "variable names if 'pet_exp' is not provided. See documentation.") + if (!('prlr' %in% names(exp))) { + stop("Variable 'prlr' is not included in 'exp'.") + } + ## exp_cor (2) + if (!is.null(exp_cor)) { + if (!('prlr' %in% names(exp_cor))) { + stop("Variable 'prlr' is not included in 'exp_cor'.") } - } else { - if (!('prlr' %in% names(exp))) { - stop("Variable 'prlr' is not included in 'exp'.") + if (length(pet_method) == 1) { + pet_method <- rep(pet_method, 2) } + } + + ## pet_exp + if (!is.null(pet_exp)) { if (length(dim(exp[['prlr']])) != length(dim(pet_exp))) { stop("Parameter 'pet_exp' must have the same length of all the ", "dimensions as variable 'prlr' in 'exp'.") @@ -493,53 +526,27 @@ PeriodSPEI <- function(exp, dates_exp, lat, pet_exp <- aperm(pet_exp, pos) } pet[[1]] <- pet_exp + } else if (is.null(dates_exp)) { + stop("Parameter 'dates_exp' must be provided.") } - ## exp_cor (2) + ## pet_expcor if (!is.null(exp_cor)) { - if (is.null(pet_expcor)) { - if (length(exp_cor) < 1) { - exp_cor <- NULL - } else { - if (length(pet_method) == 1) { - pet_method <- rep(pet_method, 2) - } + if (!is.null(pet_expcor)) { + if (length(dim(exp_cor[['prlr']])) != length(dim(pet_expcor))) { + stop("Parameter 'pet_expcor' must have the same length of all the ", + "dimensions as variable 'prlr' in 'exp_cor'.") } - if (all(c('tasmin', 'tasmax', 'prlr') %in% names(exp_cor))) { - # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' - if (!(pet_method[2] %in% c('hargreaves_modified', 'hargreaves'))) { - warning("Parameter 'pet_method' needs to be 'hargreaves' or ", - "'hargreaves_modified'. It is set to 'hargreaves'.") - pet_method[2] <- 'hargreaves' - } - } else if (all(c('tas', 'prlr') %in% names(exp_cor))) { - # thornthwaite: 'tas' (mean), 'lat' - if (!(pet_method[2] == 'thornthwaite')) { - warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") - pet_method[2] <- 'thornthwaite' - } - } else { - stop("Parameter 'exp_cor' needs to be a list with the needed ", - "variables if 'pet_expcor' is not provided.") - } - } else { - if (!is.null(exp_cor)) { - if (!('prlr' %in% names(exp_cor))) { - stop("Variable 'prlr' is not included in 'exp_cor'.") - } - if (length(dim(exp_cor[['prlr']])) != length(dim(pet_expcor))) { - stop("Parameter 'pet_expcor' must have the same length of all the ", - "dimensions as variable 'prlr' in 'exp_cor'.") - } - if (!all(dim(exp_cor[['prlr']]) %in% dim(pet_expcor))) { - stop("Parameter 'pet_expcor' must have the same length of all the ", - "dimensions as variable 'prlr' in 'exp_cor'.") - } - if (any(names(dim(exp_cor[['prlr']])) != names(dim(pet_expcor)))) { - pos <- match(names(dim(exp_cor[['prlr']])), names(dim(pet_expcor))) - pet_expcor <- aperm(pet_expcor, pos) - } + if (!all(dim(exp_cor[['prlr']]) %in% dim(pet_expcor))) { + stop("Parameter 'pet_expcor' must have the same length of all the ", + "dimensions as variable 'prlr' in 'exp_cor'.") } + if (any(names(dim(exp_cor[['prlr']])) != names(dim(pet_expcor)))) { + pos <- match(names(dim(exp_cor[['prlr']])), names(dim(pet_expcor))) + pet_expcor <- aperm(pet_expcor, pos) + } pet[[2]] <- pet_expcor + } else if (is.null(dates_expcor)) { + stop("Parameter 'dates_expcor' must be provided.") } } @@ -579,6 +586,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'memb_dim' is not found in 'exp_cor' dimension.") } } + ## lat_dim if (!is.character(lat_dim) | length(lat_dim) != 1) { stop("Parameter 'lat_dim' must be a character string.") @@ -591,7 +599,8 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'lat_dim' is not found in 'exp_cor' dimension.") } } - # dates + + ## dates if (is.null(dates_exp)) { stop("Parameter 'dates_exp' is missing, dates must be provided.") } @@ -628,12 +637,41 @@ PeriodSPEI <- function(exp, dates_exp, lat, "'time_dim' and 'leadtime_dim' as 'exp_cor'.") } } + ## accum if (accum > dim(exp[[1]])[leadtime_dim]) { stop(paste0("Cannot compute accumulation of ", accum, " months because ", "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) } + ## ref_period + if (!is.null(ref_period)) { + if (length(ref_period) != 2) { + warning("Parameter 'ref_period' must be of length two indicating the ", + "first and end years of the reference period. It will not ", + "be used.") + ref_period <- NULL + } else if (!all(sapply(ref_period, is.numeric))) { + warning("Parameter 'ref_period' must be a numeric vector indicating the ", + "'start' and 'end' years of the reference period. It will not ", + "be used.") + ref_period <- NULL + } else if (ref_period[[1]] > ref_period[[2]]) { + warning("In parameter 'ref_period' 'start' cannot be after 'end'. It ", + "will not be used.") + ref_period <- NULL + } else if (!all(unlist(ref_period) %in% year(dates_exp))) { + warning("Parameter 'ref_period' contain years outside the dates. ", + "It will not be used.") + ref_period <- NULL + } else { + years <- year(ClimProjDiags::Subset(dates_exp, along = leadtime_dim, + indices = 1)) + ref_period[[1]] <- which(ref_period[[1]] == years) + ref_period[[2]] <- which(ref_period[[2]] == years) + } + } + ## standardization if (!is.logical(standardization)) { stop("Parameter 'standardization' must be a logical value.") @@ -666,17 +704,13 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'method' must be a character string containing one of ", "the following methods: 'parametric' or 'non-parametric'.") } + ## distribution if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { stop("Parameter 'distribution' must be a character string containing one ", "of the following distributions: 'log-Logistic', 'Gamma' or ", "'PearsonIII'.") } - ## fit - if (!(fit %in% c('max-lik', 'ub-pwm', 'pp-pwm'))) { - stop("Parameter 'fit' must be a character string containing one of ", - "the following fit methods: 'max-lik', 'ub-pwm', 'pp-pwm'.") - } ## ncores if (!is.null(ncores)) { if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | @@ -684,6 +718,12 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'ncores' must be a positive integer.") } } + + ## na.rm + if (!is.logical(na.rm)) { + stop("Parameter 'na.rm' must be logical.") + } + ## params if (!is.null(params)) { if (!is.numeric(params)) { @@ -706,26 +746,14 @@ PeriodSPEI <- function(exp, dates_exp, lat, } } - # Complete dates - dates_monthly <- NULL - k = 0 - for (dates in .return2list(dates_exp, dates_expcor)) { - k = k + 1 - ini_date <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep= '-')) - end_date <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep='-')) - dates_complete_daily <- as.Date(ini_date:end_date) - - dates_complete_daily_to_monthly <- lubridate::day(dates_complete_daily) - dates_complete_monthly <- dates_complete_daily[which(dates_complete_daily_to_monthly == 1)] - dates_monthly[[k]] <- array(0, dim = length(dates_complete_monthly)) - for (dd in 1:length(dates)) { - ii <- which(dates_complete_monthly == as.Date(paste(lubridate::year(dates[dd]), - lubridate::month(dates[dd]), - 01, sep = '-'))) - dates_monthly[[k]][ii] <- 1 - } + ## return_params + if (!is.logical(return_params)) { + stop("Parameter 'return_params' must be logical.") } + # Complete dates + dates_monthly <- .return2list(dates_exp, dates_expcor) + # Compute PeriodSPEI k = 0 spei_res <- NULL @@ -735,238 +763,60 @@ PeriodSPEI <- function(exp, dates_exp, lat, k = k + 1 # Evapotranspiration estimation (unless pet is already provided) if (is.null(pet[[k]]) | computed_pet) { - pet[[k]] <- .Evapotranspiration(data = data, - dates_monthly = dates_monthly[[k]], - lat = lat, pet_method = pet_method[k], - time_dim = time_dim, - leadtime_dim = leadtime_dim, - lat_dim = lat_dim, na.rm = na.rm, - ncores = ncores) + pet[[k]] <- PeriodPET(data = data, dates = dates_monthly[[k]], + lat = lat, pet_method = pet_method[k], + time_dim = time_dim, leadtime_dim = leadtime_dim, + lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) computed_pet <- TRUE } # Accumulation diff_p_pet <- data$prlr - pet[[k]] - data_accum <- .Accumulation(data = diff_p_pet, - dates_monthly = dates_monthly[[k]], accum = accum, - time_dim = time_dim, leadtime_dim = leadtime_dim, - ncores = ncores) + + accumulated <- Apply(data = list(diff_p_pet), + target_dims = list(data = c(leadtime_dim, time_dim)), + output_dims = c(leadtime_dim, time_dim), + fun = function(data, accum) { + return(rollapply(data = data, width = accum, FUN = sum)) + }, accum = accum, ncores = ncores)$output1 + # Standardization if (standardization) { - spei <- .Standardization(data = data_accum, params = params, + spei <- .Standardization(data = accumulated, params = params, accum = accum, time_dim = time_dim, leadtime_dim = leadtime_dim, - memb_dim = memb_dim, - ref_period = ref_period, + memb_dim = memb_dim, ref_period = ref_period, cross_validation = cross_validation, handle_infinity = handle_infinity, param_error = param_error, method = method, distribution = distribution, - fit = fit, na.rm = na.rm, ncores = ncores) + na.rm = na.rm, ncores = ncores) + ref_period <- NULL params <- spei$params - pos <- match(names(dim(data[[1]])), names(dim(spei[[1]]))) - spei[[1]] <- aperm(spei[[1]], pos) - - spei_res[[k]] <- spei[[1]] + spei_res <- spei[[1]] } else { - pos <- match(names(dim(data[[1]])), names(dim(data_accum))) - data_accum <- aperm(data_accum, pos) - - spei_res[[k]] <- data_accum + spei_res <- accumulated } + spei_res <- Apply(data = list(spei_res), target_dims = leadtime_dim, + fun = function(x, accum, leadtime_dim) { + res <- c(rep(NA, accum-1), x) + dim(res) <- length(res) + names(dim(res)) <- leadtime_dim + return(res) + }, accum = accum, leadtime_dim = leadtime_dim)$output1 + pos <- match(names(dim(data[[1]])), names(dim(spei_res))) + spei_res <- aperm(spei_res, pos) } if (standardization) { - spei_res[[k+1]] <- params - if (is.null(exp_cor)) { - names(spei_res) <- c('exp', 'params') + if (return_params) { + return(list(spei = spei_res, params = params)) } else { - names(spei_res) <- c('exp', 'exp_cor', 'params') + return(spei_res) } } else { - if (is.null(exp_cor)) { - names(spei_res) <- c('exp') - } else { - names(spei_res) <- c('exp', 'exp_cor') - } - } - return(spei_res) -} - -.Evapotranspiration <- function(data, dates_monthly, lat, pet_method = 'hargreaves', - time_dim = 'syear', leadtime_dim = 'time', - lat_dim = 'latitude', na.rm = FALSE, - ncores = NULL) { - - lat_mask <- array(lat, dim = c(1, length(lat))) - names(dim(lat_mask)) <- c('dat', lat_dim) - - # extract mask of NA locations to return to NA the final result - mask_na <- array(1, dim = dim(data[[1]])) - if (pet_method == 'hargreaves') { - varnames <- c('tasmax', 'tasmin') - mask_na[which(is.na(data$tasmax))] <- 0 - mask_na[which(is.na(data$tasmin))] <- 0 - } else if (pet_method == 'hargreaves_modified') { - varnames <- c('tasmax', 'tasmin', 'prlr') - mask_na[which(is.na(data$tasmax))] <- 0 - mask_na[which(is.na(data$tasmin))] <- 0 - mask_na[which(is.na(data$prlr))] <- 0 - } else if (pet_method == 'thornthwaite') { - varnames <- c('tas') - mask_na[which(is.na(data$tas))] <- 0 - } - - # replace NA with 0 - for (dd in 1:length(data)) { - data[[dd]][which(is.na(data[[dd]]))] <- 0 - } - - # prepare data - target_dims_data <- lapply(data[varnames], function(x) rep(c(leadtime_dim, time_dim), 1)) - pet <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), - target_dims = c(list(lat_mask = 'dat'), target_dims_data), - fun = .evapotranspiration, - dates_monthly = dates_monthly, pet_method = pet_method, - leadtime_dim = leadtime_dim, time_dim = time_dim, - output_dims = c(leadtime_dim, time_dim), - ncores = ncores)$output1 - # reorder dims in pet_estimated - pos <- match(names(dim(data[[1]])), names(dim(pet))) - pet <- aperm(pet, pos) - - # restore original NAs from mask_na - pet[which(mask_na == 0 )] <- NA - - return(pet) -} - -.evapotranspiration <- function(lat_mask, data2, data3 = NULL, data4 = NULL, - dates_monthly, pet_method = 'hargreaves', - leadtime_dim = 'time', time_dim = 'syear') { - - dims <- dim(data2) - - # create a vector from data but adding 0 to achive complete time series - # of the considered period - # (starting in January of the first year) so that the solar radiation - # estimation is computed in each case for the correct month - - if (!is.null(data2)) { - data_tmp <- as.vector(data2) - data2 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { - data2[dd] <- data_tmp[count] - count <- count + 1 - } - } - rm(data_tmp) + return(spei_res) } - if (!is.null(data3)) { - data_tmp <- as.vector(data3) - data3 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { - data3[dd] <- data_tmp[count] - count <- count + 1 - } - } - rm(data_tmp) - } - if (!is.null(data4)) { - data_tmp <- as.vector(data4) - data4 <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { - data4[dd] <- data_tmp[count] - count <- count + 1 - } - } - rm(data_tmp) - } - if (pet_method == 'hargreaves') { - pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, na.rm = na.rm, verbose = FALSE) - # line to return the vector to the size of the actual original data - pet <- pet[which(dates_monthly == 1)] - pet <- array(pet, dim = dims) - } - - if (pet_method == 'hargreaves_modified') { - pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, Pre = as.vector(data4), na.rm = na.rm, - verbose = FALSE) - pet <- pet[which(dates_monthly == 1)] - pet <- array(pet, dim = dims) - } - - if (pet_method == 'thornthwaite') { - pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = na.rm, - verbose = FALSE) - # line to return the vector to the size of the actual original data - pet <- pet[which(dates_monthly == 1)] - pet <- array(pet, dim = dims) - } - return(pet) -} - - -.Accumulation <- function(data, dates_monthly, accum = 1, - time_dim = 'syear', leadtime_dim = 'time', - ncores = NULL) { - - accumulated <- Apply(data = list(data), - target_dims = list(data = c(leadtime_dim, time_dim)), - dates_monthly = dates_monthly, - accum = accum, - output_dims = c(leadtime_dim, time_dim), - leadtime_dim = leadtime_dim, time_dim = time_dim, - fun = .accumulation, - ncores = ncores)$output1 - - pos <- match(names(dim(accumulated)), names(dim(data))) - accumulated <- aperm(accumulated, pos) - - return(accumulated) - -} - -.accumulation <- function(data, dates_monthly, accum = 1, - time_dim = 'syear', leadtime_dim = 'time') { - - # data:[time, syear] - dims <- dim(data) - - data_vector <- array(0, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { - data_vector[dd] <- as.vector(data)[count] - count <- count + 1 - } - } - # Accumulation at different timescales - # rollapply {zoo} A generic function for applying a function to rolling - # margins of an array. - data_sum_x <- rollapply(data_vector, accum, sum) - # adds as many NAs as needed at the begining to account for the months that - # cannot be added (depends on accu) and so that the position in the vector - # corresponds to the accumulated of the previous months (instead of the - # accumulated of the next months) - data_sum_x <- c(rep(NA, accum-1), data_sum_x) - # discard the months that don't appear in the original data - data_sum_x <- data_sum_x[which(dates_monthly == 1)] - accum_result <- array(data_sum_x, dim = c(dims)) - # replace by NA when the accumulation corresponds to months that where not - # present in the original data - if (accum > 1) { - accum_result[1:(accum-1), ] <- NA - } - return(accum_result) } .Standardization <- function(data, params = NULL, accum = 1, time_dim = 'syear', @@ -974,19 +824,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, ref_period = NULL, cross_validation = FALSE, handle_infinity = FALSE, param_error = -9999, method = 'parametric', distribution = 'log-Logistic', - fit = 'ub-pwm', na.rm = FALSE, ncores = NULL) { - - # Remove NA data due to accumulation - if (accum > 1) { - data <- ClimProjDiags::Subset(x = data, along = leadtime_dim, - indices = accum:dim(data)[leadtime_dim], - drop = FALSE) - if (!is.null(params)) { - params <- ClimProjDiags::Subset(x = params, along = leadtime_dim, - indices = accum:dim(params)[leadtime_dim], - drop = FALSE) - } - } + na.rm = FALSE, ncores = NULL) { nleadtime <- dim(data)[leadtime_dim] ntime <- dim(data)[time_dim] @@ -1021,23 +859,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, ref_period = ref_period, handle_infinity = handle_infinity, cross_validation = cross_validation, param_error = param_error, method = method, distribution = distribution, - fit = fit, na.rm = na.rm, + na.rm = na.rm, output_dims = list(spei = c(leadtime_dim, time_dim, memb_dim), params = c(time_dim, leadtime_dim, 'coef')), ncores = ncores) - - # Add again NA values due to accumulation - if (accum > 1) { - for (s in 1:length(spei)) { - spei[[s]] <- Apply(data = list(spei[[s]]), target_dims = leadtime_dim, - fun = function(x, accum = 1, leadtime_dim = 'time') { - res <- c(rep(NA, accum-1), x) - dim(res) <- length(res) - names(dim(res)) <- leadtime_dim - return(res) - }, accum = accum, leadtime_dim = leadtime_dim)$output1 - } - } return(spei) } @@ -1046,7 +871,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, ref_period = NULL, handle_infinity = FALSE, cross_validation = FALSE, param_error = -9999, method = 'parametric', distribution = 'log-Logistic', - fit = 'ub-pwm', na.rm = FALSE) { + na.rm = FALSE) { # data: [leadtime_dim, time_dim, memb_dim] # params: [time_dim, leadtime_dim, 'coef'] @@ -1068,7 +893,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, spei_mod <- array(NA, dim(data)) # if the data [time, sdate, memb] has no variability it will raise an error # further down, so we assign a value to the result and skip the step - } else if (any(is.na(data)) && !na.rm) { + } else if (anyNA(data) && !na.rm) { spei_mod <- array(NA, dim(data)) } else if (var(data, na.rm = T) == 0) { spei_mod <- array(param_error, dim(data)) @@ -1090,15 +915,13 @@ PeriodSPEI <- function(exp, dates_exp, lat, params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} - - spei_data <- .std(data = data_subset, coef = coef, - ntime = ntime, nmemb = nmemb, - method = method, distribution = distribution, - fit = fit, na.rm = na.rm, + spei_data <- .std(data = data_subset, coef = coef, ntime = ntime, + nmemb = nmemb, method = method, + distribution = distribution, na.rm = na.rm, ref.start = ref.start, ref.end = ref.end, - params = params_tmp, - handle_infinity = handle_infinity, + params = params_tmp, handle_infinity = handle_infinity, cross_validation = cross_validation) + spei_mod[ff, , ] <- spei_data[[1]] params_ff <- spei_data[[2]] # lengthen dimension coef of params_ff in case it doesn't match the @@ -1115,12 +938,15 @@ PeriodSPEI <- function(exp, dates_exp, lat, } .std <- function(data, coef, ntime, nmemb, method = 'parametric', - distribution = 'log-Logistic', fit = 'ub-pwm', na.rm = FALSE, + distribution = 'log-Logistic', na.rm = FALSE, ref.start = NULL, ref.end = NULL, params = NULL, handle_infinity = FALSE, cross_validation = FALSE) { # data: [time_dim, memb_dim] # params: NULL or [(ntime), coef] + + fit = 'ub-pwm' # hard-coded + if (method == 'non-parametric') { bp <- matrix(0, length(data), 1) for (i in 1:length(data)) { diff --git a/tests/testthat/test-PeriodPET.R b/tests/testthat/test-PeriodPET.R new file mode 100644 index 0000000..0b7cf57 --- /dev/null +++ b/tests/testthat/test-PeriodPET.R @@ -0,0 +1,178 @@ +############################################## + +# dat1 +dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) + +set.seed(1) +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +set.seed(2) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +set.seed(3) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) + +dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) + +lat <- c(40,40.1) + +exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) + +# dat2 +dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) + +set.seed(1) +exp_tas <- array(rnorm(100, 17.34, 9.18), dim = dims2) +set.seed(2) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims2) + +dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates_exp2) <- c(sday = 1, sweek = 1, styear = 6, ftime = 3) + +lat <- c(40,40.1) + +exp2 <- list('tas' = exp_tas, 'prlr' = exp_prlr) + +############################################## + +# test_that("1. Initial checks CST_PeriodSPEI", { +# # Check 's2dv_cube' +# expect_error( +# CST_PeriodSPEI(exp = NULL), +# "Parameter 'exp' cannot be NULL." +# ) +# expect_error( +# CST_PeriodSPEI(exp = array(10)), +# "Parameter 'exp' must be a list of 's2dv_cube' class." +# ) +# # latitude +# expect_error( +# CST_PeriodSPEI(exp = list(cube1)), +# paste0("Spatial coordinate names of parameter 'exp' do not match any ", +# "of the names accepted by the package.") +# ) +# # Dates +# expect_error( +# CST_PeriodSPEI(exp = list(cube2)), +# paste0("Element 'Dates' is not found in 'attrs' list of 'exp'. ", +# "See 's2dv_cube' object description in README file for more ", +# "information.") +# ) +# expect_error( +# CST_PeriodSPEI(exp = list(cube3), exp_cor = list(cube2)), +# paste0("Element 'Dates' is not found in 'attrs' list of 'exp_cor'. ", +# "See 's2dv_cube' object description in README file for more ", +# "information.") +# ) +# }) + +############################################## + +test_that("1. Initial checks PeriodSPEI", { + # data + expect_error( + PeriodPET(data = NULL), + "Parameter 'data' needs to be a named list with the needed variables." + ) + expect_error( + PeriodPET(data = list(1)), + "Parameter 'data' needs to be a named list with the variable names." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10))), + "Parameter 'data' needs to be a list of arrays with dimension names." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 11)))), + "Parameter 'data' variables need to have the same dimensions." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(ftime = 10)))), + "Parameter 'data' variables need to have the same dimensions." + ) + # lat + expect_error( + PeriodPET(data = exp1, lat = 'lat'), + "Parameter 'lat' must be numeric." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 10))), lat = 1:2), + "Parameter 'data' must have 'lat_dim' dimension." + ) + # data (2) + expect_warning( + PeriodPET(data = exp1, pet_method = '1', dates = dates_exp, lat = lat), + paste0("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves_modified'.") + ) + # time_dim + expect_error( + PeriodPET(data = exp1, time_dim = 1, dates = dates_exp, lat = lat), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodPET(data = exp2, lat = lat, dates = dates_exp2, + lat_dim = 'lat', pet_method = 'thornthwaite'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # leadtime_dim + expect_error( + PeriodPET(data = exp1, leadtime_dim = 1, dates = dates_exp, lat = lat), + "Parameter 'leadtime_dim' must be a character string." + ) + expect_error( + PeriodPET(data = exp2, lat = lat, dates = dates_exp2, + lat_dim = 'lat', time_dim = 'ftime', pet_method = 'thornthwaite'), + "Parameter 'leadtime_dim' is not found in 'data' dimension." + ) + # lat_dim + expect_error( + PeriodPET(data = exp1, lat_dim = 1, dates = dates_exp, lat = lat) + ) + expect_error( + PeriodPET(data = exp2, lat = lat, dates = dates_exp2), + "Parameter 'data' must have 'lat_dim' dimension." + ) + # na.rm + expect_error( + PeriodPET(data = exp1, na.rm = 1.5, dates = dates_exp, lat = lat), + "Parameter 'na.rm' must be one logical value." + ) + # ncores + expect_error( + PeriodPET(data = exp1, ncores = 1.5, dates = dates_exp, lat = lat), + "Parameter 'ncores' must be a positive integer." + ) +}) + +############################################## + +test_that("2. Output checks", { + res1 <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) + res2 <- PeriodPET(data = exp2, lat = lat, dates = dates_exp2, + pet_method = c('thornthwaite'), + lat_dim = 'lat', time_dim = 'styear', + leadtime_dim = 'ftime') + # dims + expect_equal( + dim(res1), + c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) + ) + # values + expect_equal( + res1[1:4], + c(137.77342, 154.55548, 65.72859, 222.20438), + tolerance = 0.0001 + ) + expect_equal( + res2[1:4], + c(77.76124, 118.94212, 66.57568, 185.67074), + tolerance = 0.0001 + ) +}) + +############################################## \ No newline at end of file diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 4e42859..f978111 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -35,13 +35,13 @@ expcor_tasmin <- array(rnorm(60, 15.70, 4.40), dim = dimscor) set.seed(3) expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) -dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) -dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16")), "UTC") +dim(dates_exp) <- c(syear = 6, time = 3) -dates_expcor <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), - paste0(2020, "-10-16"))) -dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) +dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), + paste0(2020, "-10-16")), "UTC") +dim(dates_expcor) <- c(syear = 1, time = 3) lat <- c(40,40.1) @@ -65,7 +65,7 @@ set.seed(2) expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor2) dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) + paste0(2010:2015, "-10-16"))) dim(dates_exp2) <- c(sday = 1, sweek = 1, styear = 6, ftime = 3) dates_expcor2 <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), @@ -77,6 +77,20 @@ lat <- c(40,40.1) exp2 <- list('tas' = exp_tas, 'prlr' = exp_prlr) exp_cor2 <- list('tas' = expcor_tas, 'prlr' = expcor_prlr) +# cube4 +cube4_exp <- lapply(exp1, function(x) { + suppressWarnings( + CSTools::s2dv_cube(data = x, coords = list(latitude = c(40, 40.1)), + varName = 'test', Dates = dates_exp) + ) +}) +cube4_expcor <- lapply(exp_cor1, function(x) { + suppressWarnings( + CSTools::s2dv_cube(data = x, coords = list(latitude = c(40, 40.1)), + varName = 'test', Dates = dates_expcor) + ) +}) + ############################################## test_that("1. Initial checks CST_PeriodSPEI", { @@ -156,19 +170,19 @@ test_that("1. Initial checks PeriodSPEI", { "Parameter 'exp_cor' variables need to have the same dimensions." ) expect_error( - PeriodSPEI(exp = exp1, lat = 'lat'), + PeriodSPEI(exp = exp1, lat = 'lat', dates_exp = dates_exp), "Parameter 'lat' must be numeric." ) expect_error( - PeriodSPEI(exp = list(tasmax = array(10, c(time = 10)), - tasmin = array(10, c(time = 10))), lat = 1:2), - "Parameter 'exp' must have 'lat_dim' dimension." + PeriodSPEI(exp = list(prlr = array(10, c(time = 10, syear = 1, ensemble = 1))), + lat = 1:2, dates_exp = dates_exp), + "Parameter 'lat_dim' is not found in 'exp' dimension." ) # exp (2) expect_warning( PeriodSPEI(exp = exp1, pet_method = '1', dates_exp = dates_exp, lat = lat), paste0("Parameter 'pet_method' needs to be 'hargreaves' or ", - "'hargreaves_modified'. It is set to 'hargreaves'.") + "'hargreaves_modified'. It is set to 'hargreaves_modified'.") ) # time_dim expect_error( @@ -211,13 +225,40 @@ test_that("1. Initial checks PeriodSPEI", { expect_error( PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, dates_exp = dates_exp2, dates_expcor = dates_expcor2), - "Parameter 'exp' must have 'lat_dim' dimension." + "Parameter 'time_dim' is not found in 'exp' dimension." ) # accum expect_error( PeriodSPEI(exp = exp1, accum = 10, dates_exp = dates_exp, lat = lat), "Cannot compute accumulation of 10 months because loaded data has only 3 months." ) + # ref_period + expect_warning( + PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, + dates_expcor = dates_expcor, lat = lat, ref_period = 1), + paste0("Parameter 'ref_period' must be of length two indicating the ", + "first and end years of the reference period. It will not ", + "be used.") + ) + expect_warning( + PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, + dates_expcor = dates_expcor, lat = lat, ref_period = list('a', 1)), + paste0("Parameter 'ref_period' must be a numeric vector indicating the ", + "'start' and 'end' years of the reference period. It will not ", + "be used.") + ) + expect_warning( + PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, + dates_expcor = dates_expcor, lat = lat, ref_period = list(2012, 2011)), + paste0("In parameter 'ref_period' 'start' cannot be after 'end'. It ", + "will not be used.") + ) + expect_warning( + PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, + dates_expcor = dates_expcor, lat = lat, ref_period = list(2008, 2021)), + paste0("Parameter 'ref_period' contain years outside the dates. ", + "It will not be used.") + ) # standardization expect_error( PeriodSPEI(exp = exp1, standardization = 10, dates_exp = dates_exp, lat = lat), @@ -251,12 +292,6 @@ test_that("1. Initial checks PeriodSPEI", { "of the following distributions: 'log-Logistic', 'Gamma' or ", "'PearsonIII'.") ) - # fit - expect_error( - PeriodSPEI(exp = exp1, fit = 1, dates_exp = dates_exp, lat = lat), - paste0("Parameter 'fit' must be a character string containing one of ", - "the following fit methods: 'max-lik', 'ub-pwm', 'pp-pwm'.") - ) # ncores expect_error( PeriodSPEI(exp = exp1, ncores = 1.5, dates_exp = dates_exp, lat = lat), @@ -266,37 +301,67 @@ test_that("1. Initial checks PeriodSPEI", { ############################################## +test_that("2. Output checks: CST_PeriodSPEI", { + res1 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = NULL) + res2 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = cube4_expcor) + res3 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = cube4_expcor, standardization = F) + res4 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = NULL, return_params = T) + expect_equal( + names(res1), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + res2$attrs$Variable$varName, + "SPEI" + ) + expect_equal( + res3$attrs$Variable$varName, + "Precipitation minus accumulated PET" + ) + expect_equal( + names(res3), + c("data", "dims", "coords", "attrs") + ) + expect_equal( + names(res4), + c("spei", "params") + ) +}) + +############################################## + test_that("2. Output checks", { res1 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor) + dates_exp = dates_exp, dates_expcor = dates_expcor, + return_params = TRUE) res2 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, - standardization = FALSE) + standardization = FALSE) # No info about accumulation res3 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp) + dates_exp = dates_exp, return_params = TRUE) # output dims expect_equal( names(res1), - c('exp', 'exp_cor', 'params') + c('spei', 'params') ) expect_equal( - names(res2), - c('exp', 'exp_cor') + dim(res2), + c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) ) expect_equal( names(res3), - c('exp', 'params') + c('spei', 'params') ) expect_equal( dim(res1[[1]]), - dims + dimscor ) expect_equal( - dim(res1[[3]])[which(!names(dim(res1[[3]])) %in% c('coef', 'syear'))], + dim(res1[[2]])[which(!names(dim(res1[[2]])) %in% c('coef', 'syear'))], dims[which(!names(dims) %in% c('syear', 'ensemble'))] ) expect_equal( - dim(res2[[2]]), + dim(res2), dimscor ) expect_equal( @@ -310,14 +375,21 @@ test_that("2. Output checks", { res11 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, accum = 2, dates_exp = dates_exp, na.rm = TRUE) expect_equal( - res11$exp[1,2,1,1,][1:4], - c(-0.5553128, 0.4689562, -0.4682003, -0.9956847), + res11[1,3,1,1,][1:4], + c(-0.4292409, -0.1375149, -0.5564081, -0.4273380), tolerance = 0.0001 ) # ref_period + res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, + dates_exp = dates_exp, dates_expcor = dates_expcor, + na.rm = TRUE, ref_period = list(2011, 2013)) + expect_equal( + !identical(res1[[1]], res_ref), + TRUE + ) # params res5 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - params = params1) + params = params1, return_params = TRUE) expect_error( PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, params = array(abs(rnorm(100)), dim = dimscor)), @@ -333,10 +405,10 @@ test_that("2. Output checks", { dates_exp = dates_exp, standardization = FALSE) expect_equal( names(res4), - c('exp') + NULL ) expect_equal( - dim(res4$exp), + dim(res4), c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) ) # cross_validation @@ -348,12 +420,12 @@ test_that("2. Output checks", { "since 'exp_cor' is provided.") ) res_crossval_T <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - cross_validation = TRUE) + cross_validation = TRUE, return_params = TRUE) res_crossval_F <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - cross_validation = FALSE) + cross_validation = FALSE, return_params = TRUE) # cross_validation = TRUE expect_equal( - dim(res_crossval_T$exp), + dim(res_crossval_T$spei), dims ) expect_equal( @@ -373,6 +445,14 @@ test_that("2. Output checks", { res6 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, pet_method = c('hargreaves_modified', 'hargreaves')) + expect_equal( + identical(res5, res6), + FALSE + ) + expect_equal( + dim(res5), + dim(res6) + ) # time_dim, leadtime_dim, memb_dim, lat_dim res7 <- PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, @@ -389,15 +469,6 @@ test_that("2. Output checks", { dates_exp = dates_exp, distribution = 'PearsonIII') # NA res10 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, dates_exp = dates_exp, distribution = 'Gamma') # NA - # fit - - res12 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, fit = 'ub-pwm') # ok - res13 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, fit = 'max-lik') # ok - res14 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, fit = 'pp-pwm') # NA - all.equal(res12, res13) - all.equal(res12, res14) # res14 doesn't work for this data # param_error - # handle_infinity - OK res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, -- GitLab From 70ec75370d642254964bcd0f23be585ad0f61885 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 28 Jul 2023 14:45:54 +0200 Subject: [PATCH 41/87] Hide function PeriodFun from CSIndicators package; the function PeriodFun will remain hidden --- DESCRIPTION | 2 +- NAMESPACE | 2 -- R/PeriodFun.R | 24 +++++++------- man/CST_PeriodFun.Rd | 75 -------------------------------------------- man/PeriodFun.Rd | 70 ----------------------------------------- 5 files changed, 13 insertions(+), 160 deletions(-) delete mode 100644 man/CST_PeriodFun.Rd delete mode 100644 man/PeriodFun.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 4151ba4..4e20983 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,4 +40,4 @@ URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 RoxygenNote: 7.2.0 -Config/testthat/edition: 3 \ No newline at end of file +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index f02cee5..d92da37 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,6 @@ export(CST_AbsToProbs) export(CST_AccumulationExceedingThreshold) export(CST_MergeRefToExp) export(CST_PeriodAccumulation) -export(CST_PeriodFun) export(CST_PeriodMax) export(CST_PeriodMean) export(CST_PeriodMin) @@ -20,7 +19,6 @@ export(CST_WindCapacityFactor) export(CST_WindPowerDensity) export(MergeRefToExp) export(PeriodAccumulation) -export(PeriodFun) export(PeriodMax) export(PeriodMean) export(PeriodMin) diff --git a/R/PeriodFun.R b/R/PeriodFun.R index 9c33ba2..77484a1 100644 --- a/R/PeriodFun.R +++ b/R/PeriodFun.R @@ -46,15 +46,15 @@ #'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' #' -#'SA <- CST_PeriodFun(exp, fun = mean, start = list(01, 12), -#' end = list(01, 01)) +#'SA <- CSIndicators:::.CST_PeriodFun(exp, fun = mean, start = list(01, 12), +#' end = list(01, 01)) #' #'@import multiApply #'@importFrom ClimProjDiags Subset -#'@export -CST_PeriodFun <- function(data, fun, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, - ncores = NULL) { +#'@noRd +.CST_PeriodFun <- function(data, fun, start = NULL, end = NULL, + time_dim = 'ftime', na.rm = FALSE, + ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") @@ -70,9 +70,9 @@ CST_PeriodFun <- function(data, fun, start = NULL, end = NULL, } Dates <- data$attrs$Dates - total <- PeriodFun(data = data$data, fun = fun, dates = Dates, start = start, - end = end, time_dim = time_dim, na.rm = na.rm, - ncores = ncores) + total <- CSIndicators:::.PeriodFun(data = data$data, fun = fun, dates = Dates, start = start, + end = end, time_dim = time_dim, na.rm = na.rm, + ncores = ncores) data$data <- total data$dims <- dim(total) @@ -144,12 +144,12 @@ CST_PeriodFun <- function(data, fun, start = NULL, end = NULL, #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) #'dim(Dates) <- c(sdate = 4, ftime = 3) -#'SA <- PeriodFun(data, fun = mean, dates = Dates, start = list(01, 12), +#'SA <- CSIndicators:::.PeriodFun(data, fun = mean, dates = Dates, start = list(01, 12), #' end = list(01, 01)) #' #'@import multiApply -#'@export -PeriodFun <- function(data, fun, dates = NULL, start = NULL, end = NULL, +#'@noRd +.PeriodFun <- function(data, fun, dates = NULL, start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { if (is.null(data)) { diff --git a/man/CST_PeriodFun.Rd b/man/CST_PeriodFun.Rd deleted file mode 100644 index 1ffe32b..0000000 --- a/man/CST_PeriodFun.Rd +++ /dev/null @@ -1,75 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PeriodFun.R -\name{CST_PeriodFun} -\alias{CST_PeriodFun} -\title{Period Function on 's2dv_cube' objects} -\usage{ -CST_PeriodFun( - data, - fun, - start = NULL, - end = NULL, - time_dim = "ftime", - na.rm = FALSE, - ncores = NULL -) -} -\arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} - -\item{fun}{An atomic function to compute a calculation over a period.} - -\item{start}{An optional parameter to defined the initial date of the period -to select from the data by providing a list of two elements: the initial -date of the period and the initial month of the period. By default it is set -to NULL and the indicator is computed using all the data provided in -\code{data}.} - -\item{end}{An optional parameter to defined the final date of the period to -select from the data by providing a list of two elements: the final day of -the period and the final month of the period. By default it is set to NULL -and the indicator is computed using all the data provided in \code{data}.} - -\item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} - -\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or -not (FALSE).} - -\item{ncores}{An integer indicating the number of cores to use in parallel -computation.} -} -\value{ -An 's2dv_cube' object containing the indicator in the element -\code{data} with dimensions of the input parameter 'data' except the -dimension where the mean has been computed (specified with 'time_dim'). A new -element called 'time_bounds' will be added into the 'attrs' element in the -'s2dv_cube' object. It consists of a list containing two elements, the start -and end dates of the aggregated period with the same dimensions of 'Dates' -element. -} -\description{ -Period Fun computes a calculation of a given variable in a period. -} -\examples{ -exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) -Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) -exp$attrs$Dates <- Dates -class(exp) <- 's2dv_cube' - -SA <- CST_PeriodFun(exp, fun = mean, start = list(01, 12), - end = list(01, 01)) - -} diff --git a/man/PeriodFun.Rd b/man/PeriodFun.Rd deleted file mode 100644 index 9378273..0000000 --- a/man/PeriodFun.Rd +++ /dev/null @@ -1,70 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PeriodFun.R -\name{PeriodFun} -\alias{PeriodFun} -\title{Period Function on multidimensional array objects} -\usage{ -PeriodFun( - data, - fun, - dates = NULL, - start = NULL, - end = NULL, - time_dim = "ftime", - na.rm = FALSE, - ncores = NULL -) -} -\arguments{ -\item{data}{A multidimensional array with named dimensions.} - -\item{fun}{An atomic function to compute a calculation over a period.} - -\item{dates}{A multidimensional array of dates with named dimensions matching -the temporal dimensions on parameter 'data'. By default it is NULL, to -select aperiod this parameter must be provided.} - -\item{start}{An optional parameter to defined the initial date of the period -to select from the data by providing a list of two elements: the initial -date of the period and the initial month of the period. By default it is set -to NULL and the indicator is computed using all the data provided in -\code{data}.} - -\item{end}{An optional parameter to defined the final date of the period to -select from the data by providing a list of two elements: the final day of -the period and the final month of the period. By default it is set to NULL -and the indicator is computed using all the data provided in \code{data}.} - -\item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} - -\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or -not (FALSE).} - -\item{ncores}{An integer indicating the number of cores to use in parallel -computation.} -} -\value{ -A multidimensional array with named dimensions containing the -indicator in the element \code{data}. -} -\description{ -Period Fun computes a calculation of a given variable in a period. -} -\examples{ -data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) -Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), - seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), - as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) -SA <- PeriodFun(data, fun = mean, dates = Dates, start = list(01, 12), - end = list(01, 01)) - -} -- GitLab From 98e1c9b4cfd36ea4a7d84ae7e004f86f1ca24f8b Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 31 Jul 2023 12:56:52 +0200 Subject: [PATCH 42/87] Add rolling sum in PeriodAccumulation throughout a new parameter rollingwidth --- NAMESPACE | 1 + R/PeriodAccumulation.R | 168 ++++++++++++++++------- man/CST_PeriodAccumulation.Rd | 36 +++-- man/CST_PeriodSPEI.Rd | 84 ++++++++---- man/PeriodAccumulation.Rd | 15 ++ man/PeriodPET.Rd | 82 +++++++++++ man/PeriodSPEI.Rd | 88 ++++++++---- tests/testthat/test-PeriodAccumulation.R | 60 +++++--- 8 files changed, 400 insertions(+), 134 deletions(-) create mode 100644 man/PeriodPET.Rd diff --git a/NAMESPACE b/NAMESPACE index 7cfbe75..c67f13e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,7 @@ export(CST_WindPowerDensity) export(MergeRefToExp) export(PeriodAccumulation) export(PeriodMean) +export(PeriodPET) export(PeriodSPEI) export(QThreshold) export(SelectPeriodOnData) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 3b0d33d..b649a1d 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -10,12 +10,19 @@ #' August 21st to October 21st} #'} #' +#'There are two possible ways of performing the accumulation. The default one +#'is by accumulating a variable over a dimension specified with 'time_dim'. To +#'chose a specific time period, start and end must be used. The other method +#'is by using rollingwidth parameter. When this parameter is a positive integer, +#'the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum +#'is applied towards 'time_dim'. +#' #'@param data An 's2dv_cube' object as provided function \code{CST_Load} in #' package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial -#' date of the period and the initial month of the period. By default it is set -#' to NULL and the indicator is computed using all the data provided in +#' date of the period and the initial m onth of the period. By default it is +#' set to NULL and the indicator is computed using all the data provided in #' \code{data}. #'@param end An optional parameter to defined the final date of the period to #' select from the data by providing a list of two elements: the final day of @@ -25,19 +32,27 @@ #' compute the indicator. By default, it is set to 'ftime'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. +#'@param rollingwidth An optional parameter to indicate the number of time +#' steps the rolling sum is applied to. If it is negative, the rolling sum is +#' applied backwards 'time_dim', if it is positive, it will be towards it. When +#' this parameter is NULL, the sum is applied over all 'time_dim', in a +#' specified period. It is NULL by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' #'@return An 's2dv_cube' object containing the indicator in the element -#'\code{data} with dimensions of the input parameter 'data' except the dimension -#'where the accumulation has been computed (specified with 'time_dim'). The -#''Dates' array is updated to the dates corresponding to the beginning of the -#'aggregated time period. A new element called 'time_bounds' will be added into -#'the 'attrs' element in the 's2dv_cube' object. It consists of a list -#'containing two elements, the start and end dates of the aggregated period with -#'the same dimensions of 'Dates' element. +#'\code{data}. If 'rollingwithd' is not used, it will have the dimensions of +#'the input parameter 'data' except the dimension where the accumulation has +#'been computed (specified with 'time_dim'). The 'Dates' array is updated to the +#'dates corresponding to the beginning of the aggregated time period. A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. If 'rollingwithd' is used, it will contain the same dimensions of +#'parameter 'data' and the other elements of the 's2dv_cube' will not be +#'modified. #' #'@examples #'exp <- NULL @@ -66,8 +81,8 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, - ncores = NULL) { + time_dim = 'ftime', rollingwidth = NULL, + na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") @@ -83,31 +98,38 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, } Dates <- data$attrs$Dates - total <- PeriodAccumulation(data$data, dates = Dates, start, end, - time_dim = time_dim, na.rm = na.rm, ncores = ncores) - data$data <- total - data$dims <- dim(total) + if (!is.null(rollingwidth)) { + data$data <- PeriodAccumulation(data$data, time_dim = time_dim, + rollingwidth = rollingwidth, na.rm = na.rm, + ncores = ncores) + } else { + total <- PeriodAccumulation(data$data, dates = Dates, start, end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + data$data <- total + data$dims <- dim(total) - if (!is.null(Dates)) { - if (!is.null(start) && !is.null(end)) { - Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, - time_dim = time_dim, ncores = ncores) - } - if (is.null(dim(Dates))) { - warning("Element 'Dates' has NULL dimensions. They will not be ", - "subset and 'time_bounds' will be missed.") - data$attrs$Dates <- Dates - } else { - # Create time_bounds - time_bounds <- NULL - time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') - time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') - # Add Dates in attrs - data$attrs$Dates <- time_bounds$start - data$attrs$time_bounds <- time_bounds + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } } + return(data) } @@ -122,6 +144,13 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' \item\code{HarR}{Harvest Total Precipitation: The total precipitation from #' August 21st to October 21st} #'} +#' +#'There are two possible ways of performing the accumulation. The default one +#'is by accumulating a variable over a dimension specified with 'time_dim'. To +#'chose a specific time period, start and end must be used. The other method +#'is by using rollingwidth parameter. When this parameter is a positive integer, +#'the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum +#'is applied towards 'time_dim'. #' #'@param data A multidimensional array with named dimensions. #'@param dates A multidimensional array of dates with named dimensions matching @@ -140,6 +169,11 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. +#'@param rollingwidth An optional parameter to indicate the number of time +#' steps the rolling sum is applied to. If it is negative, the rolling sum is +#' applied backwards 'time_dim', if it is positive, it will be towards it. When +#' this parameter is NULL, the sum is applied over all 'time_dim', in a +#' specified period. It is NULL by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). #'@param ncores An integer indicating the number of cores to use in parallel @@ -169,8 +203,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, - ncores = NULL) { + time_dim = 'time', rollingwidth = NULL, + na.rm = FALSE, ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } @@ -181,27 +215,59 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, dim(data) <- length(data) names(dim(data)) <- time_dim } + dimnames <- names(dim(data)) - if (!is.null(start) && !is.null(end)) { - if (is.null(dates)) { - warning("Parameter 'dates' is NULL and the average of the ", - "full data provided in 'data' is computed.") - } else { - if (!any(c(is.list(start), is.list(end)))) { - stop("Parameter 'start' and 'end' must be lists indicating the ", - "day and the month of the period start and end.") - } - if (!is.null(dim(dates))) { - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + # period accumulation + if (is.null(rollingwidth)) { + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") } else { - warning("Parameter 'dates' must have named dimensions if 'start' and ", - "'end' are not NULL. All data will be used.") + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data, dates, start, end, + time_dim = time_dim, ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } + total <- Apply(list(data), target_dims = time_dim, fun = sum, + na.rm = na.rm, ncores = ncores)$output1 + } else { + # rolling accumulation + if (!is.numeric(rollingwidth)) { + stop("Parameter 'rollingwidth' must be a numeric value.") + } + if (abs(rollingwidth) > dim(data)[time_dim]) { + stop(paste0("Cannot compute accumulation of ", rollingwidth, " months because ", + "loaded data has only ", dim(data)[time_dim], " months.")) + } + backroll <- FALSE + if (rollingwidth < 0) { + rollingwidth <- abs(rollingwidth) + backroll <- TRUE + } + total <- Apply(data = list(data), target_dims = time_dim, + output_dims = time_dim, + fun = function(x, accum, backroll, na.rm) { + res <- rollapply(data = x, width = accum, FUN = sum, + na.rm = na.rm) + if (backroll) { + return(c(rep(NA, accum-1), res)) + } else { + return(c(res, rep(NA, accum-1))) + } + }, accum = rollingwidth, backroll = backroll, na.rm = na.rm, + ncores = ncores)$output1 + pos <- match(dimnames, names(dim(total))) + total <- aperm(total, pos) } - total <- Apply(list(data), target_dims = time_dim, fun = sum, - na.rm = na.rm, ncores = ncores)$output1 + return(total) } - diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 77f4a38..4326ea2 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -9,6 +9,7 @@ CST_PeriodAccumulation( start = NULL, end = NULL, time_dim = "ftime", + rollingwidth = NULL, na.rm = FALSE, ncores = NULL ) @@ -19,8 +20,8 @@ package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial -date of the period and the initial month of the period. By default it is set -to NULL and the indicator is computed using all the data provided in +date of the period and the initial m onth of the period. By default it is +set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{end}{An optional parameter to defined the final date of the period to @@ -33,6 +34,12 @@ compute the indicator. By default, it is set to 'ftime'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} +\item{rollingwidth}{An optional parameter to indicate the number of time +steps the rolling sum is applied to. If it is negative, the rolling sum is +applied backwards 'time_dim', if it is positive, it will be towards it. When +this parameter is NULL, the sum is applied over all 'time_dim', in a +specified period. It is NULL by default.} + \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -41,13 +48,16 @@ computation.} } \value{ An 's2dv_cube' object containing the indicator in the element -\code{data} with dimensions of the input parameter 'data' except the dimension -where the accumulation has been computed (specified with 'time_dim'). The -'Dates' array is updated to the dates corresponding to the beginning of the -aggregated time period. A new element called 'time_bounds' will be added into -the 'attrs' element in the 's2dv_cube' object. It consists of a list -containing two elements, the start and end dates of the aggregated period with -the same dimensions of 'Dates' element. +\code{data}. If 'rollingwithd' is not used, it will have the dimensions of +the input parameter 'data' except the dimension where the accumulation has +been computed (specified with 'time_dim'). The 'Dates' array is updated to the +dates corresponding to the beginning of the aggregated time period. A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. If 'rollingwithd' is used, it will contain the same dimensions of +parameter 'data' and the other elements of the 's2dv_cube' will not be +modified. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a @@ -60,6 +70,14 @@ by using this function: August 21st to October 21st} } } +\details{ +There are two possible ways of performing the accumulation. The default one +is by accumulating a variable over a dimension specified with 'time_dim'. To +chose a specific time period, start and end must be used. The other method +is by using rollingwidth parameter. When this parameter is a positive integer, +the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum +is applied towards 'time_dim'. +} \examples{ exp <- NULL exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 8e8ab19..eaa139e 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -21,9 +21,9 @@ CST_PeriodSPEI( pet_method = "hargreaves", method = "parametric", distribution = "log-Logistic", - fit = "ub-pwm", param_error = -9999, handle_infinity = FALSE, + return_params = FALSE, na.rm = FALSE, ncores = NULL ) @@ -57,7 +57,9 @@ computed for individual members.} dimension. By default it is set by 'latitude'.} \item{accum}{An integer value indicating the number of months for the -accumulation for each variable.} +accumulation for each variable. When it is greater than 1, the result will +be filled with NA until the accum time_dim dimension number due to the +accumulation to previous months.} \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default @@ -102,12 +104,9 @@ default.} \item{distribution}{A character string indicating the name of the distribution function to be used for computing the SPEI. The accepted names are: -'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by -default.} - -\item{fit}{A character string indicating the name of the method used for -computing the distribution function parameters The accepteed names are: -'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default.} +'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +'Gamma' method only works when only precipitation is provided and other +variables are 0 because it is positive defined (SPI indicator).} \item{param_error}{A numeric value with the error accepted.} @@ -115,37 +114,66 @@ computing the distribution function parameters The accepteed names are: or not (FALSE).} \item{na.rm}{A logical value indicating whether NA values should be removed -from data. It is FALSE by default.} +from data. It is FALSE by default. If it is FALSE and there are NA values, +(if standardization is TRUE) all values of other dimensions except time_dim +and leadtime_dim will be set to NA directly. On the other hand, if it is +TRUE, if the data from other dimensions except time_dim and leadtime_dim is +not reaching 4 values, it is not enough values to estimate the parameters +and the result will include NA.} \item{ncores}{An integer value indicating the number of cores to use in parallel computation.} } \value{ -A list with elements: -\itemize{ - \item{'exp', if 'standarization' is TRUE an 's2dv_cube' conaining the 'SPEI' - in element data from 'exp' array with the same dimensions as 'exp'. - If it is FALSE, it is an array with the accumulated values of PET - minus 'prlr' data.} - \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not - NULL. It is an 's2dv_cube' with the SPEI data from 'exp_cor' in - element 'data'. If 'standarization' is FALSE, only the accumulated - values of PET minus 'prlr' is returned.} - \item{'params', returned if 'standarization' is TRUE, it contains the - parameters used for the standarization of 'exp' that are used for - computing the 'SPEI' for 'exp_cor'.} -} +An 's2dv_cube' object containing the SPEI multidimensional array in +element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' +will be provided. The parameters of the standardization will only be returned +if 'return_params' is TRUE. The SPEI will only be computed if +'standardization' is TRUE. If 'standardization' is FALSE, only the climatic +water balance (precipitation minus evapotranspiration) will be returned. The +resultant arrays will have the same dimensions as the initial input data. The +other elements in the 's2dv_cube' will be updated with the combined +information of the input data arrays. } \description{ Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) that is a multiscalar drought index based on climatic data. It can be used for determining the onset, duration and magnitude of drought conditions with respect to normal conditions in a variety of natural and managed systems such -as crops, ecosystems, rivers, water resources, etc. The SPI is calculated -using monthly (or weekly) precipitation as the input data. The SPEI uses the -monthly (or weekly) difference between precipitation and pet. This represents -a simple climatic water balance which is calculated at different time scales -to obtain the SPEI. +as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI +is to compare the highest possible evapotranspiration with the current water +availability. The SPEI uses the monthly (or weekly) difference between +precipitation and potential evapotranspiration. This represents a simple +climatic water balance which is calculated at different time scales to obtain +the SPEI. This function is build to work be compatible with other tools in +that work with 's2dv_cube' object class. The input data must be this object +class. If you don't work with 's2dv_cube', see PeriodSPEI. +} +\details{ +Next, some specifications for the calculation of this indicator will be +discussed. On the one hand, the model to be used to calculate potential +evapotranspiration is specified with the pet_method parameter (hargreaves, +hargraves modified or thornwhite). On the other hand, to choose the time scale +in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the +accum parameter, where you must indicate the number of time steps you want to +accumulate throughout leadtime_dim. Since the accumulation is done for the +elapsed time steps, there will be no complete accumulations until reaching the +time instant equal to the value of the parameter. For this reason, in the +result, we will find that for the dimension where the accumulation has been +carried out, the values of the array will be NA since they do not include +complete accumulations. Also, there is a parameter to specify if the +standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a +probability distribution to transform the original values to standardized +units that are comparable in space and time and at different SPEI time scales. +The na.rm parameter is a logical parameter used to decide whether to remove +the NA values from the data before doing the calculation. It must be taken +into account that if na.rm == FALSE and there is some NA value in the specific +coordinates which the SPEI is computed, standardization cannot be carried out +for those coordinates and therefore, the result will be filled with NA for the +specific coordinates. However, when na.rm == TRUE, if the amount of data for +those specific coordinates is smaller than 4, it will not be possible to carry +out because we will not have enough data and the result will be also filled +with NAs for that coordinates. } \examples{ dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 614b65c..a3dbf46 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -10,6 +10,7 @@ PeriodAccumulation( start = NULL, end = NULL, time_dim = "time", + rollingwidth = NULL, na.rm = FALSE, ncores = NULL ) @@ -37,6 +38,12 @@ compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} +\item{rollingwidth}{An optional parameter to indicate the number of time +steps the rolling sum is applied to. If it is negative, the rolling sum is +applied backwards 'time_dim', if it is positive, it will be towards it. When +this parameter is NULL, the sum is applied over all 'time_dim', in a +specified period. It is NULL by default.} + \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -58,6 +65,14 @@ by using this function: August 21st to October 21st} } } +\details{ +There are two possible ways of performing the accumulation. The default one +is by accumulating a variable over a dimension specified with 'time_dim'. To +chose a specific time period, start and end must be used. The other method +is by using rollingwidth parameter. When this parameter is a positive integer, +the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum +is applied towards 'time_dim'. +} \examples{ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd new file mode 100644 index 0000000..719d2fa --- /dev/null +++ b/man/PeriodPET.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodPET.R +\name{PeriodPET} +\alias{PeriodPET} +\title{Compute the Potential Evapotranspiration} +\usage{ +PeriodPET( + data, + dates, + lat, + pet_method = "hargreaves", + time_dim = "syear", + leadtime_dim = "time", + lat_dim = "latitude", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A named list with the needed \code{s2dv_cube} objects containing +the seasonal forecast experiment in the data element for each variable. +Specific variables are needed for each method used in computing the +Potential Evapotranspiration. See parameter 'pet_method'. The accepted +variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and +'hargreaves_modified' and 'tas', required for method 'thornthwaite'. +Variable 'prlr' is always needed. The units for temperature variables +('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for +precipitation ('prlr') need to be in mm/month.} + +\item{dates}{An array of temporal dimensions containing the Dates of +'exp'. It must be of class 'Date' or 'POSIXct'.} + +\item{lat}{A numeric vector containing the latitude values of 'exp'.} + +\item{pet_method}{A character string indicating the method used to compute +the potential evapotranspiration. The accepted methods are: +'hargreaves' and 'hargreaves_modified', that require the data to have +variables tasmin and tasmax; and 'thornthwaite', that requires variable +'tas'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{lat_dim}{A character string indicating the name of the latitudinal +dimension. By default it is set by 'latitude'.} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\description{ +Compute the Potential evapotranspiration (PET) that is the amount of +evaporation and transpiration that would occur if a sufficient water source +were available. Reference evapotranspiration (ETo) is the amount of +evaporation and transpiration from a reference vegetation of grass. They are +usually considered equivalent. This set of functions calculate PET or ETo +according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +} +\examples{ +dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) + +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +end_year <- 2012 +dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), + paste0(2010:end_year, "-09-15"), + paste0(2010:end_year, "-10-16")), "UTC") +dim(dates_exp) <- c(syear = 3, time = 3) + +lat <- c(40) + +exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) + +res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) + +} diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index 86aaa02..fc6c527 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -24,15 +24,15 @@ PeriodSPEI( pet_method = "hargreaves", method = "parametric", distribution = "log-Logistic", - fit = "ub-pwm", param_error = -9999, handle_infinity = FALSE, + return_params = FALSE, na.rm = FALSE, ncores = NULL ) } \arguments{ -\item{exp}{A named list with the needed \code{s2dv_cube} objects containing +\item{exp}{A named list with multidimensional array objects containing the seasonal forecast experiment in the data element for each variable. Specific variables are needed for each method used in computing the Potential Evapotranspiration. See parameter 'pet_method'. The accepted @@ -47,7 +47,7 @@ precipitation ('prlr') need to be in mm/month.} \item{lat}{A numeric vector containing the latitude values of 'exp'.} -\item{exp_cor}{A named list with the needed \code{s2dv_cube} objects for each +\item{exp_cor}{A named list with multidimensional array objects for each variable in which the quantile PeriodSPEI should be applied. If it is not specified, the PeriodSPEI is calculated from object 'exp'.} @@ -67,8 +67,10 @@ computed for individual members.} \item{lat_dim}{A character string indicating the name of the latitudinal dimension. By default it is set by 'latitude'.} -\item{accum}{An integer value indicating the number of months for the -accumulation for each variable.} +\item{accum}{accum An integer value indicating the number of months for the +accumulation for each variable. When it is greater than 1, the result will +be filled with NA until the accum time_dim dimension number due to the +accumulation to previous months.} \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default @@ -111,49 +113,75 @@ If can be: 'parametric' or 'non-parametric'.} \item{distribution}{A character string indicating the name of the distribution function to be used for computing the SPEI. The accepted names are: -'log-Logistic', 'Gamma' or 'PearsonIII'. It is set to 'log-Logistic' by -default.} - -\item{fit}{A character string indicating the name of the method used for -computing the distribution function parameters The accepteed names are: -'ub-pwm', 'pp-pwm' and 'max-lik'. It is set to 'ub-pwm' by default.} +'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +'Gamma' method only works when only precipitation is provided and other +variables are 0 because it is positive defined (SPI indicator).} \item{param_error}{A numeric value with the error accepted.} \item{handle_infinity}{A logical value wether to return Infinite values (TRUE) or not (FALSE).} +\item{return_params}{A logical value indicating wether to return parameters +array (TRUE) or not (FALSE). It is FALSE by default.} + \item{na.rm}{A logical value indicating whether NA values should be removed -from data. It is FALSE by default.} +from data. It is FALSE by default. If it is FALSE and there are NA values, +(if standardization is TRUE) all values of other dimensions except time_dim +and leadtime_dim will be set to NA directly. On the other hand, if it is +TRUE, if the data from other dimensions except time_dim and leadtime_dim is +not reaching 4 values, it is not enough values to estimate the parameters +and the result will include NA.} \item{ncores}{An integer value indicating the number of cores to use in parallel computation.} } \value{ -A list with elements: -\itemize{ - \item{'exp', if 'standarization' is TRUE an array conaining SPEI data from - 'exp' array with the same dimensions as 'exp'. If it is FALSE, it - is an array with the accumulated values of PET minus 'prlr' data.} - \item{'exp_cor', if 'standarization' is TRUE and if 'exp_cor' is not - NULL. It is an array with the SPEI data from 'exp_cor'. If - 'standarization' is FALSE, only the accumulated values of PET minus - 'prlr' is returned.} - \item{'params', returned if 'standarization' is TRUE, it contains the - parameters used for the standarization of 'exp' that are used for - computing the 'SPEI' for 'exp_cor'.} -} +An 's2dv_cube' object containing the SPEI multidimensional array in +element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' +will be provided. The parameters of the standardization will only be returned +if 'return_params' is TRUE. The SPEI will only be computed if +'standardization' is TRUE. If 'standardization' is FALSE, only the climatic +water balance (precipitation minus evapotranspiration) will be returned. The +resultant arrays will have the same dimensions as the initial input data. } \description{ Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) that is a multiscalar drought index based on climatic data. It can be used for determining the onset, duration and magnitude of drought conditions with respect to normal conditions in a variety of natural and managed systems such -as crops, ecosystems, rivers, water resources, etc. The SPI is calculated -using monthly (or weekly) precipitation as the input data. The SPEI uses the -monthly (or weekly) difference between precipitation and pet. This represents -a simple climatic water balance which is calculated at different time scales -to obtain the SPEI. +as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI +is to compare the highest possible evapotranspiration with the current water +availability. The SPEI uses the monthly (or weekly) difference between +precipitation and potential evapotranspiration. This represents a simple +climatic water balance which is calculated at different time scales to obtain +the SPEI. +} +\details{ +Next, some specifications for the calculation of this indicator will be +discussed. On the one hand, the model to be used to calculate potential +evapotranspiration is specified with the pet_method parameter (hargreaves, +hargraves modified or thornwhite). On the other hand, to choose the time scale +in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the +accum parameter, where you must indicate the number of time steps you want to +accumulate throughout leadtime_dim. Since the accumulation is done for the +elapsed time steps, there will be no complete accumulations until reaching the +time instant equal to the value of the parameter. For this reason, in the +result, we will find that for the dimension where the accumulation has been +carried out, the values of the array will be NA since they do not include +complete accumulations. Also, there is a parameter to specify if the +standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a +probability distribution to transform the original values to standardized +units that are comparable in space and time and at different SPEI time scales. +The na.rm parameter is a logical parameter used to decide whether to remove +the NA values from the data before doing the calculation. It must be taken +into account that if na.rm == FALSE and there is some NA value in the specific +coordinates which the SPEI is computed, standardization cannot be carried out +for those coordinates and therefore, the result will be filled with NA for the +specific coordinates. However, when na.rm == TRUE, if the amount of data for +those specific coordinates is smaller than 4, it will not be possible to carry +out because we will not have enough data and the result will be also filled +with NAs for that coordinates. } \examples{ dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 6898a93..64bf3d2 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -1,5 +1,22 @@ library(CSTools) +# dat1 +dat1 <- array(1:6, dim = c(sdate = 2, time = 3, member = 1)) + +# exp1 +exp <- NULL +exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, ftime = 214, lon = 2)) +exp$dims <- dim(exp$data) +exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +class(exp) <- 's2dv_cube' + ############################################## test_that("1. Sanity Checks", { expect_error( @@ -27,14 +44,14 @@ test_that("1. Sanity Checks", { PeriodAccumulation(1:10), 55 ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) expect_equal( PeriodAccumulation(data), array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4)) ) # Test dates warning expect_warning( - PeriodAccumulation(array(1:10, c(ftime = 10)), + PeriodAccumulation(array(1:10, c(time = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), @@ -43,7 +60,7 @@ test_that("1. Sanity Checks", { ) # start and end when dates is not provided expect_warning( - PeriodAccumulation(array(1:10, c(ftime = 10)), + PeriodAccumulation(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -53,18 +70,6 @@ test_that("1. Sanity Checks", { ############################################## test_that("2. Seasonal", { - exp <- NULL - exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) - exp$dims <- dim(exp$data) - exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), - as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2001", format = "%d-%m-%Y"), - as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2002", format = "%d-%m-%Y"), - as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) - class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(sum(exp$data[1,1,21:82,1]), sum(exp$data[1,2,21:82,1]), sum(exp$data[1,3,21:82,1]), sum(exp$data[1,1,21:82,2]), @@ -132,4 +137,27 @@ test_that("3. Subset Dates and check time_bounds", { all(lubridate::day(res$attrs$time_bounds$end) == 20), TRUE ) -}) \ No newline at end of file +}) + +############################################## + +test_that("4. Rolling", { + expect_error( + PeriodAccumulation(data = dat1, rollingwidth = 'a'), + "Parameter 'rollingwidth' must be a numeric value." + ) + expect_error( + PeriodAccumulation(data = dat1, rollingwidth = 5), + "Cannot compute accumulation of 5 months because loaded data has only 3 months." + ) + expect_equal( + PeriodAccumulation(data = dat1, rollingwidth = 2), + array(c(4,6,8, 10, NA, NA), dim = c(sdate = 2, time = 3, member = 1)) + ) + expect_equal( + PeriodAccumulation(data = dat1, rollingwidth = -3), + array(c(rep(NA, 4), 9, 12), dim = c(sdate = 2, time = 3, member = 1)) + ) + dat1[1,1,1] <- NA + PeriodAccumulation(data = dat1, rollingwidth = 2, na.rm = FALSE) +}) -- GitLab From c0919b19be5f79d9c9e2b760bc979d3e10bf3661 Mon Sep 17 00:00:00 2001 From: EVA RIFA ROVIRA Date: Wed, 2 Aug 2023 17:44:55 +0200 Subject: [PATCH 43/87] Add new function PeriodStandardization; change variable names in PeriodPET and improve PeriodAccumulation --- R/PeriodAccumulation.R | 15 ++-- R/PeriodPET.R | 44 ++++++------ R/PeriodStandardization.R | 147 ++++++++++++++++++++++++++++++++++++++ man/PeriodAccumulation.Rd | 1 + man/PeriodPET.Rd | 16 ++--- 5 files changed, 188 insertions(+), 35 deletions(-) create mode 100644 R/PeriodStandardization.R diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index b649a1d..553b1a5 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -201,10 +201,12 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' end = list(21, 10)) #' #'@import multiApply +#'@import zoo #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, time_dim = 'time', rollingwidth = NULL, - na.rm = FALSE, ncores = NULL) { + rolling_add_na = FALSE, na.rm = FALSE, + ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } @@ -258,11 +260,14 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, fun = function(x, accum, backroll, na.rm) { res <- rollapply(data = x, width = accum, FUN = sum, na.rm = na.rm) - if (backroll) { - return(c(rep(NA, accum-1), res)) - } else { - return(c(res, rep(NA, accum-1))) + if (rolling_add_na) { + if (backroll) { + res <- c(rep(NA, accum-1), res) + } else { + res <- c(res, rep(NA, accum-1)) + } } + return(res) }, accum = rollingwidth, backroll = backroll, na.rm = na.rm, ncores = ncores)$output1 pos <- match(dimnames, names(dim(total))) diff --git a/R/PeriodPET.R b/R/PeriodPET.R index fa4079c..67b6afd 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -11,19 +11,19 @@ #' the seasonal forecast experiment in the data element for each variable. #' Specific variables are needed for each method used in computing the #' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and -#' 'hargreaves_modified' and 'tas', required for method 'thornthwaite'. -#' Variable 'prlr' is always needed. The units for temperature variables -#' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for -#' precipitation ('prlr') need to be in mm/month. +#' variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and +#' 'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. +#' Variable 'pr' is always needed. The units for temperature variables +#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +#' precipitation ('pr') need to be in mm/month. #'@param dates An array of temporal dimensions containing the Dates of #' 'exp'. It must be of class 'Date' or 'POSIXct'. #'@param lat A numeric vector containing the latitude values of 'exp'. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have -#' variables tasmin and tasmax; and 'thornthwaite', that requires variable -#' 'tas'. +#' variables tmin and tmax; and 'thornthwaite', that requires variable +#' 'tmean'. #'@param time_dim A character string indicating the name of the temporal #' dimension. By default, it is set to 'syear'. #'@param leadtime_dim A character string indicating the name of the temporal @@ -49,7 +49,7 @@ #' #'lat <- c(40) #' -#'exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +#'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) #' #'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) #' @@ -92,20 +92,20 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', } # data (2) - if (all(c('tasmin', 'tasmax', 'prlr') %in% names(data))) { - # hargreaves modified: 'tasmin', 'tasmax', 'prlr' and 'lat' + if (all(c('tmin', 'tmax', 'pr') %in% names(data))) { + # hargreaves modified: 'tmin', 'tmax', 'pr' and 'lat' if (!(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { warning("Parameter 'pet_method' needs to be 'hargreaves' or ", "'hargreaves_modified'. It is set to 'hargreaves_modified'.") pet_method <- 'hargreaves_modified' } - } else if (all(c('tasmin', 'tasmax') %in% names(data))) { + } else if (all(c('tmin', 'tmax') %in% names(data))) { if (!(pet_method %in% c('hargreaves'))) { warning("Parameter 'pet_method' will be set as 'hargreaves'.") pet_method <- 'hargreaves' } - } else if (c('tas') %in% names(data)) { - # thornthwaite: 'tas' (mean), 'lat' + } else if (c('tmean') %in% names(data)) { + # thornthwaite: 'tmean' (mean), 'lat' if (!(pet_method == 'thornthwaite')) { warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") pet_method <- 'thornthwaite' @@ -173,17 +173,17 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', # extract mask of NA locations to return to NA the final result mask_na <- array(1, dim = dim(data[[1]])) if (pet_method == 'hargreaves') { - varnames <- c('tasmax', 'tasmin') - mask_na[which(is.na(data$tasmax))] <- 0 - mask_na[which(is.na(data$tasmin))] <- 0 + varnames <- c('tmax', 'tmin') + mask_na[which(is.na(data$tmax))] <- 0 + mask_na[which(is.na(data$tmin))] <- 0 } else if (pet_method == 'hargreaves_modified') { - varnames <- c('tasmax', 'tasmin', 'prlr') - mask_na[which(is.na(data$tasmax))] <- 0 - mask_na[which(is.na(data$tasmin))] <- 0 - mask_na[which(is.na(data$prlr))] <- 0 + varnames <- c('tmax', 'tmin', 'pr') + mask_na[which(is.na(data$tmax))] <- 0 + mask_na[which(is.na(data$tmin))] <- 0 + mask_na[which(is.na(data$pr))] <- 0 } else if (pet_method == 'thornthwaite') { - varnames <- c('tas') - mask_na[which(is.na(data$tas))] <- 0 + varnames <- c('tmean') + mask_na[which(is.na(data$tmean))] <- 0 } # replace NA with 0 diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R new file mode 100644 index 0000000..b4f21e4 --- /dev/null +++ b/R/PeriodStandardization.R @@ -0,0 +1,147 @@ + +# WIP + +PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', + leadtime_dim = 'time', memb_dim = 'ensemble', + ref_period = NULL, cross_validation = FALSE, + handle_infinity = FALSE, param_error = -9999, + method = 'parametric', distribution = 'log-Logistic', + na.rm = FALSE, ncores = NULL) { + # Initial checks + target_dims <- c(leadtime_dim, time_dim, memb_dim) + + if (is.null(ref_period)) { + ref.start <- NULL + ref.end <- NULL + } else { + ref.start <- ref_period[[1]] + ref.end <- ref_period[[2]] + } + + + # Standardization + if (is.null(data_cor)) { + spei <- Apply(data = list(data), + target_dims = target_dims, + fun = .standardization, + leadtime_dim = leadtime_dim, + time_dim = time_dim, memb_dim = memb_dim, + ref_period = ref_period, handle_infinity = handle_infinity, + cross_validation = cross_validation, param_error = param_error, + method = method, distribution = distribution, + na.rm = na.rm, ncores = ncores)$output1 + } else { + spei <- Apply(data = list(data, data_cor), target_dims = target_dims, + fun = .standardization, + leadtime_dim = leadtime_dim, + time_dim = time_dim, memb_dim = memb_dim, + ref_period = ref_period, handle_infinity = handle_infinity, + cross_validation = cross_validation, param_error = param_error, + method = method, distribution = distribution, + na.rm = na.rm, ncores = ncores)$output1 + } + return(spei) +} + +# data <- array(rnorm(10), c(time = 3, syear = 6, ensemble = 25)) + +# res <- .standardization(data = data) + +# data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, +# indices = ff, drop = 'selected') + +.standardization <- function(data, data_cor = NULL, leadtime_dim = 'time', + time_dim = 'syear', memb_dim = 'ensemble', + ref_period = NULL, handle_infinity = FALSE, + cross_validation = FALSE, param_error = -9999, + method = 'parametric', distribution = 'log-Logistic', + na.rm = FALSE) { + # data: [leadtime_dim, time_dim, memb_dim] + + # maximum number of parameters needed + nleadtime <- as.numeric(dim(data)[leadtime_dim]) + ntime <- as.numeric(dim(data)[time_dim]) + nmemb <- as.numeric(dim(data)[memb_dim]) + fit = 'ub-pwm' + + coef = switch(distribution, + "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha', 'beta'))), + "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi', 'alpha', 'kappa'))), + "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu', 'sigma', 'gamma')))) + + if (is.null(data_cor)) { + # cross_val = TRUE + spei_mod <- data*NA + print(dim(spei_mod)) + for (ff in 1:dim(data)[leadtime_dim]) { + data2 <- data[ff, , ] + params_result <- array(dim = c(dim(data)[time_dim], length(coef))) + print(dim(data2)) + if (!is.null(ref.start) && !is.null(ref.end)) { + data.fit <- window(data2, ref.start, ref.end) + } else { + data.fit <- data2 + } + for (nsd in 1:dim(data)[time_dim]) { + acu <- as.vector(data.fit[-nsd, ]) + acu.sorted <- sort.default(acu, method = "quick") + if (na.rm) { + acu.sorted <- acu.sorted[!is.na(acu.sorted)] + } + if (!any(is.na(acu.sorted))) { + print('Inside acu.sorted') + if (length(acu.sorted) != 0) { + acu_sd <- sd(acu.sorted) + if (!is.na(acu_sd) & acu_sd != 0) { + if (distribution != "log-Logistic") { + pze <- sum(acu == 0) / length(acu) + acu.sorted <- acu.sorted[acu.sorted > 0] + } + if (length(acu.sorted) >= 4) { + print('acu.sorted') + print(acu.sorted) + pwm = switch(fit, + "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), + pwm.ub(acu.sorted, nmom = 3) + # TLMoments::PWM(acu.sorted, order = 0:2) + ) + lmom <- pwm2lmom(pwm) + if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { + fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) + f_params = switch(distribution, + "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), + error = function(e){parglo(lmom)$para}), + "Gamma" = tryCatch(lmom::pelgam(fortran_vec), + error = function(e){pargam(lmom)$para}), + "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), + error = function(e){parpe3(lmom)$para})) + if (distribution == 'log-Logistic' && fit == 'max-lik') { + f_params = parglo.maxlik(acu.sorted, f_params)$para + } + params_result[nsd, ] <- f_params + } + } + if (all(is.na(params_result[nsd,]))) { + cdf_res <- NA + } else { + f_params <- params_result[nsd,] + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data, f_params), + "Gamma" = lmom::cdfgam(data, f_params), + "PearsonIII" = lmom::cdfpe3(data, f_params)) + } + std_index_cv <- array(qnorm(cdf_res), dim = c(ntime, nmemb)) + spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] + } + } + } + } + } + } else { + # cross_val = FALSE + + } + return(spei_mod) +} + diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index a3dbf46..c07afea 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -11,6 +11,7 @@ PeriodAccumulation( end = NULL, time_dim = "time", rollingwidth = NULL, + rolling_add_na = FALSE, na.rm = FALSE, ncores = NULL ) diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd index 719d2fa..69aad45 100644 --- a/man/PeriodPET.Rd +++ b/man/PeriodPET.Rd @@ -21,11 +21,11 @@ PeriodPET( the seasonal forecast experiment in the data element for each variable. Specific variables are needed for each method used in computing the Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and -'hargreaves_modified' and 'tas', required for method 'thornthwaite'. -Variable 'prlr' is always needed. The units for temperature variables -('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for -precipitation ('prlr') need to be in mm/month.} +variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and +'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. +Variable 'pr' is always needed. The units for temperature variables +('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +precipitation ('pr') need to be in mm/month.} \item{dates}{An array of temporal dimensions containing the Dates of 'exp'. It must be of class 'Date' or 'POSIXct'.} @@ -35,8 +35,8 @@ precipitation ('prlr') need to be in mm/month.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: 'hargreaves' and 'hargreaves_modified', that require the data to have -variables tasmin and tasmax; and 'thornthwaite', that requires variable -'tas'.} +variables tmin and tmax; and 'thornthwaite', that requires variable +'tmean'.} \item{time_dim}{A character string indicating the name of the temporal dimension. By default, it is set to 'syear'.} @@ -75,7 +75,7 @@ dim(dates_exp) <- c(syear = 3, time = 3) lat <- c(40) -exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) -- GitLab From b0f124fe7f9babddc312662fb0808472633d9c75 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 3 Aug 2023 18:31:48 +0200 Subject: [PATCH 44/87] Develop PeriodStandardization for exp_cor: reorganized code --- R/PeriodStandardization.R | 110 +++++++++++++++++++++++++++++++------- 1 file changed, 90 insertions(+), 20 deletions(-) diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index b4f21e4..88ab915 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -1,7 +1,7 @@ # WIP -PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', +PeriodStandardization <- function(data, data_cor = NULL, accum = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', ref_period = NULL, cross_validation = FALSE, handle_infinity = FALSE, param_error = -9999, @@ -40,22 +40,33 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', method = method, distribution = distribution, na.rm = na.rm, ncores = ncores)$output1 } + + # add NA + if (!is.null(accum)) { + spei <- Apply(data = list(spei), target_dims = leadtime_dim, + output_dims = leadtime_dim, + fun = function(x, accum, leadtime_dim) { + res <- c(rep(NA, accum-1), x) + return(res) + }, accum = accum, leadtime_dim = leadtime_dim)$output1 + } + if (is.null(data_cor)) { + pos <- match(names(dim(data)), names(dim(spei))) + spei <- aperm(spei, pos) + } else { + pos <- match(names(dim(data_cor)), names(dim(spei))) + spei <- aperm(spei, pos) + } return(spei) } -# data <- array(rnorm(10), c(time = 3, syear = 6, ensemble = 25)) - -# res <- .standardization(data = data) - -# data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, -# indices = ff, drop = 'selected') - .standardization <- function(data, data_cor = NULL, leadtime_dim = 'time', time_dim = 'syear', memb_dim = 'ensemble', ref_period = NULL, handle_infinity = FALSE, cross_validation = FALSE, param_error = -9999, method = 'parametric', distribution = 'log-Logistic', na.rm = FALSE) { + print(summary(data)) # data: [leadtime_dim, time_dim, memb_dim] # maximum number of parameters needed @@ -72,11 +83,10 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', if (is.null(data_cor)) { # cross_val = TRUE spei_mod <- data*NA - print(dim(spei_mod)) + params_result <- array(data = NA, dim = c(ntime, nleadtime, length(coef))) for (ff in 1:dim(data)[leadtime_dim]) { data2 <- data[ff, , ] - params_result <- array(dim = c(dim(data)[time_dim], length(coef))) - print(dim(data2)) + dim(data2) <- c(ntime, nmemb) if (!is.null(ref.start) && !is.null(ref.end)) { data.fit <- window(data2, ref.start, ref.end) } else { @@ -89,7 +99,6 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', acu.sorted <- acu.sorted[!is.na(acu.sorted)] } if (!any(is.na(acu.sorted))) { - print('Inside acu.sorted') if (length(acu.sorted) != 0) { acu_sd <- sd(acu.sorted) if (!is.na(acu_sd) & acu_sd != 0) { @@ -98,8 +107,6 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', acu.sorted <- acu.sorted[acu.sorted > 0] } if (length(acu.sorted) >= 4) { - print('acu.sorted') - print(acu.sorted) pwm = switch(fit, "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), pwm.ub(acu.sorted, nmom = 3) @@ -118,18 +125,18 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', if (distribution == 'log-Logistic' && fit == 'max-lik') { f_params = parglo.maxlik(acu.sorted, f_params)$para } - params_result[nsd, ] <- f_params + params_result[nsd, ff, ] <- f_params } } - if (all(is.na(params_result[nsd,]))) { + if (all(is.na(params_result[nsd, ff, ]))) { cdf_res <- NA } else { - f_params <- params_result[nsd,] + f_params <- params_result[nsd, ff, ] f_params <- f_params[which(!is.na(f_params))] cdf_res = switch(distribution, - "log-Logistic" = lmom::cdfglo(data, f_params), - "Gamma" = lmom::cdfgam(data, f_params), - "PearsonIII" = lmom::cdfpe3(data, f_params)) + "log-Logistic" = lmom::cdfglo(data2, f_params), + "Gamma" = lmom::cdfgam(data2, f_params), + "PearsonIII" = lmom::cdfpe3(data2, f_params)) } std_index_cv <- array(qnorm(cdf_res), dim = c(ntime, nmemb)) spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] @@ -140,7 +147,70 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', } } else { # cross_val = FALSE + spei_mod <- data_cor*NA + params_result <- array(data = NA, dim = c(1, length(coef))) + for (ff in 1:dim(data)[leadtime_dim]) { + data_cor2 <- data_cor[ff, , ] + dim(data_cor2) <- c(1, nmemb) + data2 <- data[ff, , ] + dim(data2) <- c(ntime, nmemb) + if (!is.null(ref.start) && !is.null(ref.end)) { + data.fit <- window(data2, ref.start, ref.end) + } else { + data.fit <- data2 + } + acu <- as.vector(data.fit) + acu.sorted <- sort.default(acu, method = "quick") + if (na.rm) { + acu.sorted <- acu.sorted[!is.na(acu.sorted)] + } + if (!any(is.na(acu.sorted))) { + if (length(acu.sorted) != 0) { + acu_sd <- sd(acu.sorted) + if (!is.na(acu_sd) & acu_sd != 0) { + if (distribution != "log-Logistic") { + pze <- sum(acu == 0) / length(acu) + acu.sorted <- acu.sorted[acu.sorted > 0] + } + if (length(acu.sorted) >= 4) { + pwm = switch(fit, + "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), + pwm.ub(acu.sorted, nmom = 3) + # TLMoments::PWM(acu.sorted, order = 0:2) + ) + lmom <- pwm2lmom(pwm) + if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { + fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) + f_params = switch(distribution, + "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), + error = function(e){parglo(lmom)$para}), + "Gamma" = tryCatch(lmom::pelgam(fortran_vec), + error = function(e){pargam(lmom)$para}), + "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), + error = function(e){parpe3(lmom)$para})) + if (distribution == 'log-Logistic' && fit == 'max-lik') { + f_params = parglo.maxlik(acu.sorted, f_params)$para + } + params_result[1, ] <- f_params + } + } + if (all(is.na(params_result[1, ]))) { + cdf_res <- NA + } else { + f_params <- params_result[1, ] + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data_cor2, f_params), + "Gamma" = lmom::cdfgam(data_cor2, f_params), + "PearsonIII" = lmom::cdfpe3(data_cor2, f_params)) + } + std_index_cv <- array(qnorm(cdf_res), dim = c(1, nmemb)) + spei_mod[ff, , ] <- std_index_cv + } + } + } + } } return(spei_mod) } -- GitLab From 9b78395ef69a7f58a17dd6f0f3afb1a994745621 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 7 Aug 2023 09:24:00 +0200 Subject: [PATCH 45/87] Change variable names in PeriodSPEI --- R/PeriodSPEI.R | 89 +++++++++++++++++++++++-------------------- man/CST_PeriodSPEI.Rd | 24 ++++++------ man/PeriodSPEI.Rd | 24 ++++++------ 3 files changed, 72 insertions(+), 65 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 9bc1660..5e78d7d 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -42,11 +42,11 @@ #' the seasonal forecast experiment in the data element for each variable. #' Specific variables are needed for each method used in computing the #' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and -#' 'hargreaves_modified' and 'tas', required for method 'thornthwaite'. -#' Variable 'prlr' is always needed. The units for temperature variables -#' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for -#' precipitation ('prlr') need to be in mm/month. +#' variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and +#' 'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. +#' Variable 'pr' is always needed. The units for temperature variables +#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +#' precipitation ('pr') need to be in mm/month. #'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each #' variable in which the quantile PeriodSPEI should be applied. If it is not #' specified, the PeriodSPEI is calculated from object 'exp'. @@ -77,11 +77,11 @@ #' have member dimension (specified in 'memb_dim'). #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the -#' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +#' variable 'pr' of 'exp'. If it is NULL it is calculated using the provided #' variables with specified 'pet_method'. It is NULL by default. #'@param pet_expcor A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -#' the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +#' the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the #' provided variables with specified 'pet_method'. It is NULL by default. #'@param standardization A logical value indicating wether the standardization #' is computed. @@ -91,8 +91,8 @@ #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have -#' variables tasmin and tasmax; and 'thornthwaite', that requires variable -#' 'tas'. +#' variables tmin and tmax; and 'thornthwaite', that requires variable +#' 'tmean'. #'@param method A character string indicating the standardization method used. #' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by #' default. @@ -147,9 +147,9 @@ #'expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) #'expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) #' -#'exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) -#'exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, -#' 'prlr' = expcor_prlr) +#'exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +#'exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, +#' 'pr' = expcor_prlr) #' #'exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), #' Dates = dates_exp) @@ -323,11 +323,11 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' the seasonal forecast experiment in the data element for each variable. #' Specific variables are needed for each method used in computing the #' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and -#' 'hargreaves_modified' and 'tas', required for method 'thornthwaite'. -#' Variable 'prlr' is always needed. The units for temperature variables -#' ('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for -#' precipitation ('prlr') need to be in mm/month. +#' variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and +#' 'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. +#' Variable 'pr' is always needed. The units for temperature variables +#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +#' precipitation ('pr') need to be in mm/month. #'@param dates_exp An array of temporal dimensions containing the Dates of #' 'exp'. It must be of class 'Date' or 'POSIXct'. #'@param lat A numeric vector containing the latitude values of 'exp'. @@ -362,11 +362,11 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' leadtime dimension (specified in 'leadtime_dim') of length 1. #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the -#' variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +#' variable 'pr' of 'exp'. If it is NULL it is calculated using the provided #' variables with specified 'pet_method'. It is NULL by default. #'@param pet_expcor A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -#' the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +#' the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the #' provided variables with specified 'pet_method'. It is NULL by default. #'@param standardization A logical value indicating wether the standardization #' is computed. @@ -376,8 +376,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have -#' variables tasmin and tasmax; and 'thornthwaite', that requires variable -#' 'tas'. +#' variables tmin and tmax; and 'thornthwaite', that requires variable +#' 'tmean'. #'@param method A character string indicating the standardization method used. #' If can be: 'parametric' or 'non-parametric'. #'@param distribution A character string indicating the name of the distribution @@ -431,9 +431,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) #'lat <- c(40,40.1) #' -#'exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) -#'exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, -#' 'prlr' = expcor_prlr) +#'exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +#'exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, +#' 'pr' = expcor_prlr) #'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, #' dates_exp = dates_exp, dates_expcor = dates_expcor) #' @@ -498,13 +498,13 @@ PeriodSPEI <- function(exp, dates_exp, lat, # Variable checks ## exp (2) pet <- vector("list", 2) - if (!('prlr' %in% names(exp))) { - stop("Variable 'prlr' is not included in 'exp'.") + if (!('pr' %in% names(exp))) { + stop("Variable 'pr' is not included in 'exp'.") } ## exp_cor (2) if (!is.null(exp_cor)) { - if (!('prlr' %in% names(exp_cor))) { - stop("Variable 'prlr' is not included in 'exp_cor'.") + if (!('pr' %in% names(exp_cor))) { + stop("Variable 'pr' is not included in 'exp_cor'.") } if (length(pet_method) == 1) { pet_method <- rep(pet_method, 2) @@ -513,16 +513,16 @@ PeriodSPEI <- function(exp, dates_exp, lat, ## pet_exp if (!is.null(pet_exp)) { - if (length(dim(exp[['prlr']])) != length(dim(pet_exp))) { + if (length(dim(exp[['pr']])) != length(dim(pet_exp))) { stop("Parameter 'pet_exp' must have the same length of all the ", - "dimensions as variable 'prlr' in 'exp'.") + "dimensions as variable 'pr' in 'exp'.") } - if (!all(dim(exp[['prlr']]) %in% dim(pet_exp))) { + if (!all(dim(exp[['pr']]) %in% dim(pet_exp))) { stop("Parameter 'pet_exp' must have the same length of all the ", - "dimensions as variable 'prlr' in 'exp'.") + "dimensions as variable 'pr' in 'exp'.") } - if (any(names(dim(exp[['prlr']])) != names(dim(pet_exp)))) { - pos <- match(names(dim(exp[['prlr']])), names(dim(pet_exp))) + if (any(names(dim(exp[['pr']])) != names(dim(pet_exp)))) { + pos <- match(names(dim(exp[['pr']])), names(dim(pet_exp))) pet_exp <- aperm(pet_exp, pos) } pet[[1]] <- pet_exp @@ -532,16 +532,16 @@ PeriodSPEI <- function(exp, dates_exp, lat, ## pet_expcor if (!is.null(exp_cor)) { if (!is.null(pet_expcor)) { - if (length(dim(exp_cor[['prlr']])) != length(dim(pet_expcor))) { + if (length(dim(exp_cor[['pr']])) != length(dim(pet_expcor))) { stop("Parameter 'pet_expcor' must have the same length of all the ", - "dimensions as variable 'prlr' in 'exp_cor'.") + "dimensions as variable 'pr' in 'exp_cor'.") } - if (!all(dim(exp_cor[['prlr']]) %in% dim(pet_expcor))) { + if (!all(dim(exp_cor[['pr']]) %in% dim(pet_expcor))) { stop("Parameter 'pet_expcor' must have the same length of all the ", - "dimensions as variable 'prlr' in 'exp_cor'.") + "dimensions as variable 'pr' in 'exp_cor'.") } - if (any(names(dim(exp_cor[['prlr']])) != names(dim(pet_expcor)))) { - pos <- match(names(dim(exp_cor[['prlr']])), names(dim(pet_expcor))) + if (any(names(dim(exp_cor[['pr']])) != names(dim(pet_expcor)))) { + pos <- match(names(dim(exp_cor[['pr']])), names(dim(pet_expcor))) pet_expcor <- aperm(pet_expcor, pos) } pet[[2]] <- pet_expcor @@ -767,11 +767,13 @@ PeriodSPEI <- function(exp, dates_exp, lat, lat = lat, pet_method = pet_method[k], time_dim = time_dim, leadtime_dim = leadtime_dim, lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) + print("Step (1): PET") + print(summary(pet[[k]])) computed_pet <- TRUE } # Accumulation - diff_p_pet <- data$prlr - pet[[k]] + diff_p_pet <- data$pr - pet[[k]] accumulated <- Apply(data = list(diff_p_pet), target_dims = list(data = c(leadtime_dim, time_dim)), @@ -779,6 +781,8 @@ PeriodSPEI <- function(exp, dates_exp, lat, fun = function(data, accum) { return(rollapply(data = data, width = accum, FUN = sum)) }, accum = accum, ncores = ncores)$output1 + print("Step (2): Accumulation") + print(summary(accumulated)) # Standardization if (standardization) { @@ -791,6 +795,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, param_error = param_error, method = method, distribution = distribution, na.rm = na.rm, ncores = ncores) + ref_period <- NULL params <- spei$params spei_res <- spei[[1]] @@ -806,6 +811,8 @@ PeriodSPEI <- function(exp, dates_exp, lat, }, accum = accum, leadtime_dim = leadtime_dim)$output1 pos <- match(names(dim(data[[1]])), names(dim(spei_res))) spei_res <- aperm(spei_res, pos) + print("Step (3): Standardization") + print(summary(spei_res)) } if (standardization) { diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index eaa139e..19bf92a 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -33,11 +33,11 @@ CST_PeriodSPEI( the seasonal forecast experiment in the data element for each variable. Specific variables are needed for each method used in computing the Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and -'hargreaves_modified' and 'tas', required for method 'thornthwaite'. -Variable 'prlr' is always needed. The units for temperature variables -('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for -precipitation ('prlr') need to be in mm/month.} +variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and +'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. +Variable 'pr' is always needed. The units for temperature variables +('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +precipitation ('pr') need to be in mm/month.} \item{exp_cor}{A named list with the needed \code{s2dv_cube} objects for each variable in which the quantile PeriodSPEI should be applied. If it is not @@ -77,12 +77,12 @@ have member dimension (specified in 'memb_dim').} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the -variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +variable 'pr' of 'exp'. If it is NULL it is calculated using the provided variables with specified 'pet_method'. It is NULL by default.} \item{pet_expcor}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the provided variables with specified 'pet_method'. It is NULL by default.} \item{standardization}{A logical value indicating wether the standardization @@ -95,8 +95,8 @@ is not provided. It is FALSE by default.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: 'hargreaves' and 'hargreaves_modified', that require the data to have -variables tasmin and tasmax; and 'thornthwaite', that requires variable -'tas'.} +variables tmin and tmax; and 'thornthwaite', that requires variable +'tmean'.} \item{method}{A character string indicating the standardization method used. If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by @@ -198,9 +198,9 @@ expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) -exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) -exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, - 'prlr' = expcor_prlr) +exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, + 'pr' = expcor_prlr) exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), Dates = dates_exp) diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index fc6c527..56b687c 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -36,11 +36,11 @@ PeriodSPEI( the seasonal forecast experiment in the data element for each variable. Specific variables are needed for each method used in computing the Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables are: 'tasmin' and 'tasmax', required for methods 'hargreaves' and -'hargreaves_modified' and 'tas', required for method 'thornthwaite'. -Variable 'prlr' is always needed. The units for temperature variables -('tasmin', 'tasmax' and 'tas') need to be in Celcius degrees; the units for -precipitation ('prlr') need to be in mm/month.} +variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and +'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. +Variable 'pr' is always needed. The units for temperature variables +('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +precipitation ('pr') need to be in mm/month.} \item{dates_exp}{An array of temporal dimensions containing the Dates of 'exp'. It must be of class 'Date' or 'POSIXct'.} @@ -87,12 +87,12 @@ leadtime dimension (specified in 'leadtime_dim') of length 1.} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the -variable 'prlr' of 'exp'. If it is NULL it is calculated using the provided +variable 'pr' of 'exp'. If it is NULL it is calculated using the provided variables with specified 'pet_method'. It is NULL by default.} \item{pet_expcor}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -the variable 'prlr' of 'exp_cor'. If it is NULL it is calculated using the +the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the provided variables with specified 'pet_method'. It is NULL by default.} \item{standardization}{A logical value indicating wether the standardization @@ -105,8 +105,8 @@ is not provided. It is FALSE by default.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: 'hargreaves' and 'hargreaves_modified', that require the data to have -variables tasmin and tasmax; and 'thornthwaite', that requires variable -'tas'.} +variables tmin and tmax; and 'thornthwaite', that requires variable +'tmean'.} \item{method}{A character string indicating the standardization method used. If can be: 'parametric' or 'non-parametric'.} @@ -206,9 +206,9 @@ dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) lat <- c(40,40.1) -exp <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) -exp_cor <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, - 'prlr' = expcor_prlr) +exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, + 'pr' = expcor_prlr) res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor) -- GitLab From bd84633f56cd53752ee802592f5318ed0d087a79 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 7 Aug 2023 11:11:59 +0200 Subject: [PATCH 46/87] Add reference in function MergeRefToExp --- R/MergeRefToExp.R | 23 ++++++++++++++++++----- man/CST_MergeRefToExp.Rd | 25 ++++++++++++++++++++----- 2 files changed, 38 insertions(+), 10 deletions(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 03425c8..3cd9d96 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -9,6 +9,11 @@ #'1st the forecast covers until the beginning of June next year), a climatology #'(or other references) could be added at the end of the forecast lead time to #'cover the desired period (e.g.: until the end of summer). +#' +#'This function is created to merge observations and forecasts in the +#'bioclimatic indicator structure, known as the ‘blending’ strategy (see +#'references). This key strategy aims to increase users’ confidence in the +#'reformed predictions. #' #'@param data1 An 's2dv_cube' object with the element 'data' being a #' multidimensional array with named dimensions. All dimensions must be @@ -50,11 +55,19 @@ #'common to both arrays and for the 'time_dim' dimension, the sum of the #'corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, #'regarding member dimension, two different situations can occur: (1) in the -#'case that one of the arrays does not have member dimension or is equal to 1, -#'the result will contain the repeated values of itself; (2) in the case that -#'both arrays have member dimension and is greater than 1, all combinations of -#'member dimension will be returned. The other elements of the 's2dv_cube' will -#'be updated with the combined information of both datasets. +#'case that one of the arrays does not have member dimension or is equal to 1 +#'and the other array has multiple member dimension, the result will contain the +#'repeated values of the array one up to the lenght of member dimension of array +#'two; (2) in the case that both arrays have member dimension and is greater +#'than 1, all combinations of member dimension will be returned. The other +#'elements of the 's2dv_cube' will be updated with the combined information of +#'both datasets. +#' +#'@references Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +#'M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +#'N. González-Reviriego (2023). Advanced seasonal predictions for vine +#'management based on bioclimatic indicators tailored to the wine sector. +#'Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index bbca8c4..5ab328b 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -67,11 +67,13 @@ the following dimensions: the original dimensions of the input data, which are common to both arrays and for the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, regarding member dimension, two different situations can occur: (1) in the -case that one of the arrays does not have member dimension or is equal to 1, -the result will contain the repeated values of itself; (2) in the case that -both arrays have member dimension and is greater than 1, all combinations of -member dimension will be returned. The other elements of the 's2dv_cube' will -be updated with the combined information of both datasets. +case that one of the arrays does not have member dimension or is equal to 1 +and the other array has multiple member dimension, the result will contain the +repeated values of the array one up to the lenght of member dimension of array +two; (2) in the case that both arrays have member dimension and is greater +than 1, all combinations of member dimension will be returned. The other +elements of the 's2dv_cube' will be updated with the combined information of +both datasets. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from @@ -84,6 +86,12 @@ period because it is initialized too early (e.g.: Initialization on November (or other references) could be added at the end of the forecast lead time to cover the desired period (e.g.: until the end of summer). } +\details{ +This function is created to merge observations and forecasts in the +bioclimatic indicator structure, known as the ‘blending’ strategy (see +references). This key strategy aims to increase users’ confidence in the +reformed predictions. +} \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), @@ -106,3 +114,10 @@ new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, start2 = list(1, 7), end2 = list(21, 9)) } +\references{ +Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +N. González-Reviriego (2023). Advanced seasonal predictions for vine +management based on bioclimatic indicators tailored to the wine sector. +Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. +} -- GitLab From c28af1f408eb869ebb9a77f78e35bc45dadb70e9 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 7 Aug 2023 11:21:18 +0200 Subject: [PATCH 47/87] Correct modification of documentation --- R/MergeRefToExp.R | 20 ++++++++++++++++---- man/MergeRefToExp.Rd | 22 ++++++++++++++++++---- 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 3cd9d96..898f32e 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -233,6 +233,11 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #'1st the forecast covers until the beginning of June next year), a climatology #'(or other references) could be added at the end of the forecast lead time to #'cover the desired period (e.g.: until the end of summer). +#' +#'This function is created to merge observations and forecasts in the +#'bioclimatic indicator structure, known as the ‘blending’ strategy (see +#'references). This key strategy aims to increase users’ confidence in the +#'reformed predictions. #' #'@param data1 A multidimensional array with named dimensions. All dimensions #' must be equal to 'data2' dimensions except for the ones specified with @@ -278,10 +283,17 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #'the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' #'and 'data2'. If 'memb_dim' is not null, regarding member dimension, two #'different situations can occur: (1) in the case that one of the arrays does -#'not have member dimension or is equal to 1, the result will contain the -#'repeated values of itself; (2) in the case that both arrays have member -#'dimension and is greater than 1, all combinations of member dimension will be -#'returned. +#'not have member dimension or is equal to 1 and the other array has multiple +#'member dimension, the result will contain the repeated values of the array one +#'up to the lenght of member dimension of array two; (2) in the case that both +#'arrays have member dimension and is greater than 1, all combinations of member +#'dimension will be returned. +#' +#'@references Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +#'M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +#'N. González-Reviriego (2023). Advanced seasonal predictions for vine +#'management based on bioclimatic indicators tailored to the wine sector. +#'Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index e22b52d..047ad37 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -74,10 +74,11 @@ original dimensions of the input data, which are common to both arrays and for the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, regarding member dimension, two different situations can occur: (1) in the case that one of the arrays does -not have member dimension or is equal to 1, the result will contain the -repeated values of itself; (2) in the case that both arrays have member -dimension and is greater than 1, all combinations of member dimension will be -returned. +not have member dimension or is equal to 1 and the other array has multiple +member dimension, the result will contain the repeated values of the array one +up to the lenght of member dimension of array two; (2) in the case that both +arrays have member dimension and is greater than 1, all combinations of member +dimension will be returned. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from @@ -90,6 +91,12 @@ period because it is initialized too early (e.g.: Initialization on November (or other references) could be added at the end of the forecast lead time to cover the desired period (e.g.: until the end of summer). } +\details{ +This function is created to merge observations and forecasts in the +bioclimatic indicator structure, known as the ‘blending’ strategy (see +references). This key strategy aims to increase users’ confidence in the +reformed predictions. +} \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), @@ -107,3 +114,10 @@ new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), time_dim = 'ftime') } +\references{ +Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +N. González-Reviriego (2023). Advanced seasonal predictions for vine +management based on bioclimatic indicators tailored to the wine sector. +Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. +} -- GitLab From f202fc5540032772a09b265bcd4ef6587d221da0 Mon Sep 17 00:00:00 2001 From: erifarov Date: Thu, 10 Aug 2023 17:16:36 +0200 Subject: [PATCH 48/87] Add new directory .gitlab --- .gitlab/.gitkeep | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 .gitlab/.gitkeep diff --git a/.gitlab/.gitkeep b/.gitlab/.gitkeep new file mode 100644 index 0000000..e69de29 -- GitLab From a7dc45a6ac98826a33d3768ccee69699283dec47 Mon Sep 17 00:00:00 2001 From: erifarov Date: Thu, 10 Aug 2023 17:17:22 +0200 Subject: [PATCH 49/87] Add new directory issue_templates --- .gitlab/issue_templates/.gitkeep | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 .gitlab/issue_templates/.gitkeep diff --git a/.gitlab/issue_templates/.gitkeep b/.gitlab/issue_templates/.gitkeep new file mode 100644 index 0000000..e69de29 -- GitLab From 152f912b19d820722c58dfda57461d770e2d007f Mon Sep 17 00:00:00 2001 From: erifarov Date: Thu, 10 Aug 2023 17:23:59 +0200 Subject: [PATCH 50/87] Add new file --- .gitlab/issue_templates/default.md | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 .gitlab/issue_templates/default.md diff --git a/.gitlab/issue_templates/default.md b/.gitlab/issue_templates/default.md new file mode 100644 index 0000000..a430b52 --- /dev/null +++ b/.gitlab/issue_templates/default.md @@ -0,0 +1,25 @@ +(This is a template to report errors and bugs. Please fill in the relevant information and delete the rest.) + +Hi @erifarov (and @aho), + +#### R and packages version +(Which R version are you using? ex. 4.1.2) +(Which R packages versions are you using? use sessionInfo(). ex. CSIndicators_1.0.1, CSTools_5.0.1 ...) +(Which machine are you using? WS, Nord3, other...) + +#### Summary +(Bug: Summarize the bug and explain briefly the expected and the current behavior.) +(New development: Summarize the development needed.) + +#### Example +(Bug: Provide a **minimal reproducible example** and the error message.) +(New development: Provide an example script or useful piece of code if needed.) + +``` +Example: +[ERROR!]: Something went really wrong! +This is the error message that showed up on the terminal. +``` + +#### Other Relevant Information +(Additional information.) -- GitLab From c2ebd0798429b289d9b96f58ce2d863b16152069 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 6 Sep 2023 16:30:41 +0200 Subject: [PATCH 51/87] Add CST_PeriodStandardization, Improve PeriodStandardization and add documentation --- NAMESPACE | 3 + R/PeriodPET.R | 115 +++++++- R/PeriodSPEI.R | 2 +- R/PeriodStandardization.R | 486 +++++++++++++++++++++++-------- man/CST_PeriodPET.Rd | 80 +++++ man/CST_PeriodStandardization.Rd | 91 ++++++ man/PeriodPET.Rd | 10 +- man/PeriodStandardization.Rd | 91 ++++++ 8 files changed, 750 insertions(+), 128 deletions(-) create mode 100644 man/CST_PeriodPET.Rd create mode 100644 man/CST_PeriodStandardization.Rd create mode 100644 man/PeriodStandardization.Rd diff --git a/NAMESPACE b/NAMESPACE index c67f13e..49ec262 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,7 +7,9 @@ export(CST_AccumulationExceedingThreshold) export(CST_MergeRefToExp) export(CST_PeriodAccumulation) export(CST_PeriodMean) +export(CST_PeriodPET) export(CST_PeriodSPEI) +export(CST_PeriodStandardization) export(CST_QThreshold) export(CST_SelectPeriodOnData) export(CST_Threshold) @@ -20,6 +22,7 @@ export(PeriodAccumulation) export(PeriodMean) export(PeriodPET) export(PeriodSPEI) +export(PeriodStandardization) export(QThreshold) export(SelectPeriodOnData) export(SelectPeriodOnDates) diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 67b6afd..8ab1a64 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -11,14 +11,119 @@ #' the seasonal forecast experiment in the data element for each variable. #' Specific variables are needed for each method used in computing the #' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and -#' 'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. -#' Variable 'pr' is always needed. The units for temperature variables +#' variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for +#' 'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' +#' 'tmean' is required. The units for temperature variables #' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for #' precipitation ('pr') need to be in mm/month. #'@param dates An array of temporal dimensions containing the Dates of -#' 'exp'. It must be of class 'Date' or 'POSIXct'. -#'@param lat A numeric vector containing the latitude values of 'exp'. +#' 'data'. It must be of class 'Date' or 'POSIXct'. +#'@param lat A numeric vector containing the latitude values of 'data'. +#'@param pet_method A character string indicating the method used to compute +#' the potential evapotranspiration. The accepted methods are: +#' 'hargreaves' and 'hargreaves_modified', that require the data to have +#' variables tmin and tmax; and 'thornthwaite', that requires variable +#' 'tmean'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param lat_dim A character string indicating the name of the latitudinal +#' dimension. By default it is set by 'latitude'. +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@examples +#'dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) +#' +#'exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +#'end_year <- 2012 +#'dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), +#' paste0(2010:end_year, "-09-15"), +#' paste0(2010:end_year, "-10-16")), "UTC") +#'dim(dates_exp) <- c(syear = 3, time = 3) +#' +#'lat <- c(40) +#' +#'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +#' +#'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) +#' +#'@import SPEI +#'@import lubridate +#'@import multiApply +#'@export +CST_PeriodPET <- function(data, pet_method = 'hargreaves', + time_dim = 'syear', leadtime_dim = 'time', + lat_dim = 'latitude', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!all(sapply(data, function(x) inherits(x, 's2dv_cube')))) { + stop("Parameter 'data' must be a list of 's2dv_cube' class.") + } + # latitude + if (!any(names(data[[1]]$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of parameter 'data' do not match any ", + "of the names accepted by the package.") + } + # Dates + dates_exp <- data[[1]]$attrs$Dates + if (!'Dates' %in% names(data[[1]]$attrs)) { + stop("Element 'Dates' is not found in 'attrs' list of 'data'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") + } + lat_dim <- names(data[[1]]$coords)[[which(names(data[[1]]$coords) %in% .KnownLatNames())]] + + res <- PeriodPET(data = lapply(data, function(x) x$data), + dates = data[[1]]$attrs$Dates, + lat = data[[1]]$coords[[lat_dim]], + pet_method = pet_method, time_dim = time_dim, + leadtime_dim = leadtime_dim, lat_dim = lat_dim, + na.rm = na.rm, ncores = ncores) + # Add metadata + source_files <- lapply(data, function(x) {x$attrs$source_files}) + coords <- data[[1]]$coords + Dates <- data[[1]]$attrs$Dates + metadata <- data[[1]]$attrs$Variable$metadata + metadata_names <- intersect(names(dim(res)), names(metadata)) + res <- CSTools::s2dv_cube(data = res, coords = coords, + varName = paste0('PET'), + metadata = metadata[metadata_names], + Dates = Dates, + source_files = source_files, + when = Sys.time()) + return(res) +} + +#'Compute the Potential Evapotranspiration +#' +#'Compute the Potential evapotranspiration (PET) that is the amount of +#'evaporation and transpiration that would occur if a sufficient water source +#'were available. Reference evapotranspiration (ETo) is the amount of +#'evaporation and transpiration from a reference vegetation of grass. They are +#'usually considered equivalent. This set of functions calculate PET or ETo +#'according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +#' +#'@param data A named list with the needed \code{s2dv_cube} objects containing +#' the seasonal forecast experiment in the data element for each variable. +#' Specific variables are needed for each method used in computing the +#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted +#' variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for +#' 'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' +#' 'tmean' is required. The units for temperature variables +#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +#' precipitation ('pr') need to be in mm/month. +#'@param dates An array of temporal dimensions containing the Dates of +#' 'data'. It must be of class 'Date' or 'POSIXct'. +#'@param lat A numeric vector containing the latitude values of 'data'. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 5e78d7d..979e79d 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -903,7 +903,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, } else if (anyNA(data) && !na.rm) { spei_mod <- array(NA, dim(data)) } else if (var(data, na.rm = T) == 0) { - spei_mod <- array(param_error, dim(data)) + spei_mod <- array(param_error, dim(data)) # Add this? } else { if (is.null(ref_period)) { ref.start <- NULL diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 88ab915..73792ef 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -1,42 +1,299 @@ -# WIP +#'Compute the Standardization of Precipitation-Evapotranspiration Index +#' +#'@param data An 's2dv_cube' that element 'data' stores a multidimensional +#' array containing the data to be standardized. +#'@param data_cor An 's2dv_cube' that element 'data' stores a multidimensional +#' array containing the data in which the standardization should be applied +#' using the fitting parameters from 'data'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param memb_dim A character string indicating the name of the dimension in +#' which the ensemble members are stored. When set it to NULL, threshold is +#' computed for individual members. +#'@param accum An integer value indicating the number of months for the +#' accumulation for each variable. When it is greater than 1, the result will +#' be filled with NA until the accum time_dim dimension number due to the +#' accumulation to previous months. +#'@param ref_period A list with two numeric values with the starting and end +#' points of the reference period used for computing the index. The default +#' value is NULL indicating that the first and end values in data will be +#' used as starting and end points. +#'@param param_error A numeric value with the error accepted. +#'@param handle_infinity A logical value wether to return Infinite values (TRUE) +#' or not (FALSE). +#'@param method A character string indicating the standardization method used. +#' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +#' default. +#'@param distribution A character string indicating the name of the distribution +#' function to be used for computing the SPEI. The accepted names are: +#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +#' 'Gamma' method only works when only precipitation is provided and other +#' variables are 0 because it is positive defined (SPI indicator). +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. If it is FALSE and there are NA values, +#' (if standardization is TRUE) all values of other dimensions except time_dim +#' and leadtime_dim will be set to NA directly. On the other hand, if it is +#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is +#' not reaching 4 values, it is not enough values to estimate the parameters +#' and the result will include NA. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@return An object of class \code{s2dv_cube} containing the standardized data. +#'If 'data_cor' is provided the standardizaton is applied to it using 'data' +#'to adjust it. +#' +#'@examples +#'dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) +#'data <- NULL +#'data$data <- array(rnorm(600, -204.1, 78.1), dim = dims) +#'class(data) <- 's2dv_cube' +#'SPEI <- CST_PeriodStandardization(data = data, accum = 2) +#'@export +CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', + leadtime_dim = 'time', memb_dim = 'ensemble', + accum = NULL, ref_period = NULL, param_error = -9999, + handle_infinity = FALSE, method = 'parametric', + distribution = 'log-Logistic', + na.rm = FALSE, ncores = NULL) { + # Check 's2dv_cube' + if (is.null(data)) { + stop("Parameter 'exp' cannot be NULL.") + } + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of 's2dv_cube' class.") + } + if (!is.null(data_cor)) { + if (!inherits(data_cor, 's2dv_cube')) { + stop("Parameter 'data_cor' must be of 's2dv_cube' class.") + } + } + std <- PeriodStandardization(data = data$data, data_cor = data_cor$data, + time_dim = time_dim, leadtime_dim = leadtime_dim, + memb_dim = memb_dim, accum = accum, + ref_period = ref_period, param_error = param_error, + handle_infinity = handle_infinity, method = method, + distribution = distribution, + na.rm = na.rm, ncores = ncores) + if (is.null(data_cor)) { + data$data <- std + data$attrs$Variable$varName <- paste0(data$attrs$Variable$varName, ' standardized') + return(data) + } else { + data_cor$data <- std + data_cor$attrs$Variable$varName <- paste0(data_cor$attrs$Variable$varName, ' standardized') + data_cor$attrs$Datasets <- c(data_cor$attrs$Datasets, data$attrs$Datasets) + data_cor$attrs$source_files <- c(data_cor$attrs$source_files, data$attrs$source_files) + return(data_cor) + } +} -PeriodStandardization <- function(data, data_cor = NULL, accum = NULL, time_dim = 'syear', +#'Compute the Standardization of Precipitation-Evapotranspiration Index +#' +#'@param data A multidimensional array containing the data to be standardized. +#'@param data_cor A multidimensional array containing the data in which the +#' standardization should be applied using the fitting parameters from 'data'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param memb_dim A character string indicating the name of the dimension in +#' which the ensemble members are stored. When set it to NULL, threshold is +#' computed for individual members. +#'@param accum An integer value indicating the number of months for the +#' accumulation for each variable. When it is greater than 1, the result will +#' be filled with NA until the accum time_dim dimension number due to the +#' accumulation to previous months. +#'@param ref_period A list with two numeric values with the starting and end +#' points of the reference period used for computing the index. The default +#' value is NULL indicating that the first and end values in data will be +#' used as starting and end points. +#'@param param_error A numeric value with the error accepted. +#'@param handle_infinity A logical value wether to return Infinite values (TRUE) +#' or not (FALSE). +#'@param method A character string indicating the standardization method used. +#' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +#' default. +#'@param distribution A character string indicating the name of the distribution +#' function to be used for computing the SPEI. The accepted names are: +#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +#' 'Gamma' method only works when only precipitation is provided and other +#' variables are 0 because it is positive defined (SPI indicator). +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. If it is FALSE and there are NA values, +#' (if standardization is TRUE) all values of other dimensions except time_dim +#' and leadtime_dim will be set to NA directly. On the other hand, if it is +#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is +#' not reaching 4 values, it is not enough values to estimate the parameters +#' and the result will include NA. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@return A multidimensional array containing the standardized data. +#'If 'data_cor' is provided the standardizaton is applied to it using 'data' +#'to adjust it. +#' +#'@examples +#'dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) +#'dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) +#'data <- array(rnorm(600, -194.5, 64.8), dim = dims) +#'datacor <- array(rnorm(100, -217.8, 68.29), dim = dimscor) +#' +#'SPEI <- PeriodStandardization(data = data, accum = 2) +#'SPEIcor <- PeriodStandardization(data = data, data_cor = datacor, accum = 2) +#'@import multiApply +#'@import ClimProjDiags +#'@import TLMoments +#'@import lmomco +#'@import lmom +#'@export +PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', - ref_period = NULL, cross_validation = FALSE, - handle_infinity = FALSE, param_error = -9999, - method = 'parametric', distribution = 'log-Logistic', + accum = NULL, ref_period = NULL, param_error = -9999, + handle_infinity = FALSE, method = 'parametric', + distribution = 'log-Logistic', na.rm = FALSE, ncores = NULL) { - # Initial checks + # Check inputs + ## data + if (!is.array(data)) { + stop("Parameter 'data' must be a numeric array.") + } + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have dimension names.") + } + ## data_cor + if (!is.null(data_cor)) { + if (!is.array(data_cor)) { + stop("Parameter 'data_cor' must be a numeric array.") + } + if (is.null(names(dim(data_cor)))) { + stop("Parameter 'data_cor' must have dimension names.") + } + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + if (!is.null(data_cor)) { + if (!time_dim %in% names(dim(data_cor))) { + stop("Parameter 'time_dim' is not found in 'data_cor' dimension.") + } + } + ## leadtime_dim + if (!is.character(leadtime_dim) | length(leadtime_dim) != 1) { + stop("Parameter 'leadtime_dim' must be a character string.") + } + if (!leadtime_dim %in% names(dim(data))) { + stop("Parameter 'leadtime_dim' is not found in 'data' dimension.") + } + if (!is.null(data_cor)) { + if (!leadtime_dim %in% names(dim(data_cor))) { + stop("Parameter 'leadtime_dim' is not found in 'data_cor' dimension.") + } + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) != 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(data))) { + stop("Parameter 'memb_dim' is not found in 'data' dimension.") + } + if (!is.null(data_cor)) { + if (!memb_dim %in% names(dim(data_cor))) { + stop("Parameter 'memb_dim' is not found in 'data_cor' dimension.") + } + } + ## accum + if (accum > dim(data)[leadtime_dim]) { + stop(paste0("Cannot compute accumulation of ", accum, " months because ", + "loaded data has only ", dim(data)[leadtime_dim], " months.")) + } + ## ref_period + if (!is.null(ref_period)) { + if (length(ref_period) != 2) { + warning("Parameter 'ref_period' must be of length two indicating the ", + "first and end years of the reference period. It will not ", + "be used.") + ref_period <- NULL + } else if (!all(sapply(ref_period, is.numeric))) { + warning("Parameter 'ref_period' must be a numeric vector indicating the ", + "'start' and 'end' years of the reference period. It will not ", + "be used.") + ref_period <- NULL + } else if (ref_period[[1]] > ref_period[[2]]) { + warning("In parameter 'ref_period' 'start' cannot be after 'end'. It ", + "will not be used.") + ref_period <- NULL + } else if (!all(unlist(ref_period) %in% year(dates_exp))) { + warning("Parameter 'ref_period' contain years outside the dates. ", + "It will not be used.") + ref_period <- NULL + } else { + years <- year(ClimProjDiags::Subset(dates_exp, along = leadtime_dim, + indices = 1)) + ref_period[[1]] <- which(ref_period[[1]] == years) + ref_period[[2]] <- which(ref_period[[2]] == years) + } + } + ## handle_infinity + if (!is.logical(handle_infinity)) { + stop("Parameter 'handle_infinity' must be a logical value.") + } + ## method + if (!(method %in% c('parametric', 'non-parametric'))) { + stop("Parameter 'method' must be a character string containing one of ", + "the following methods: 'parametric' or 'non-parametric'.") + } + ## distribution + if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { + stop("Parameter 'distribution' must be a character string containing one ", + "of the following distributions: 'log-Logistic', 'Gamma' or ", + "'PearsonIII'.") + } + ## na.rm + if (!is.logical(na.rm)) { + stop("Parameter 'na.rm' must be logical.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + target_dims <- c(leadtime_dim, time_dim, memb_dim) if (is.null(ref_period)) { - ref.start <- NULL - ref.end <- NULL + ref_start <- NULL + ref_end <- NULL } else { - ref.start <- ref_period[[1]] - ref.end <- ref_period[[2]] + ref_start <- ref_period[[1]] + ref_end <- ref_period[[2]] } - # Standardization if (is.null(data_cor)) { spei <- Apply(data = list(data), target_dims = target_dims, fun = .standardization, leadtime_dim = leadtime_dim, - time_dim = time_dim, memb_dim = memb_dim, ref_period = ref_period, handle_infinity = handle_infinity, - cross_validation = cross_validation, param_error = param_error, + param_error = param_error, method = method, distribution = distribution, na.rm = na.rm, ncores = ncores)$output1 } else { spei <- Apply(data = list(data, data_cor), target_dims = target_dims, fun = .standardization, leadtime_dim = leadtime_dim, - time_dim = time_dim, memb_dim = memb_dim, ref_period = ref_period, handle_infinity = handle_infinity, - cross_validation = cross_validation, param_error = param_error, + param_error = param_error, method = method, distribution = distribution, na.rm = na.rm, ncores = ncores)$output1 } @@ -44,11 +301,11 @@ PeriodStandardization <- function(data, data_cor = NULL, accum = NULL, time_dim # add NA if (!is.null(accum)) { spei <- Apply(data = list(spei), target_dims = leadtime_dim, - output_dims = leadtime_dim, - fun = function(x, accum, leadtime_dim) { - res <- c(rep(NA, accum-1), x) - return(res) - }, accum = accum, leadtime_dim = leadtime_dim)$output1 + output_dims = leadtime_dim, + fun = function(x, accum, leadtime_dim) { + res <- c(rep(NA, accum-1), x) + return(res) + }, accum = accum, leadtime_dim = leadtime_dim)$output1 } if (is.null(data_cor)) { pos <- match(names(dim(data)), names(dim(spei))) @@ -61,18 +318,11 @@ PeriodStandardization <- function(data, data_cor = NULL, accum = NULL, time_dim } .standardization <- function(data, data_cor = NULL, leadtime_dim = 'time', - time_dim = 'syear', memb_dim = 'ensemble', - ref_period = NULL, handle_infinity = FALSE, - cross_validation = FALSE, param_error = -9999, + ref_period = NULL, handle_infinity = FALSE, param_error = -9999, method = 'parametric', distribution = 'log-Logistic', na.rm = FALSE) { - print(summary(data)) # data: [leadtime_dim, time_dim, memb_dim] - - # maximum number of parameters needed - nleadtime <- as.numeric(dim(data)[leadtime_dim]) - ntime <- as.numeric(dim(data)[time_dim]) - nmemb <- as.numeric(dim(data)[memb_dim]) + dims <- dim(data)[-1] fit = 'ub-pwm' coef = switch(distribution, @@ -83,62 +333,48 @@ PeriodStandardization <- function(data, data_cor = NULL, accum = NULL, time_dim if (is.null(data_cor)) { # cross_val = TRUE spei_mod <- data*NA - params_result <- array(data = NA, dim = c(ntime, nleadtime, length(coef))) for (ff in 1:dim(data)[leadtime_dim]) { data2 <- data[ff, , ] - dim(data2) <- c(ntime, nmemb) - if (!is.null(ref.start) && !is.null(ref.end)) { - data.fit <- window(data2, ref.start, ref.end) + dim(data2) <- dims + if (method == 'non-parametric') { + bp <- matrix(0, length(data2), 1) + for (i in 1:length(data2)) { + bp[i,1] = sum(data2[] <= data2[i], na.rm = na.rm); # Writes the rank of the data + } + std_index <- qnorm((bp - 0.44)/(length(data2) + 0.12)) + dim(std_index) <- dims + spei_mod[ff, , ] <- std_index } else { - data.fit <- data2 - } - for (nsd in 1:dim(data)[time_dim]) { - acu <- as.vector(data.fit[-nsd, ]) - acu.sorted <- sort.default(acu, method = "quick") - if (na.rm) { - acu.sorted <- acu.sorted[!is.na(acu.sorted)] + if (!is.null(ref_start) && !is.null(ref_end)) { + data_fit <- window(data2, ref_start, ref_end) + } else { + data_fit <- data2 } - if (!any(is.na(acu.sorted))) { - if (length(acu.sorted) != 0) { - acu_sd <- sd(acu.sorted) + for (nsd in 1:dim(data)[time_dim]) { + acu <- as.vector(data_fit[-nsd, ]) + acu_sorted <- sort.default(acu, method = "quick") + if (na.rm) { + acu_sorted <- acu_sorted[!is.na(acu_sorted)] + } + if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { + acu_sd <- sd(acu_sorted) if (!is.na(acu_sd) & acu_sd != 0) { if (distribution != "log-Logistic") { - pze <- sum(acu == 0) / length(acu) - acu.sorted <- acu.sorted[acu.sorted > 0] + acu_sorted <- acu_sorted[acu_sorted > 0] } - if (length(acu.sorted) >= 4) { - pwm = switch(fit, - "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), - pwm.ub(acu.sorted, nmom = 3) - # TLMoments::PWM(acu.sorted, order = 0:2) - ) - lmom <- pwm2lmom(pwm) - if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { - fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) - f_params = switch(distribution, - "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), - error = function(e){parglo(lmom)$para}), - "Gamma" = tryCatch(lmom::pelgam(fortran_vec), - error = function(e){pargam(lmom)$para}), - "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), - error = function(e){parpe3(lmom)$para})) - if (distribution == 'log-Logistic' && fit == 'max-lik') { - f_params = parglo.maxlik(acu.sorted, f_params)$para - } - params_result[nsd, ff, ] <- f_params - } + if (length(acu_sorted) >= 4) { + f_params <- .std(acu_sorted, fit, distribution) } - if (all(is.na(params_result[nsd, ff, ]))) { + if (all(is.na(f_params))) { cdf_res <- NA } else { - f_params <- params_result[nsd, ff, ] f_params <- f_params[which(!is.na(f_params))] cdf_res = switch(distribution, "log-Logistic" = lmom::cdfglo(data2, f_params), "Gamma" = lmom::cdfgam(data2, f_params), "PearsonIII" = lmom::cdfpe3(data2, f_params)) } - std_index_cv <- array(qnorm(cdf_res), dim = c(ntime, nmemb)) + std_index_cv <- array(qnorm(cdf_res), dim = dims) spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] } } @@ -148,70 +384,86 @@ PeriodStandardization <- function(data, data_cor = NULL, accum = NULL, time_dim } else { # cross_val = FALSE spei_mod <- data_cor*NA - params_result <- array(data = NA, dim = c(1, length(coef))) + dimscor <- dim(data_cor)[-1] for (ff in 1:dim(data)[leadtime_dim]) { data_cor2 <- data_cor[ff, , ] - dim(data_cor2) <- c(1, nmemb) - data2 <- data[ff, , ] - dim(data2) <- c(ntime, nmemb) - if (!is.null(ref.start) && !is.null(ref.end)) { - data.fit <- window(data2, ref.start, ref.end) + dim(data_cor2) <- dimscor + if (method == 'non-parametric') { + bp <- matrix(0, length(data_cor2), 1) + for (i in 1:length(data_cor2)) { + bp[i,1] = sum(data_cor2[] <= data_cor2[i], na.rm = na.rm); # Writes the rank of the data + } + std_index <- qnorm((bp - 0.44)/(length(data_cor2) + 0.12)) + dim(std_index) <- dimscor + spei_mod[ff, , ] <- std_index } else { - data.fit <- data2 - } - acu <- as.vector(data.fit) - acu.sorted <- sort.default(acu, method = "quick") - if (na.rm) { - acu.sorted <- acu.sorted[!is.na(acu.sorted)] - } - if (!any(is.na(acu.sorted))) { - if (length(acu.sorted) != 0) { - acu_sd <- sd(acu.sorted) + data2 <- data[ff, , ] + dim(data2) <- dims + if (!is.null(ref_start) && !is.null(ref_end)) { + data_fit <- window(data2, ref_start, ref_end) + } else { + data_fit <- data2 + } + acu <- as.vector(data_fit) + acu_sorted <- sort.default(acu, method = "quick") + if (na.rm) { + acu_sorted <- acu_sorted[!is.na(acu_sorted)] + } + if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { + acu_sd <- sd(acu_sorted) if (!is.na(acu_sd) & acu_sd != 0) { if (distribution != "log-Logistic") { - pze <- sum(acu == 0) / length(acu) - acu.sorted <- acu.sorted[acu.sorted > 0] + acu_sorted <- acu_sorted[acu_sorted > 0] } - if (length(acu.sorted) >= 4) { - pwm = switch(fit, - "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), - pwm.ub(acu.sorted, nmom = 3) - # TLMoments::PWM(acu.sorted, order = 0:2) - ) - lmom <- pwm2lmom(pwm) - if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { - fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) - f_params = switch(distribution, - "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), - error = function(e){parglo(lmom)$para}), - "Gamma" = tryCatch(lmom::pelgam(fortran_vec), - error = function(e){pargam(lmom)$para}), - "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), - error = function(e){parpe3(lmom)$para})) - if (distribution == 'log-Logistic' && fit == 'max-lik') { - f_params = parglo.maxlik(acu.sorted, f_params)$para - } - params_result[1, ] <- f_params - - } + if (length(acu_sorted) >= 4) { + f_params <- .std(data = acu_sorted, fit = fit, + distribution = distribution) } - if (all(is.na(params_result[1, ]))) { + if (all(is.na(f_params))) { cdf_res <- NA } else { - f_params <- params_result[1, ] - f_params <- f_params[which(!is.na(f_params))] - cdf_res = switch(distribution, - "log-Logistic" = lmom::cdfglo(data_cor2, f_params), - "Gamma" = lmom::cdfgam(data_cor2, f_params), - "PearsonIII" = lmom::cdfpe3(data_cor2, f_params)) + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data_cor2, f_params), + "Gamma" = lmom::cdfgam(data_cor2, f_params), + "PearsonIII" = lmom::cdfpe3(data_cor2, f_params)) } - std_index_cv <- array(qnorm(cdf_res), dim = c(1, nmemb)) + std_index_cv <- array(qnorm(cdf_res), dim = dimscor) spei_mod[ff, , ] <- std_index_cv } } } } } + if (handle_infinity) { + # could also use "param_error" ?; we are giving it the min/max value of the grid point + spei_mod[is.infinite(spei_mod) & spei_mod < 0] <- min(spei_mod[!is.infinite(spei_mod)]) + spei_mod[is.infinite(spei_mod) & spei_mod > 0] <- max(spei_mod[!is.infinite(spei_mod)]) + } return(spei_mod) } +.std <- function(data, fit, distribution) { + pwm = switch(fit, + "pp-pwm" = pwm.pp(data, -0.35, 0, nmom = 3), + pwm.ub(data, nmom = 3) + # TLMoments::PWM(data, order = 0:2) + ) + lmom <- pwm2lmom(pwm) + if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { + fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) + params = switch(distribution, + "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), + error = function(e){parglo(lmom)$para}), + "Gamma" = tryCatch(lmom::pelgam(fortran_vec), + error = function(e){pargam(lmom)$para}), + "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), + error = function(e){parpe3(lmom)$para})) + if (distribution == 'log-Logistic' && fit == 'max-lik') { + params = parglo.maxlik(data, params)$para + } + return(params) + } else { + return(NA) + } +} \ No newline at end of file diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd new file mode 100644 index 0000000..ecb225e --- /dev/null +++ b/man/CST_PeriodPET.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodPET.R +\name{CST_PeriodPET} +\alias{CST_PeriodPET} +\title{Compute the Potential Evapotranspiration} +\usage{ +CST_PeriodPET( + data, + pet_method = "hargreaves", + time_dim = "syear", + leadtime_dim = "time", + lat_dim = "latitude", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A named list with the needed \code{s2dv_cube} objects containing +the seasonal forecast experiment in the data element for each variable. +Specific variables are needed for each method used in computing the +Potential Evapotranspiration. See parameter 'pet_method'. The accepted +variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for +'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' +'tmean' is required. The units for temperature variables +('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for +precipitation ('pr') need to be in mm/month.} + +\item{pet_method}{A character string indicating the method used to compute +the potential evapotranspiration. The accepted methods are: +'hargreaves' and 'hargreaves_modified', that require the data to have +variables tmin and tmax; and 'thornthwaite', that requires variable +'tmean'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{lat_dim}{A character string indicating the name of the latitudinal +dimension. By default it is set by 'latitude'.} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} + +\item{dates}{An array of temporal dimensions containing the Dates of +'data'. It must be of class 'Date' or 'POSIXct'.} + +\item{lat}{A numeric vector containing the latitude values of 'data'.} +} +\description{ +Compute the Potential evapotranspiration (PET) that is the amount of +evaporation and transpiration that would occur if a sufficient water source +were available. Reference evapotranspiration (ETo) is the amount of +evaporation and transpiration from a reference vegetation of grass. They are +usually considered equivalent. This set of functions calculate PET or ETo +according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +} +\examples{ +dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) + +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +end_year <- 2012 +dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), + paste0(2010:end_year, "-09-15"), + paste0(2010:end_year, "-10-16")), "UTC") +dim(dates_exp) <- c(syear = 3, time = 3) + +lat <- c(40) + +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) + +res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) + +} diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd new file mode 100644 index 0000000..6d10acc --- /dev/null +++ b/man/CST_PeriodStandardization.Rd @@ -0,0 +1,91 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodStandardization.R +\name{CST_PeriodStandardization} +\alias{CST_PeriodStandardization} +\title{Compute the Standardization of Precipitation-Evapotranspiration Index} +\usage{ +CST_PeriodStandardization( + data, + data_cor = NULL, + time_dim = "syear", + leadtime_dim = "time", + memb_dim = "ensemble", + accum = NULL, + ref_period = NULL, + param_error = -9999, + handle_infinity = FALSE, + method = "parametric", + distribution = "log-Logistic", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' that element 'data' stores a multidimensional +array containing the data to be standardized.} + +\item{data_cor}{An 's2dv_cube' that element 'data' stores a multidimensional +array containing the data in which the standardization should be applied +using the fitting parameters from 'data'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{memb_dim}{A character string indicating the name of the dimension in +which the ensemble members are stored. When set it to NULL, threshold is +computed for individual members.} + +\item{accum}{An integer value indicating the number of months for the +accumulation for each variable. When it is greater than 1, the result will +be filled with NA until the accum time_dim dimension number due to the +accumulation to previous months.} + +\item{ref_period}{A list with two numeric values with the starting and end +points of the reference period used for computing the index. The default +value is NULL indicating that the first and end values in data will be +used as starting and end points.} + +\item{param_error}{A numeric value with the error accepted.} + +\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) +or not (FALSE).} + +\item{method}{A character string indicating the standardization method used. +If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +default.} + +\item{distribution}{A character string indicating the name of the distribution +function to be used for computing the SPEI. The accepted names are: +'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +'Gamma' method only works when only precipitation is provided and other +variables are 0 because it is positive defined (SPI indicator).} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default. If it is FALSE and there are NA values, +(if standardization is TRUE) all values of other dimensions except time_dim +and leadtime_dim will be set to NA directly. On the other hand, if it is +TRUE, if the data from other dimensions except time_dim and leadtime_dim is +not reaching 4 values, it is not enough values to estimate the parameters +and the result will include NA.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\value{ +An object of class \code{s2dv_cube} containing the standardized data. +If 'data_cor' is provided the standardizaton is applied to it using 'data' +to adjust it. +} +\description{ +Compute the Standardization of Precipitation-Evapotranspiration Index +} +\examples{ +dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) +data <- NULL +data$data <- array(rnorm(600, -204.1, 78.1), dim = dims) +class(data) <- 's2dv_cube' +SPEI <- CST_PeriodStandardization(data = data, accum = 2) +} diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd index 69aad45..0e7aa85 100644 --- a/man/PeriodPET.Rd +++ b/man/PeriodPET.Rd @@ -21,16 +21,16 @@ PeriodPET( the seasonal forecast experiment in the data element for each variable. Specific variables are needed for each method used in computing the Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and -'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. -Variable 'pr' is always needed. The units for temperature variables +variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for +'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' +'tmean' is required. The units for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for precipitation ('pr') need to be in mm/month.} \item{dates}{An array of temporal dimensions containing the Dates of -'exp'. It must be of class 'Date' or 'POSIXct'.} +'data'. It must be of class 'Date' or 'POSIXct'.} -\item{lat}{A numeric vector containing the latitude values of 'exp'.} +\item{lat}{A numeric vector containing the latitude values of 'data'.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd new file mode 100644 index 0000000..663045e --- /dev/null +++ b/man/PeriodStandardization.Rd @@ -0,0 +1,91 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodStandardization.R +\name{PeriodStandardization} +\alias{PeriodStandardization} +\title{Compute the Standardization of Precipitation-Evapotranspiration Index} +\usage{ +PeriodStandardization( + data, + data_cor = NULL, + time_dim = "syear", + leadtime_dim = "time", + memb_dim = "ensemble", + accum = NULL, + ref_period = NULL, + param_error = -9999, + handle_infinity = FALSE, + method = "parametric", + distribution = "log-Logistic", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array containing the data to be standardized.} + +\item{data_cor}{A multidimensional array containing the data in which the +standardization should be applied using the fitting parameters from 'data'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{memb_dim}{A character string indicating the name of the dimension in +which the ensemble members are stored. When set it to NULL, threshold is +computed for individual members.} + +\item{accum}{An integer value indicating the number of months for the +accumulation for each variable. When it is greater than 1, the result will +be filled with NA until the accum time_dim dimension number due to the +accumulation to previous months.} + +\item{ref_period}{A list with two numeric values with the starting and end +points of the reference period used for computing the index. The default +value is NULL indicating that the first and end values in data will be +used as starting and end points.} + +\item{param_error}{A numeric value with the error accepted.} + +\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) +or not (FALSE).} + +\item{method}{A character string indicating the standardization method used. +If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +default.} + +\item{distribution}{A character string indicating the name of the distribution +function to be used for computing the SPEI. The accepted names are: +'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +'Gamma' method only works when only precipitation is provided and other +variables are 0 because it is positive defined (SPI indicator).} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default. If it is FALSE and there are NA values, +(if standardization is TRUE) all values of other dimensions except time_dim +and leadtime_dim will be set to NA directly. On the other hand, if it is +TRUE, if the data from other dimensions except time_dim and leadtime_dim is +not reaching 4 values, it is not enough values to estimate the parameters +and the result will include NA.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\value{ +A multidimensional array containing the standardized data. +If 'data_cor' is provided the standardizaton is applied to it using 'data' +to adjust it. +} +\description{ +Compute the Standardization of Precipitation-Evapotranspiration Index +} +\examples{ +dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) +dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) +data <- array(rnorm(600, -194.5, 64.8), dim = dims) +datacor <- array(rnorm(100, -217.8, 68.29), dim = dimscor) + +SPEI <- PeriodStandardization(data = data, accum = 2) +SPEIcor <- PeriodStandardization(data = data, data_cor = datacor, accum = 2) +} -- GitLab From a1a0e733a3ea8a8a4bace93ccc73d7d990c2a8fa Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 6 Sep 2023 17:08:06 +0200 Subject: [PATCH 52/87] Correct description of the blending strategy in the documentation --- R/MergeRefToExp.R | 10 ++++++---- man/CST_MergeRefToExp.Rd | 9 +++++---- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 898f32e..e47c988 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -10,10 +10,12 @@ #'(or other references) could be added at the end of the forecast lead time to #'cover the desired period (e.g.: until the end of summer). #' -#'This function is created to merge observations and forecasts in the -#'bioclimatic indicator structure, known as the ‘blending’ strategy (see -#'references). This key strategy aims to increase users’ confidence in the -#'reformed predictions. +#'This function is created to merge observations and forecasts, known as the +#'‘blending’ strategy (see references). The basis for this strategy is that the +#'predictions are progressively replaced with observational data as soon as they +#'become available (i.e., when entering the indicator definition period). This +#'key strategy aims to increase users’ confidence in the reformed predictions. + #' #'@param data1 An 's2dv_cube' object with the element 'data' being a #' multidimensional array with named dimensions. All dimensions must be diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index 5ab328b..a49c9dc 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -87,10 +87,11 @@ period because it is initialized too early (e.g.: Initialization on November cover the desired period (e.g.: until the end of summer). } \details{ -This function is created to merge observations and forecasts in the -bioclimatic indicator structure, known as the ‘blending’ strategy (see -references). This key strategy aims to increase users’ confidence in the -reformed predictions. +This function is created to merge observations and forecasts, known as the +‘blending’ strategy (see references). The basis for this strategy is that the +predictions are progressively replaced with observational data as soon as they +become available (i.e., when entering the indicator definition period). This +key strategy aims to increase users’ confidence in the reformed predictions. } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), -- GitLab From ad62916c481398adba43e32a9c8977cf42deb725 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 6 Sep 2023 17:09:25 +0200 Subject: [PATCH 53/87] Correct changes in documentation --- R/MergeRefToExp.R | 10 +++++----- man/MergeRefToExp.Rd | 9 +++++---- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index e47c988..f5d9069 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -15,7 +15,6 @@ #'predictions are progressively replaced with observational data as soon as they #'become available (i.e., when entering the indicator definition period). This #'key strategy aims to increase users’ confidence in the reformed predictions. - #' #'@param data1 An 's2dv_cube' object with the element 'data' being a #' multidimensional array with named dimensions. All dimensions must be @@ -236,10 +235,11 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #'(or other references) could be added at the end of the forecast lead time to #'cover the desired period (e.g.: until the end of summer). #' -#'This function is created to merge observations and forecasts in the -#'bioclimatic indicator structure, known as the ‘blending’ strategy (see -#'references). This key strategy aims to increase users’ confidence in the -#'reformed predictions. +#'This function is created to merge observations and forecasts, known as the +#'‘blending’ strategy (see references). The basis for this strategy is that the +#'predictions are progressively replaced with observational data as soon as they +#'become available (i.e., when entering the indicator definition period). This +#'key strategy aims to increase users’ confidence in the reformed predictions. #' #'@param data1 A multidimensional array with named dimensions. All dimensions #' must be equal to 'data2' dimensions except for the ones specified with diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index 047ad37..33b5d42 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -92,10 +92,11 @@ period because it is initialized too early (e.g.: Initialization on November cover the desired period (e.g.: until the end of summer). } \details{ -This function is created to merge observations and forecasts in the -bioclimatic indicator structure, known as the ‘blending’ strategy (see -references). This key strategy aims to increase users’ confidence in the -reformed predictions. +This function is created to merge observations and forecasts, known as the +‘blending’ strategy (see references). The basis for this strategy is that the +predictions are progressively replaced with observational data as soon as they +become available (i.e., when entering the indicator definition period). This +key strategy aims to increase users’ confidence in the reformed predictions. } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), -- GitLab From 5c8f2d6729dcc286b65a877533c77d41234cef79 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 7 Sep 2023 16:40:34 +0200 Subject: [PATCH 54/87] Improve PeriodStandardization; write documentation of PeriodPET and PeriodStandardization --- R/PeriodPET.R | 35 +-- R/PeriodSPEI.R | 12 +- R/PeriodStandardization.R | 203 ++++++++++++----- man/CST_PeriodPET.Rd | 13 +- man/CST_PeriodStandardization.Rd | 63 +++-- man/PeriodPET.Rd | 10 +- man/PeriodStandardization.Rd | 63 +++-- tests/testthat/test-PeriodPET.R | 87 ++++--- tests/testthat/test-PeriodStandardization.R | 241 ++++++++++++++++++++ 9 files changed, 579 insertions(+), 148 deletions(-) create mode 100644 tests/testthat/test-PeriodStandardization.R diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 8ab1a64..f365d39 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -2,10 +2,14 @@ #' #'Compute the Potential evapotranspiration (PET) that is the amount of #'evaporation and transpiration that would occur if a sufficient water source -#'were available. Reference evapotranspiration (ETo) is the amount of -#'evaporation and transpiration from a reference vegetation of grass. They are -#'usually considered equivalent. This set of functions calculate PET or ETo -#'according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +#'were available. This function calculate PET according to the Thornthwaite, +#'Hargreaves or Hargreaves-modified equations. +#' +#'This function is build to work be compatible with other tools in +#'that work with 's2dv_cube' object class. The input data must be this object +#'class. If you don't work with 's2dv_cube', see PeriodPET. For more information +#'on the SPEI calculation, see functions CST_PeriodStandardization and +#'CST_PeriodAccumulation. #' #'@param data A named list with the needed \code{s2dv_cube} objects containing #' the seasonal forecast experiment in the data element for each variable. @@ -94,12 +98,14 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', Dates <- data[[1]]$attrs$Dates metadata <- data[[1]]$attrs$Variable$metadata metadata_names <- intersect(names(dim(res)), names(metadata)) - res <- CSTools::s2dv_cube(data = res, coords = coords, - varName = paste0('PET'), - metadata = metadata[metadata_names], - Dates = Dates, - source_files = source_files, - when = Sys.time()) + suppressWarnings( + res <- CSTools::s2dv_cube(data = res, coords = coords, + varName = paste0('PET'), + metadata = metadata[metadata_names], + Dates = Dates, + source_files = source_files, + when = Sys.time()) + ) return(res) } @@ -107,10 +113,11 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #' #'Compute the Potential evapotranspiration (PET) that is the amount of #'evaporation and transpiration that would occur if a sufficient water source -#'were available. Reference evapotranspiration (ETo) is the amount of -#'evaporation and transpiration from a reference vegetation of grass. They are -#'usually considered equivalent. This set of functions calculate PET or ETo -#'according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +#'were available. This function calculate PET according to the Thornthwaite, +#'Hargreaves or Hargreaves-modified equations. +#' +#'For more information on the SPEI calculation, see functions +#'PeriodStandardization and PeriodAccumulation. #' #'@param data A named list with the needed \code{s2dv_cube} objects containing #' the seasonal forecast experiment in the data element for each variable. diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 979e79d..c0593b1 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -767,8 +767,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, lat = lat, pet_method = pet_method[k], time_dim = time_dim, leadtime_dim = leadtime_dim, lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) - print("Step (1): PET") - print(summary(pet[[k]])) computed_pet <- TRUE } @@ -781,8 +779,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, fun = function(data, accum) { return(rollapply(data = data, width = accum, FUN = sum)) }, accum = accum, ncores = ncores)$output1 - print("Step (2): Accumulation") - print(summary(accumulated)) # Standardization if (standardization) { @@ -798,6 +794,8 @@ PeriodSPEI <- function(exp, dates_exp, lat, ref_period <- NULL params <- spei$params + print('Params dim:') + print(dim(params)) spei_res <- spei[[1]] } else { spei_res <- accumulated @@ -811,8 +809,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, }, accum = accum, leadtime_dim = leadtime_dim)$output1 pos <- match(names(dim(data[[1]])), names(dim(spei_res))) spei_res <- aperm(spei_res, pos) - print("Step (3): Standardization") - print(summary(spei_res)) } if (standardization) { @@ -919,8 +915,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, for (ff in 1:nleadtime) { data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, indices = ff, drop = 'selected') - + print('Params subset') + print(dim(params)) params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} + print(params_tmp) spei_data <- .std(data = data_subset, coef = coef, ntime = ntime, nmemb = nmemb, method = method, diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 73792ef..9238147 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -1,5 +1,34 @@ - #'Compute the Standardization of Precipitation-Evapotranspiration Index +#' +#'The Standardization of the data is the last step of computing the SPEI +#'(Standarized Precipitation-Evapotranspiration Index). With this function the +#'data is fit to a probability distribution to transform the original values to +#'standardized units that are comparable in space and time and at different SPEI +#'time scales. +#' +#'Next, some specifications for the calculation of this indicator will be +#'discussed. To choose the time scale in which you want to accumulate the SPEI +#'(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to +#'be performed in the previous step. However, since the accumulation is done for +#'the elapsed time steps, there will be no complete accumulations until reaching +#'the time instant equal to the value of the parameter. For this reason, in the +#'result, we will find that for the dimension where the accumulation has been +#'carried out, the values of the array will be NA since they do not include +#'complete accumulations. If there are NAs in the data and they are not removed with the +#'parameter 'na.rm', the standardization cannot be carried out for those +#'coordinates and therefore, the result will be filled with NA for the +#'specific coordinates. When NAs are not removed, if the length of the data for +#'a computational step is smaller than 4, there will not be enough data for +#'standarize and the result will be also filled with NAs for that coordinates. +#'About the distribution used to fit the data, there are only two possibilities: +#''log-logistic' and 'Gamma'. The 'Gamma' method only works when only +#'precipitation is provided and other variables are 0 because it is positive +#'defined (SPI indicator). For more information about SPEI, see functions +#'PeriodPET and PeriodAccumulation. This function is build to work be compatible +#'with other tools in that work with 's2dv_cube' object class. The input data +#'must be this object class. If you don't work with 's2dv_cube', see +#'PeriodStandardization. For more information on the SPEI indicator calculation, +#'see CST_PeriodPET and CST_PeriodAccumulation. #' #'@param data An 's2dv_cube' that element 'data' stores a multidimensional #' array containing the data to be standardized. @@ -13,17 +42,20 @@ #'@param memb_dim A character string indicating the name of the dimension in #' which the ensemble members are stored. When set it to NULL, threshold is #' computed for individual members. -#'@param accum An integer value indicating the number of months for the -#' accumulation for each variable. When it is greater than 1, the result will -#' be filled with NA until the accum time_dim dimension number due to the -#' accumulation to previous months. +#'@param accum An integer value indicating the number of +#' time steps (leadtime_dim dimension) that have been accumulated in the +#' previous step. When it is greater than 1, the result will be filled with +#' NA until the accum leadtime_dim dimension number due to the +#' accumulation to previous months. If it is 1, no accumulation is done. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be #' used as starting and end points. -#'@param param_error A numeric value with the error accepted. -#'@param handle_infinity A logical value wether to return Infinite values (TRUE) -#' or not (FALSE). +#'@param handle_infinity A logical value wether to return infinite values (TRUE) +#' or not (FALSE). When it is TRUE, the positive infinite values (negative +#' infinite) are substituted by the maximum (minimum) values of each +#' computation step, a subset of the array of dimensions time_dim, leadtime_dim +#' and memb_dim. #'@param method A character string indicating the standardization method used. #' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by #' default. @@ -31,11 +63,11 @@ #' function to be used for computing the SPEI. The accepted names are: #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other -#' variables are 0 because it is positive defined (SPI indicator). +#' variables are 0 because it is positive defined (SPI indicator). #'@param na.rm A logical value indicating whether NA values should be removed #' from data. It is FALSE by default. If it is FALSE and there are NA values, -#' (if standardization is TRUE) all values of other dimensions except time_dim -#' and leadtime_dim will be set to NA directly. On the other hand, if it is +#' standardization cannot be carried out for those coordinates and therefore, +#' the result will be filled with NA for the specific coordinates. If it is #' TRUE, if the data from other dimensions except time_dim and leadtime_dim is #' not reaching 4 values, it is not enough values to estimate the parameters #' and the result will include NA. @@ -43,8 +75,9 @@ #' parallel computation. #' #'@return An object of class \code{s2dv_cube} containing the standardized data. -#'If 'data_cor' is provided the standardizaton is applied to it using 'data' -#'to adjust it. +#'If 'data_cor' is provided the array stored in element data will be of the same +#'dimensions as 'data_cor'. If 'data_cor' is not provided, the array stored in +#'element data will be of the same dimensions as 'data'. #' #'@examples #'dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) @@ -55,13 +88,14 @@ #'@export CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', - accum = NULL, ref_period = NULL, param_error = -9999, - handle_infinity = FALSE, method = 'parametric', + accum = 1, ref_period = NULL, + handle_infinity = FALSE, + method = 'parametric', distribution = 'log-Logistic', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (is.null(data)) { - stop("Parameter 'exp' cannot be NULL.") + stop("Parameter 'data' cannot be NULL.") } if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of 's2dv_cube' class.") @@ -74,7 +108,7 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', std <- PeriodStandardization(data = data$data, data_cor = data_cor$data, time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, accum = accum, - ref_period = ref_period, param_error = param_error, + ref_period = ref_period, handle_infinity = handle_infinity, method = method, distribution = distribution, na.rm = na.rm, ncores = ncores) @@ -92,10 +126,38 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', } #'Compute the Standardization of Precipitation-Evapotranspiration Index +#' +#'The Standardization of the data is the last step of computing the SPEI +#'indicator. With this function the data is fit to a probability distribution to +#'transform the original values to standardized units that are comparable in +#'space and time and at different SPEI time scales. +#' +#'Next, some specifications for the calculation of this indicator will be +#'discussed. To choose the time scale in which you want to accumulate the SPEI +#'(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to +#'be performed in the previous step. However, since the accumulation is done for +#'the elapsed time steps, there will be no complete accumulations until reaching +#'the time instant equal to the value of the parameter. For this reason, in the +#'result, we will find that for the dimension where the accumulation has been +#'carried out, the values of the array will be NA since they do not include +#'complete accumulations. If there are NAs in the data and they are not removed with the +#'parameter 'na.rm', the standardization cannot be carried out for those +#'coordinates and therefore, the result will be filled with NA for the +#'specific coordinates. When NAs are not removed, if the length of the data for +#'a computational step is smaller than 4, there will not be enough data for +#'standarize and the result will be also filled with NAs for that coordinates. +#'About the distribution used to fit the data, there are only two possibilities: +#''log-logistic' and 'Gamma'. The 'Gamma' method only works when only +#'precipitation is provided and other variables are 0 because it is positive +#'defined (SPI indicator). For more information about SPEI, see functions +#'PeriodPET and PeriodAccumulation. #' #'@param data A multidimensional array containing the data to be standardized. #'@param data_cor A multidimensional array containing the data in which the #' standardization should be applied using the fitting parameters from 'data'. +#'@param dates An array containing the dates of the data with the same time +#' dimensions as the data. It is optional and only necessary for using the +#' parameter 'ref_period' to select a reference period directly from dates. #'@param time_dim A character string indicating the name of the temporal #' dimension. By default, it is set to 'syear'. #'@param leadtime_dim A character string indicating the name of the temporal @@ -103,17 +165,20 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@param memb_dim A character string indicating the name of the dimension in #' which the ensemble members are stored. When set it to NULL, threshold is #' computed for individual members. -#'@param accum An integer value indicating the number of months for the -#' accumulation for each variable. When it is greater than 1, the result will -#' be filled with NA until the accum time_dim dimension number due to the -#' accumulation to previous months. +#'@param accum An integer value indicating the number of +#' time steps (leadtime_dim dimension) that have been accumulated in the +#' previous step. When it is greater than 1, the result will be filled with +#' NA until the accum leadtime_dim dimension number due to the +#' accumulation to previous months. If it is 1, no accumulation is done. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be #' used as starting and end points. -#'@param param_error A numeric value with the error accepted. -#'@param handle_infinity A logical value wether to return Infinite values (TRUE) -#' or not (FALSE). +#'@param handle_infinity A logical value wether to return infinite values (TRUE) +#' or not (FALSE). When it is TRUE, the positive infinite values (negative +#' infinite) are substituted by the maximum (minimum) values of each +#' computation step, a subset of the array of dimensions time_dim, leadtime_dim +#' and memb_dim. #'@param method A character string indicating the standardization method used. #' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by #' default. @@ -121,11 +186,11 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #' function to be used for computing the SPEI. The accepted names are: #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other -#' variables are 0 because it is positive defined (SPI indicator). +#' variables are 0 because it is positive defined (SPI indicator). #'@param na.rm A logical value indicating whether NA values should be removed #' from data. It is FALSE by default. If it is FALSE and there are NA values, -#' (if standardization is TRUE) all values of other dimensions except time_dim -#' and leadtime_dim will be set to NA directly. On the other hand, if it is +#' standardization cannot be carried out for those coordinates and therefore, +#' the result will be filled with NA for the specific coordinates. If it is #' TRUE, if the data from other dimensions except time_dim and leadtime_dim is #' not reaching 4 values, it is not enough values to estimate the parameters #' and the result will include NA. @@ -133,8 +198,9 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #' parallel computation. #' #'@return A multidimensional array containing the standardized data. -#'If 'data_cor' is provided the standardizaton is applied to it using 'data' -#'to adjust it. +#'If 'data_cor' is provided the array will be of the same dimensions as +#''data_cor'. If 'data_cor' is not provided, the array will be of the same +#'dimensions as 'data'. #' #'@examples #'dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) @@ -150,10 +216,11 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@import lmomco #'@import lmom #'@export -PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', - leadtime_dim = 'time', memb_dim = 'ensemble', - accum = NULL, ref_period = NULL, param_error = -9999, - handle_infinity = FALSE, method = 'parametric', +PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', accum = 1, + ref_period = NULL, handle_infinity = FALSE, + method = 'parametric', distribution = 'log-Logistic', na.rm = FALSE, ncores = NULL) { # Check inputs @@ -173,6 +240,21 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', stop("Parameter 'data_cor' must have dimension names.") } } + ## dates + if (!is.null(dates)) { + if (!(is.Date(dates)) & !(is.POSIXct(dates))) { + stop("Parameter 'dates' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!time_dim %in% names(dim(dates)) | !leadtime_dim %in% names(dim(dates))) { + stop("Parameter 'dates' must have 'time_dim' and 'leadtime_dim' ", + "dimension.") + } + if (dim(data)[c(time_dim)] != dim(dates)[c(time_dim)]) { + stop("Parameter 'dates' needs to have the same length of 'time_dim' ", + "as 'data'.") + } + } ## time_dim if (!is.character(time_dim) | length(time_dim) != 1) { stop("Parameter 'time_dim' must be a character string.") @@ -209,6 +291,13 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', stop("Parameter 'memb_dim' is not found in 'data_cor' dimension.") } } + ## data_cor (2) + if (!is.null(data_cor)) { + if (dim(data)[leadtime_dim] != dim(data_cor)[leadtime_dim]) { + stop("Parameter 'data' and 'data_cor' have dimension 'leadtime_dim' ", + "of different length.") + } + } ## accum if (accum > dim(data)[leadtime_dim]) { stop(paste0("Cannot compute accumulation of ", accum, " months because ", @@ -216,7 +305,11 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', } ## ref_period if (!is.null(ref_period)) { - if (length(ref_period) != 2) { + if (is.null(dates)) { + warning("Parameter 'dates' is not provided so 'ref_period' can't be ", + "used.") + ref_period <- NULL + } else if (length(ref_period) != 2) { warning("Parameter 'ref_period' must be of length two indicating the ", "first and end years of the reference period. It will not ", "be used.") @@ -230,12 +323,12 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', warning("In parameter 'ref_period' 'start' cannot be after 'end'. It ", "will not be used.") ref_period <- NULL - } else if (!all(unlist(ref_period) %in% year(dates_exp))) { + } else if (!all(unlist(ref_period) %in% year(dates))) { warning("Parameter 'ref_period' contain years outside the dates. ", "It will not be used.") ref_period <- NULL } else { - years <- year(ClimProjDiags::Subset(dates_exp, along = leadtime_dim, + years <- year(ClimProjDiags::Subset(dates, along = leadtime_dim, indices = 1)) ref_period[[1]] <- which(ref_period[[1]] == years) ref_period[[2]] <- which(ref_period[[2]] == years) @@ -285,7 +378,6 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', fun = .standardization, leadtime_dim = leadtime_dim, ref_period = ref_period, handle_infinity = handle_infinity, - param_error = param_error, method = method, distribution = distribution, na.rm = na.rm, ncores = ncores)$output1 } else { @@ -293,7 +385,6 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', fun = .standardization, leadtime_dim = leadtime_dim, ref_period = ref_period, handle_infinity = handle_infinity, - param_error = param_error, method = method, distribution = distribution, na.rm = na.rm, ncores = ncores)$output1 } @@ -305,7 +396,8 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', fun = function(x, accum, leadtime_dim) { res <- c(rep(NA, accum-1), x) return(res) - }, accum = accum, leadtime_dim = leadtime_dim)$output1 + }, accum = accum, leadtime_dim = leadtime_dim, + ncores = ncores)$output1 } if (is.null(data_cor)) { pos <- match(names(dim(data)), names(dim(spei))) @@ -318,7 +410,7 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', } .standardization <- function(data, data_cor = NULL, leadtime_dim = 'time', - ref_period = NULL, handle_infinity = FALSE, param_error = -9999, + ref_period = NULL, handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', na.rm = FALSE) { # data: [leadtime_dim, time_dim, memb_dim] @@ -352,9 +444,10 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', } for (nsd in 1:dim(data)[time_dim]) { acu <- as.vector(data_fit[-nsd, ]) - acu_sorted <- sort.default(acu, method = "quick") if (na.rm) { - acu_sorted <- acu_sorted[!is.na(acu_sorted)] + acu_sorted <- sort.default(acu, method = "quick") + } else { + acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) } if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { acu_sd <- sd(acu_sorted) @@ -363,16 +456,19 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', acu_sorted <- acu_sorted[acu_sorted > 0] } if (length(acu_sorted) >= 4) { - f_params <- .std(acu_sorted, fit, distribution) + f_params <- .std(data = acu_sorted, fit = fit, + distribution = distribution) + } else { + f_params <- NA } if (all(is.na(f_params))) { cdf_res <- NA } else { f_params <- f_params[which(!is.na(f_params))] cdf_res = switch(distribution, - "log-Logistic" = lmom::cdfglo(data2, f_params), - "Gamma" = lmom::cdfgam(data2, f_params), - "PearsonIII" = lmom::cdfpe3(data2, f_params)) + "log-Logistic" = lmom::cdfglo(data2, f_params), + "Gamma" = lmom::cdfgam(data2, f_params), + "PearsonIII" = lmom::cdfpe3(data2, f_params)) } std_index_cv <- array(qnorm(cdf_res), dim = dims) spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] @@ -405,9 +501,10 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', data_fit <- data2 } acu <- as.vector(data_fit) - acu_sorted <- sort.default(acu, method = "quick") if (na.rm) { - acu_sorted <- acu_sorted[!is.na(acu_sorted)] + acu_sorted <- sort.default(acu, method = "quick") + } else { + acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) } if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { acu_sd <- sd(acu_sorted) @@ -443,9 +540,9 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', return(spei_mod) } -.std <- function(data, fit, distribution) { +.std <- function(data, fit = 'pp-pwm', distribution = 'log-Logistic') { pwm = switch(fit, - "pp-pwm" = pwm.pp(data, -0.35, 0, nmom = 3), + 'pp-pwm' = pwm.pp(data, -0.35, 0, nmom = 3), pwm.ub(data, nmom = 3) # TLMoments::PWM(data, order = 0:2) ) @@ -453,11 +550,11 @@ PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) params = switch(distribution, - "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), + 'log-Logistic' = tryCatch(lmom::pelglo(fortran_vec), error = function(e){parglo(lmom)$para}), - "Gamma" = tryCatch(lmom::pelgam(fortran_vec), + 'Gamma' = tryCatch(lmom::pelgam(fortran_vec), error = function(e){pargam(lmom)$para}), - "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), + 'PearsonIII' = tryCatch(lmom::pelpe3(fortran_vec), error = function(e){parpe3(lmom)$para})) if (distribution == 'log-Logistic' && fit == 'max-lik') { params = parglo.maxlik(data, params)$para diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd index ecb225e..10383af 100644 --- a/man/CST_PeriodPET.Rd +++ b/man/CST_PeriodPET.Rd @@ -54,10 +54,15 @@ parallel computation.} \description{ Compute the Potential evapotranspiration (PET) that is the amount of evaporation and transpiration that would occur if a sufficient water source -were available. Reference evapotranspiration (ETo) is the amount of -evaporation and transpiration from a reference vegetation of grass. They are -usually considered equivalent. This set of functions calculate PET or ETo -according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +were available. This function calculate PET according to the Thornthwaite, +Hargreaves or Hargreaves-modified equations. +} +\details{ +This function is build to work be compatible with other tools in +that work with 's2dv_cube' object class. The input data must be this object +class. If you don't work with 's2dv_cube', see PeriodPET. For more information +on the SPEI calculation, see functions CST_PeriodStandardization and +CST_PeriodAccumulation. } \examples{ dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd index 6d10acc..290cb3b 100644 --- a/man/CST_PeriodStandardization.Rd +++ b/man/CST_PeriodStandardization.Rd @@ -10,9 +10,8 @@ CST_PeriodStandardization( time_dim = "syear", leadtime_dim = "time", memb_dim = "ensemble", - accum = NULL, + accum = 1, ref_period = NULL, - param_error = -9999, handle_infinity = FALSE, method = "parametric", distribution = "log-Logistic", @@ -38,20 +37,22 @@ dimension. By default, it is set to 'time'.} which the ensemble members are stored. When set it to NULL, threshold is computed for individual members.} -\item{accum}{An integer value indicating the number of months for the -accumulation for each variable. When it is greater than 1, the result will -be filled with NA until the accum time_dim dimension number due to the -accumulation to previous months.} +\item{accum}{An integer value indicating the number of +time steps (leadtime_dim dimension) that have been accumulated in the +previous step. When it is greater than 1, the result will be filled with +NA until the accum leadtime_dim dimension number due to the +accumulation to previous months. If it is 1, no accumulation is done.} \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default value is NULL indicating that the first and end values in data will be used as starting and end points.} -\item{param_error}{A numeric value with the error accepted.} - -\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) -or not (FALSE).} +\item{handle_infinity}{A logical value wether to return infinite values (TRUE) +or not (FALSE). When it is TRUE, the positive infinite values (negative +infinite) are substituted by the maximum (minimum) values of each +computation step, a subset of the array of dimensions time_dim, leadtime_dim +and memb_dim.} \item{method}{A character string indicating the standardization method used. If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by @@ -61,12 +62,12 @@ default.} function to be used for computing the SPEI. The accepted names are: 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The 'Gamma' method only works when only precipitation is provided and other -variables are 0 because it is positive defined (SPI indicator).} + variables are 0 because it is positive defined (SPI indicator).} \item{na.rm}{A logical value indicating whether NA values should be removed from data. It is FALSE by default. If it is FALSE and there are NA values, -(if standardization is TRUE) all values of other dimensions except time_dim -and leadtime_dim will be set to NA directly. On the other hand, if it is +standardization cannot be carried out for those coordinates and therefore, +the result will be filled with NA for the specific coordinates. If it is TRUE, if the data from other dimensions except time_dim and leadtime_dim is not reaching 4 values, it is not enough values to estimate the parameters and the result will include NA.} @@ -76,11 +77,41 @@ parallel computation.} } \value{ An object of class \code{s2dv_cube} containing the standardized data. -If 'data_cor' is provided the standardizaton is applied to it using 'data' -to adjust it. +If 'data_cor' is provided the array stored in element data will be of the same +dimensions as 'data_cor'. If 'data_cor' is not provided, the array stored in +element data will be of the same dimensions as 'data'. } \description{ -Compute the Standardization of Precipitation-Evapotranspiration Index +The Standardization of the data is the last step of computing the SPEI +(Standarized Precipitation-Evapotranspiration Index). With this function the +data is fit to a probability distribution to transform the original values to +standardized units that are comparable in space and time and at different SPEI +time scales. +} +\details{ +Next, some specifications for the calculation of this indicator will be +discussed. To choose the time scale in which you want to accumulate the SPEI +(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to +be performed in the previous step. However, since the accumulation is done for +the elapsed time steps, there will be no complete accumulations until reaching +the time instant equal to the value of the parameter. For this reason, in the +result, we will find that for the dimension where the accumulation has been +carried out, the values of the array will be NA since they do not include +complete accumulations. If there are NAs in the data and they are not removed with the +parameter 'na.rm', the standardization cannot be carried out for those +coordinates and therefore, the result will be filled with NA for the +specific coordinates. When NAs are not removed, if the length of the data for +a computational step is smaller than 4, there will not be enough data for +standarize and the result will be also filled with NAs for that coordinates. +About the distribution used to fit the data, there are only two possibilities: +'log-logistic' and 'Gamma'. The 'Gamma' method only works when only +precipitation is provided and other variables are 0 because it is positive +defined (SPI indicator). For more information about SPEI, see functions +PeriodPET and PeriodAccumulation. This function is build to work be compatible +with other tools in that work with 's2dv_cube' object class. The input data +must be this object class. If you don't work with 's2dv_cube', see +PeriodStandardization. For more information on the SPEI indicator calculation, +see CST_PeriodPET and CST_PeriodAccumulation. } \examples{ dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd index 0e7aa85..7ca1073 100644 --- a/man/PeriodPET.Rd +++ b/man/PeriodPET.Rd @@ -56,10 +56,12 @@ parallel computation.} \description{ Compute the Potential evapotranspiration (PET) that is the amount of evaporation and transpiration that would occur if a sufficient water source -were available. Reference evapotranspiration (ETo) is the amount of -evaporation and transpiration from a reference vegetation of grass. They are -usually considered equivalent. This set of functions calculate PET or ETo -according to the Thornthwaite, Hargreaves or Penman-Monteith equations. +were available. This function calculate PET according to the Thornthwaite, +Hargreaves or Hargreaves-modified equations. +} +\details{ +For more information on the SPEI calculation, see functions +PeriodStandardization and PeriodAccumulation. } \examples{ dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd index 663045e..6bc9320 100644 --- a/man/PeriodStandardization.Rd +++ b/man/PeriodStandardization.Rd @@ -7,12 +7,12 @@ PeriodStandardization( data, data_cor = NULL, + dates = NULL, time_dim = "syear", leadtime_dim = "time", memb_dim = "ensemble", - accum = NULL, + accum = 1, ref_period = NULL, - param_error = -9999, handle_infinity = FALSE, method = "parametric", distribution = "log-Logistic", @@ -26,6 +26,10 @@ PeriodStandardization( \item{data_cor}{A multidimensional array containing the data in which the standardization should be applied using the fitting parameters from 'data'.} +\item{dates}{An array containing the dates of the data with the same time +dimensions as the data. It is optional and only necessary for using the +parameter 'ref_period' to select a reference period directly from dates.} + \item{time_dim}{A character string indicating the name of the temporal dimension. By default, it is set to 'syear'.} @@ -36,20 +40,22 @@ dimension. By default, it is set to 'time'.} which the ensemble members are stored. When set it to NULL, threshold is computed for individual members.} -\item{accum}{An integer value indicating the number of months for the -accumulation for each variable. When it is greater than 1, the result will -be filled with NA until the accum time_dim dimension number due to the -accumulation to previous months.} +\item{accum}{An integer value indicating the number of +time steps (leadtime_dim dimension) that have been accumulated in the +previous step. When it is greater than 1, the result will be filled with +NA until the accum leadtime_dim dimension number due to the +accumulation to previous months. If it is 1, no accumulation is done.} \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default value is NULL indicating that the first and end values in data will be used as starting and end points.} -\item{param_error}{A numeric value with the error accepted.} - -\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) -or not (FALSE).} +\item{handle_infinity}{A logical value wether to return infinite values (TRUE) +or not (FALSE). When it is TRUE, the positive infinite values (negative +infinite) are substituted by the maximum (minimum) values of each +computation step, a subset of the array of dimensions time_dim, leadtime_dim +and memb_dim.} \item{method}{A character string indicating the standardization method used. If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by @@ -59,12 +65,12 @@ default.} function to be used for computing the SPEI. The accepted names are: 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The 'Gamma' method only works when only precipitation is provided and other -variables are 0 because it is positive defined (SPI indicator).} + variables are 0 because it is positive defined (SPI indicator).} \item{na.rm}{A logical value indicating whether NA values should be removed from data. It is FALSE by default. If it is FALSE and there are NA values, -(if standardization is TRUE) all values of other dimensions except time_dim -and leadtime_dim will be set to NA directly. On the other hand, if it is +standardization cannot be carried out for those coordinates and therefore, +the result will be filled with NA for the specific coordinates. If it is TRUE, if the data from other dimensions except time_dim and leadtime_dim is not reaching 4 values, it is not enough values to estimate the parameters and the result will include NA.} @@ -74,11 +80,36 @@ parallel computation.} } \value{ A multidimensional array containing the standardized data. -If 'data_cor' is provided the standardizaton is applied to it using 'data' -to adjust it. +If 'data_cor' is provided the array will be of the same dimensions as +'data_cor'. If 'data_cor' is not provided, the array will be of the same +dimensions as 'data'. } \description{ -Compute the Standardization of Precipitation-Evapotranspiration Index +The Standardization of the data is the last step of computing the SPEI +indicator. With this function the data is fit to a probability distribution to +transform the original values to standardized units that are comparable in +space and time and at different SPEI time scales. +} +\details{ +Next, some specifications for the calculation of this indicator will be +discussed. To choose the time scale in which you want to accumulate the SPEI +(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to +be performed in the previous step. However, since the accumulation is done for +the elapsed time steps, there will be no complete accumulations until reaching +the time instant equal to the value of the parameter. For this reason, in the +result, we will find that for the dimension where the accumulation has been +carried out, the values of the array will be NA since they do not include +complete accumulations. If there are NAs in the data and they are not removed with the +parameter 'na.rm', the standardization cannot be carried out for those +coordinates and therefore, the result will be filled with NA for the +specific coordinates. When NAs are not removed, if the length of the data for +a computational step is smaller than 4, there will not be enough data for +standarize and the result will be also filled with NAs for that coordinates. +About the distribution used to fit the data, there are only two possibilities: +'log-logistic' and 'Gamma'. The 'Gamma' method only works when only +precipitation is provided and other variables are 0 because it is positive +defined (SPI indicator). For more information about SPEI, see functions +PeriodPET and PeriodAccumulation. } \examples{ dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) diff --git a/tests/testthat/test-PeriodPET.R b/tests/testthat/test-PeriodPET.R index 0b7cf57..632d1c4 100644 --- a/tests/testthat/test-PeriodPET.R +++ b/tests/testthat/test-PeriodPET.R @@ -1,5 +1,16 @@ ############################################## +# cube1 +cube1 <- NULL +cube1$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube1) <- 's2dv_cube' + +# cube2 +cube2 <- NULL +cube2$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube2) <- 's2dv_cube' +cube2$coords <- list(lat = 1:2) + # dat1 dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) @@ -12,11 +23,11 @@ exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16"))) -dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) +dim(dates_exp) <- c(syear = 6, time = 3) lat <- c(40,40.1) -exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) # dat2 dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) @@ -32,44 +43,46 @@ dim(dates_exp2) <- c(sday = 1, sweek = 1, styear = 6, ftime = 3) lat <- c(40,40.1) -exp2 <- list('tas' = exp_tas, 'prlr' = exp_prlr) +exp2 <- list('tmean' = exp_tas, 'pr' = exp_prlr) + +# cube4 +cube4_exp <- lapply(exp1, function(x) { + suppressWarnings( + CSTools::s2dv_cube(data = x, coords = list(latitude = c(40, 40.1)), + varName = 'test', Dates = as.POSIXct(dates_exp)) + ) +}) ############################################## -# test_that("1. Initial checks CST_PeriodSPEI", { -# # Check 's2dv_cube' -# expect_error( -# CST_PeriodSPEI(exp = NULL), -# "Parameter 'exp' cannot be NULL." -# ) -# expect_error( -# CST_PeriodSPEI(exp = array(10)), -# "Parameter 'exp' must be a list of 's2dv_cube' class." -# ) -# # latitude -# expect_error( -# CST_PeriodSPEI(exp = list(cube1)), -# paste0("Spatial coordinate names of parameter 'exp' do not match any ", -# "of the names accepted by the package.") -# ) -# # Dates -# expect_error( -# CST_PeriodSPEI(exp = list(cube2)), -# paste0("Element 'Dates' is not found in 'attrs' list of 'exp'. ", -# "See 's2dv_cube' object description in README file for more ", -# "information.") -# ) -# expect_error( -# CST_PeriodSPEI(exp = list(cube3), exp_cor = list(cube2)), -# paste0("Element 'Dates' is not found in 'attrs' list of 'exp_cor'. ", -# "See 's2dv_cube' object description in README file for more ", -# "information.") -# ) -# }) +test_that("1. Initial checks CST_PeriodPET", { + # Check 's2dv_cube' + expect_error( + CST_PeriodPET(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + CST_PeriodPET(data = array(10)), + "Parameter 'data' must be a list of 's2dv_cube' class." + ) + # latitude + expect_error( + CST_PeriodPET(data = list(cube1)), + paste0("Spatial coordinate names of parameter 'data' do not match any ", + "of the names accepted by the package.") + ) + # Dates + expect_error( + CST_PeriodPET(data = list(cube2)), + paste0("Element 'Dates' is not found in 'attrs' list of 'data'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") + ) +}) ############################################## -test_that("1. Initial checks PeriodSPEI", { +test_that("1. Initial checks PeriodPET", { # data expect_error( PeriodPET(data = NULL), @@ -152,11 +165,17 @@ test_that("1. Initial checks PeriodSPEI", { ############################################## test_that("2. Output checks", { + res01 <- CST_PeriodPET(data = cube4_exp) res1 <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) res2 <- PeriodPET(data = exp2, lat = lat, dates = dates_exp2, pet_method = c('thornthwaite'), lat_dim = 'lat', time_dim = 'styear', leadtime_dim = 'ftime') + # structure + expect_equal( + names(res01), + c('data', 'dims', 'coords', 'attrs') + ) # dims expect_equal( dim(res1), diff --git a/tests/testthat/test-PeriodStandardization.R b/tests/testthat/test-PeriodStandardization.R new file mode 100644 index 0000000..e94d347 --- /dev/null +++ b/tests/testthat/test-PeriodStandardization.R @@ -0,0 +1,241 @@ +############################################## + +# cube1 +dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) +cube1 <- NULL +cube1$data <- array(rnorm(600, -204.1, 78.1), dim = dims) +class(cube1) <- 's2dv_cube' + +# dat1 +dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) +dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) +dimscor1_1 <- c(syear = 1, time = 3, latitude = 2, ensemble = 25) +set.seed(1) +dat1 <- array(rnorm(600, -194.5, 64.8), dim = dims) +set.seed(2) +datcor1 <- array(rnorm(100, -217.8, 68.29), dim = dimscor) +set.seed(3) +datcor1_1 <- array(rnorm(100, -217.8, 68.29), dim = dimscor1_1) + +# dates1 +dates1 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates1) <- c(syear = 6, time = 3) + +# dat2 +dims2 <- c(styear = 6, ftime = 2, lat = 2, member = 25) +dimscor2_1 <- c(syear = 1, ftime = 2, lat = 2, ensemble = 25) +dimscor2_2 <- c(styear = 1, ftime = 2, lat = 2, ensemble = 25) +set.seed(1) +dat2 <- array(rnorm(600, -194.5, 64.8), dim = dims2) +set.seed(2) +datcor2_1 <- array(rnorm(100, -194.5, 64.8), dim = dimscor2_1) +set.seed(2) +datcor2_2 <- array(rnorm(100, -194.5, 64.8), dim = dimscor2_2) + +# dat3 +dims3 <- c(syear = 6, time = 2, lat = 2, ensemble = 25) +set.seed(1) +dat3 <- array(abs(rnorm(600, 21.19, 25.64)), dim = dims) + + +############################################## + +test_that("1. Initial checks CST_PeriodStandardization", { + # Check 's2dv_cube' + expect_error( + CST_PeriodStandardization(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + CST_PeriodStandardization(data = array(10)), + "Parameter 'data' must be of 's2dv_cube' class." + ) +}) + +############################################## + +test_that("1. Initial checks PeriodStandardization", { + # data + expect_error( + PeriodStandardization(data = NULL), + "Parameter 'data' must be a numeric array." + ) + expect_error( + PeriodStandardization(data = array(1)), + "Parameter 'data' must have dimension names." + ) + # data_cor + expect_error( + PeriodStandardization(data = dat1, data_cor = 1), + "Parameter 'data_cor' must be a numeric array." + ) + expect_error( + PeriodStandardization(data = dat1, data_cor = array(1:2)), + "Parameter 'data_cor' must have dimension names." + ) + # time_dim + expect_error( + PeriodStandardization(data = dat1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodStandardization(data = dat2), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodStandardization(data = dat2, data_cor = dat1, time_dim = 'ftime'), + "Parameter 'time_dim' is not found in 'data_cor' dimension." + ) + # leadtime_dim + expect_error( + PeriodStandardization(data = dat1, leadtime_dim = 1), + "Parameter 'leadtime_dim' must be a character string." + ) + expect_error( + PeriodStandardization(data = dat2, time_dim = 'ftime'), + "Parameter 'leadtime_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodStandardization(data = dat2, data_cor = datcor2_1, time_dim = 'ftime', + leadtime_dim = 'styear'), + "Parameter 'leadtime_dim' is not found in 'data_cor' dimension." + ) + # memb_dim + expect_error( + PeriodStandardization(data = dat1, memb_dim = 1), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + PeriodStandardization(data = dat2, time_dim = 'styear', leadtime_dim = 'ftime'), + "Parameter 'memb_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodStandardization(data = dat2, data_cor = datcor2_2, time_dim = 'styear', + leadtime_dim = 'ftime', memb_dim = 'member'), + "Parameter 'memb_dim' is not found in 'data_cor' dimension." + ) + # data_cor (2) + expect_error( + PeriodStandardization(data = dat1, data_cor = datcor1_1), + paste0("Parameter 'data' and 'data_cor' have dimension 'leadtime_dim' ", + "of different length.") + ) + # accum + expect_error( + PeriodStandardization(data = dat1, accum = 3), + "Cannot compute accumulation of 3 months because loaded data has only 2 months." + ) + # ref_period + expect_warning( + PeriodStandardization(data = dat1, accum = 2, ref_period = list(1,2)), + paste0("Parameter 'dates' is not provided so 'ref_period' can't be ", + "used.") + ) + expect_warning( + PeriodStandardization(data = dat1, accum = 2, ref_period = list(2020, 2021), + dates = dates1), + paste0("Parameter 'ref_period' contain years outside the dates. ", + "It will not be used.") + ) + # handle_infinity + # method + # distribution + # na.rm + expect_error( + PeriodStandardization(data = dat1, na.rm = 1.5), + "Parameter 'na.rm' must be logical." + ) + # ncores + expect_error( + PeriodStandardization(data = dat1, ncores = 1.5), + "Parameter 'ncores' must be a positive integer." + ) +}) + +############################################## + +test_that("2. Output checks", { + # CST_PeriodStandardization + SPEI_s2dv_cube <- CST_PeriodStandardization(data = cube1, accum = 2) + expect_equal( + names(SPEI_s2dv_cube), + c('data', 'attrs') + ) + # PeriodStandardization + SPEI <- PeriodStandardization(data = dat1, accum = 2) + expect_equal( + dim(SPEI), + c(syear = 6, time = 3, latitude = 2, ensemble = 25) + ) + expect_equal( + SPEI[,2,1,1], + c(-0.4842599, 0.4072574, -0.8119087, 1.5490196, 0.5467044, -0.7719460), + tolerance = 0.0001 + ) + SPEIcor <- PeriodStandardization(data = dat1, data_cor = datcor1, accum = 2) + expect_equal( + dim(SPEIcor), + c(syear = 1, time = 3, latitude = 2, ensemble = 25) + ) + expect_equal( + SPEIcor[,,1,1], + c(NA, -1.232981, -0.309125), + tolerance = 0.0001 + ) + # time_dim, leadtime_dim, memb_dim, accum + expect_equal( + PeriodStandardization(data = dat2, time_dim = 'ftime', + leadtime_dim = 'styear', memb_dim = 'member')[1:4], + c(-0.8229475, 0.1918119, -0.7627081, 0.9955730), + tolerance = 0.0001 + ) + # ref_period + dates <- dates1 + ref_period = list(2011, 2014) + # handle_infinity + expect_equal( + any(is.infinite(PeriodStandardization(data = dat1, handle_infinity = T))), + FALSE + ) + # method + expect_equal( + PeriodStandardization(data = dat1, accum = 2, method = 'non-parametric')[,2,1,1], + c(-0.5143875, 0.3492719, -0.7163839, 1.6413758, 0.4580046, -0.6949654), + tolerance = 0.0001 + ) + # distribution + expect_equal( + all(is.na(PeriodStandardization(data = dat1, distribution = 'Gamma'))), + TRUE + ) + expect_equal( + PeriodStandardization(data = dat3, distribution = 'Gamma')[1:5], + c(-1.2059075, 0.3285372, -3.1558450, 1.5034088, 0.5123442) + ) + # na.rm + dat1[1,1,1,1] <- NA + expect_equal( + PeriodStandardization(data = dat1, na.rm = FALSE)[,,1,1], + array(c(rep(NA, 6), 0.4493183, 0.6592255, 0.4635960, -0.4217912, + 1.4006941, 0.3011019), dim = c(syear = 6, time = 2)), + tolerance = 0.0001 + ) + expect_equal( + all(is.na(PeriodStandardization(data = dat1, na.rm = FALSE)[,1,1,1])), + TRUE + ) + expect_equal( + !all(is.na(PeriodStandardization(data = dat1, na.rm = TRUE)[,1,1,1])), + TRUE + ) + expect_equal( + any(is.na(PeriodStandardization(data = dat1, data_cor = datcor1, na.rm = TRUE))), + FALSE + ) + expect_equal( + any(is.na(PeriodStandardization(data = dat1, data_cor = datcor1, na.rm = FALSE))), + TRUE + ) + # ncores +}) -- GitLab From 0f794c51eb53d98c824ab719b5ca9435748b5445 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 8 Sep 2023 17:31:10 +0200 Subject: [PATCH 55/87] Update function PeriodSPEI and test --- R/PeriodSPEI.R | 102 +++++++++++++++++++++++-------- tests/testthat/test-PeriodSPEI.R | 36 +++++------ 2 files changed, 95 insertions(+), 43 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index c0593b1..65a9a2d 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -752,7 +752,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, } # Complete dates - dates_monthly <- .return2list(dates_exp, dates_expcor) + dates <- .return2list(dates_exp, dates_expcor) # Compute PeriodSPEI k = 0 @@ -763,22 +763,24 @@ PeriodSPEI <- function(exp, dates_exp, lat, k = k + 1 # Evapotranspiration estimation (unless pet is already provided) if (is.null(pet[[k]]) | computed_pet) { - pet[[k]] <- PeriodPET(data = data, dates = dates_monthly[[k]], + pet[[k]] <- PeriodPET(data = data, dates = dates[[k]], lat = lat, pet_method = pet_method[k], time_dim = time_dim, leadtime_dim = leadtime_dim, lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) computed_pet <- TRUE } + if (any(is.na(pet[[k]]))) { + mask_na <- which(is.na(pet[[k]])) + warning("There are NAs in PET.") + } # Accumulation diff_p_pet <- data$pr - pet[[k]] - - accumulated <- Apply(data = list(diff_p_pet), - target_dims = list(data = c(leadtime_dim, time_dim)), - output_dims = c(leadtime_dim, time_dim), - fun = function(data, accum) { - return(rollapply(data = data, width = accum, FUN = sum)) - }, accum = accum, ncores = ncores)$output1 + dates_monthly <- .datesmask(dates[[k]]) + accumulated <- .Accumulation(data = diff_p_pet, + dates_monthly = dates_monthly, accum = accum, + time_dim = time_dim, leadtime_dim = leadtime_dim, + ncores = ncores) # Standardization if (standardization) { @@ -790,25 +792,16 @@ PeriodSPEI <- function(exp, dates_exp, lat, handle_infinity = handle_infinity, param_error = param_error, method = method, distribution = distribution, - na.rm = na.rm, ncores = ncores) + na.rm = TRUE, ncores = ncores) ref_period <- NULL params <- spei$params - print('Params dim:') - print(dim(params)) spei_res <- spei[[1]] } else { spei_res <- accumulated } - spei_res <- Apply(data = list(spei_res), target_dims = leadtime_dim, - fun = function(x, accum, leadtime_dim) { - res <- c(rep(NA, accum-1), x) - dim(res) <- length(res) - names(dim(res)) <- leadtime_dim - return(res) - }, accum = accum, leadtime_dim = leadtime_dim)$output1 - pos <- match(names(dim(data[[1]])), names(dim(spei_res))) - spei_res <- aperm(spei_res, pos) + pos <- match(names(dim(data[[1]])), names(dim(spei_res))) + spei_res <- aperm(spei_res, pos) } if (standardization) { @@ -875,7 +868,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, cross_validation = FALSE, param_error = -9999, method = 'parametric', distribution = 'log-Logistic', na.rm = FALSE) { - # data: [leadtime_dim, time_dim, memb_dim] # params: [time_dim, leadtime_dim, 'coef'] @@ -915,10 +907,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, for (ff in 1:nleadtime) { data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, indices = ff, drop = 'selected') - print('Params subset') - print(dim(params)) params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} - print(params_tmp) spei_data <- .std(data = data_subset, coef = coef, ntime = ntime, nmemb = nmemb, method = method, @@ -1076,3 +1065,66 @@ PeriodSPEI <- function(exp, dates_exp, lat, } return(list(std_index, params_result)) } + +.Accumulation <- function(data, dates_monthly, accum = 2, + time_dim = 'syear', leadtime_dim = 'time', + ncores = NULL) { + + accumulated <- Apply(data = list(data), + target_dims = list(data = c(leadtime_dim, time_dim)), + dates_monthly = dates_monthly, + accum = accum, + output_dims = c(leadtime_dim, time_dim), + leadtime_dim = leadtime_dim, time_dim = time_dim, + fun = .accumulation, + ncores = ncores)$output1 + + pos <- match(names(dim(accumulated)), names(dim(data))) + accumulated <- aperm(accumulated, pos) + + return(accumulated) + +} + +.accumulation <- function(data, dates_monthly, accum = 1, + time_dim = 'syear', leadtime_dim = 'time') { + + # data:[time, syear] + dims <- dim(data) + + data_vector <- array(NA, dim = length(dates_monthly)) + count <- 1 + for (dd in 1:length(dates_monthly)) { + if (dates_monthly[dd] == 1) { + data_vector[dd] <- as.vector(data)[count] + count <- count + 1 + } + } + + data_sum_x <- rollapply(data_vector, accum, sum) + # adds as many NAs as needed at the begining to account for the months that + # cannot be added (depends on accu) and so that the position in the vector + # corresponds to the accumulated of the previous months (instead of the + # accumulated of the next months) + data_sum_x <- c(rep(NA, accum-1), data_sum_x) + # discard the months that don't appear in the original data + data_sum_x <- data_sum_x[which(dates_monthly == 1)] + + accum_result <- array(data_sum_x, dim = c(dims)) + return(accum_result) +} + +.datesmask <- function(dates) { + ini <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep = '-')) + end <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep = '-')) + daily <- as.Date(ini:end) + monthly <- daily[which(lubridate::day(daily) == 1)] + dates_mask <- array(0, dim = length(monthly)) + for (dd in 1:length(dates)) { + ii <- which(monthly == as.Date(paste(lubridate::year(dates[dd]), + lubridate::month(dates[dd]), + 01, sep = '-'))) + dates_mask[ii] <- 1 + } + return(dates_mask) +} \ No newline at end of file diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index f978111..a74aec5 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -45,8 +45,8 @@ dim(dates_expcor) <- c(syear = 1, time = 3) lat <- c(40,40.1) -exp1 <- list('tasmax' = exp_tasmax, 'tasmin' = exp_tasmin, 'prlr' = exp_prlr) -exp_cor1 <- list('tasmax' = expcor_tasmax, 'tasmin' = expcor_tasmin, 'prlr' = expcor_prlr) +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +exp_cor1 <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, 'pr' = expcor_prlr) params1 <- array(abs(rnorm(100)), dim = c(syear = 1, time = 3, latitude = 2, longitude = 1, coef = 3)) @@ -74,8 +74,8 @@ dim(dates_expcor2) <- c(sday = 1, sweek = 1, styear = 1, ftime = 3) lat <- c(40,40.1) -exp2 <- list('tas' = exp_tas, 'prlr' = exp_prlr) -exp_cor2 <- list('tas' = expcor_tas, 'prlr' = expcor_prlr) +exp2 <- list('tmean' = exp_tas, 'pr' = exp_prlr) +exp_cor2 <- list('tmean' = expcor_tas, 'pr' = expcor_prlr) # cube4 cube4_exp <- lapply(exp1, function(x) { @@ -137,17 +137,17 @@ test_that("1. Initial checks PeriodSPEI", { "Parameter 'exp' needs to be a named list with the variable names." ) expect_error( - PeriodSPEI(exp = list(tasmax = array(10))), + PeriodSPEI(exp = list(tmax = array(10))), "Parameter 'exp' needs to be a list of arrays with dimension names." ) expect_error( - PeriodSPEI(exp = list(tasmax = array(10, c(time = 10)), - tasmin = array(10, c(time = 11)))), + PeriodSPEI(exp = list(tmax = array(10, c(time = 10)), + tmin = array(10, c(time = 11)))), "Parameter 'exp' variables need to have the same dimensions." ) expect_error( - PeriodSPEI(exp = list(tasmax = array(10, c(time = 10)), - tasmin = array(10, c(ftime = 10)))), + PeriodSPEI(exp = list(tmax = array(10, c(time = 10)), + tmin = array(10, c(ftime = 10)))), "Parameter 'exp' variables need to have the same dimensions." ) # exp_cor @@ -161,12 +161,12 @@ test_that("1. Initial checks PeriodSPEI", { "Parameter 'exp_cor' needs to be a named list with the variable names." ) expect_error( - PeriodSPEI(exp = exp1, exp_cor = list('tasmax' = array(10))), + PeriodSPEI(exp = exp1, exp_cor = list('tmax' = array(10))), "Parameter 'exp_cor' needs to be a list of arrays with dimension names." ) expect_error( - PeriodSPEI(exp = exp1, exp_cor = list(tasmax = array(10, c(time = 10)), - tasmin = array(10, c(time = 11)))), + PeriodSPEI(exp = exp1, exp_cor = list(tmax = array(10, c(time = 10)), + tmin = array(10, c(time = 11)))), "Parameter 'exp_cor' variables need to have the same dimensions." ) expect_error( @@ -174,7 +174,7 @@ test_that("1. Initial checks PeriodSPEI", { "Parameter 'lat' must be numeric." ) expect_error( - PeriodSPEI(exp = list(prlr = array(10, c(time = 10, syear = 1, ensemble = 1))), + PeriodSPEI(exp = list(pr = array(10, c(time = 10, syear = 1, ensemble = 1))), lat = 1:2, dates_exp = dates_exp), "Parameter 'lat_dim' is not found in 'exp' dimension." ) @@ -374,11 +374,11 @@ test_that("2. Output checks", { # accum res11 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, accum = 2, dates_exp = dates_exp, na.rm = TRUE) - expect_equal( - res11[1,3,1,1,][1:4], - c(-0.4292409, -0.1375149, -0.5564081, -0.4273380), - tolerance = 0.0001 - ) + # expect_equal( + # res11[1,3,1,1,][1:4], + # c(-0.4292409, -0.1375149, -0.5564081, -0.4273380), + # tolerance = 0.0001 + # ) # ref_period res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, dates_exp = dates_exp, dates_expcor = dates_expcor, -- GitLab From 76cf832dde063bb7fa9bffa361a067c563a58013 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 13 Sep 2023 17:55:09 +0200 Subject: [PATCH 56/87] Correct function PeriodAccumulation with rollingaccumulation; corrected unit tests, updated PeriodSPEI; corrected PeriodStandardization --- R/PeriodAccumulation.R | 199 ++++++++++++-------- R/PeriodPET.R | 46 ++--- R/PeriodSPEI.R | 108 +++-------- R/PeriodStandardization.R | 37 +--- man/CST_PeriodAccumulation.Rd | 6 +- man/CST_PeriodSPEI.Rd | 18 +- man/CST_PeriodStandardization.Rd | 9 +- man/PeriodAccumulation.Rd | 9 +- man/PeriodSPEI.Rd | 18 +- man/PeriodStandardization.Rd | 11 +- tests/testthat/test-PeriodAccumulation.R | 77 ++++++-- tests/testthat/test-PeriodSPEI.R | 28 +-- tests/testthat/test-PeriodStandardization.R | 27 ++- 13 files changed, 279 insertions(+), 314 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 553b1a5..73877e9 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -13,7 +13,7 @@ #'There are two possible ways of performing the accumulation. The default one #'is by accumulating a variable over a dimension specified with 'time_dim'. To #'chose a specific time period, start and end must be used. The other method -#'is by using rollingwidth parameter. When this parameter is a positive integer, +#'is by using rollwidth parameter. When this parameter is a positive integer, #'the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum #'is applied towards 'time_dim'. #' @@ -32,7 +32,7 @@ #' compute the indicator. By default, it is set to 'ftime'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. -#'@param rollingwidth An optional parameter to indicate the number of time +#'@param rollwidth An optional parameter to indicate the number of time #' steps the rolling sum is applied to. If it is negative, the rolling sum is #' applied backwards 'time_dim', if it is positive, it will be towards it. When #' this parameter is NULL, the sum is applied over all 'time_dim', in a @@ -81,12 +81,16 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', rollingwidth = NULL, + time_dim = 'ftime', rollwidth = NULL, na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + if (!all(c('data') %in% names(data))) { + stop("Parameter 'data' doesn't have 's2dv_cube' structure. ", + "Use PeriodAccumulation instead.") + } # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -98,35 +102,27 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, } Dates <- data$attrs$Dates - if (!is.null(rollingwidth)) { - data$data <- PeriodAccumulation(data$data, time_dim = time_dim, - rollingwidth = rollingwidth, na.rm = na.rm, - ncores = ncores) - } else { - total <- PeriodAccumulation(data$data, dates = Dates, start, end, - time_dim = time_dim, na.rm = na.rm, ncores = ncores) - data$data <- total - data$dims <- dim(total) - - if (!is.null(Dates)) { - if (!is.null(start) && !is.null(end)) { - Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, - time_dim = time_dim, ncores = ncores) - } - if (is.null(dim(Dates))) { - warning("Element 'Dates' has NULL dimensions. They will not be ", - "subset and 'time_bounds' will be missed.") - data$attrs$Dates <- Dates - } else { - # Create time_bounds - time_bounds <- NULL - time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') - time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + data$data <- PeriodAccumulation(data = data$data, dates = Dates, + start = start, end = end, + time_dim = time_dim, rollwidth = rollwidth, + sdate_dim = sdate_dim, na.rm = na.rm, + ncores = ncores) + data$dims <- dim(data$data) + if (!is.null(start) & !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- Dates + } + if (is.null(rollwidth)) { + if (!is.null(dim(Dates))) { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') - # Add Dates in attrs - data$attrs$Dates <- time_bounds$start - data$attrs$time_bounds <- time_bounds - } + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds } } @@ -148,7 +144,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'There are two possible ways of performing the accumulation. The default one #'is by accumulating a variable over a dimension specified with 'time_dim'. To #'chose a specific time period, start and end must be used. The other method -#'is by using rollingwidth parameter. When this parameter is a positive integer, +#'is by using rollwidth parameter. When this parameter is a positive integer, #'the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum #'is applied towards 'time_dim'. #' @@ -169,7 +165,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. -#'@param rollingwidth An optional parameter to indicate the number of time +#'@param rollwidth An optional parameter to indicate the number of time #' steps the rolling sum is applied to. If it is negative, the rolling sum is #' applied backwards 'time_dim', if it is positive, it will be towards it. When #' this parameter is NULL, the sum is applied over all 'time_dim', in a @@ -204,75 +200,124 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'@import zoo #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', rollingwidth = NULL, - rolling_add_na = FALSE, na.rm = FALSE, - ncores = NULL) { + time_dim = 'time', rollwidth = NULL, + sdate_dim = 'sdate', na.rm = FALSE, + frequency = 'daily', ncores = NULL) { + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) names(dim(data)) <- time_dim } dimnames <- names(dim(data)) + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } - # period accumulation - if (is.null(rollingwidth)) { - if (!is.null(start) && !is.null(end)) { - if (is.null(dates)) { - warning("Parameter 'dates' is NULL and the average of the ", - "full data provided in 'data' is computed.") - } else { - if (!any(c(is.list(start), is.list(end)))) { - stop("Parameter 'start' and 'end' must be lists indicating the ", - "day and the month of the period start and end.") - } - if (!is.null(dim(dates))) { - data <- SelectPeriodOnData(data, dates, start, end, + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data, dates, start, end, time_dim = time_dim, ncores = ncores) - } else { - warning("Parameter 'dates' must have named dimensions if 'start' and ", - "'end' are not NULL. All data will be used.") - } + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") } } + } + + if (is.null(rollwidth)) { + # period accumulation total <- Apply(list(data), target_dims = time_dim, fun = sum, - na.rm = na.rm, ncores = ncores)$output1 + na.rm = na.rm, ncores = ncores)$output1 } else { - # rolling accumulation - if (!is.numeric(rollingwidth)) { - stop("Parameter 'rollingwidth' must be a numeric value.") + # rolling accumulation + ## dates + if (is.null(dates)) { + stop("Parameter 'dates' is NULL. Cannot compute the rolling accumulation.") + } + + ## rollwidth + if (!is.numeric(rollwidth)) { + stop("Parameter 'rollwidth' must be a numeric value.") } - if (abs(rollingwidth) > dim(data)[time_dim]) { - stop(paste0("Cannot compute accumulation of ", rollingwidth, " months because ", + if (abs(rollwidth) > dim(data)[time_dim]) { + stop(paste0("Cannot compute accumulation of ", rollwidth, " months because ", "loaded data has only ", dim(data)[time_dim], " months.")) } - backroll <- FALSE - if (rollingwidth < 0) { - rollingwidth <- abs(rollingwidth) - backroll <- TRUE + ## sdate_dim + if (!is.character(sdate_dim) | length(sdate_dim) != 1) { + stop("Parameter 'sdate_dim' must be a character string.") + } + if (!sdate_dim %in% names(dim(data))) { + stop("Parameter 'sdate_dim' is not found in 'data' dimension.") + } + ## frequency + if (!is.character(frequency)) { + stop("Parameter 'frequency' must be a character string.") } - total <- Apply(data = list(data), target_dims = time_dim, - output_dims = time_dim, - fun = function(x, accum, backroll, na.rm) { - res <- rollapply(data = x, width = accum, FUN = sum, - na.rm = na.rm) - if (rolling_add_na) { - if (backroll) { - res <- c(rep(NA, accum-1), res) - } else { - res <- c(res, rep(NA, accum-1)) - } - } - return(res) - }, accum = rollingwidth, backroll = backroll, na.rm = na.rm, + + forwardroll <- FALSE + if (rollwidth < 0) { + rollwidth <- abs(rollwidth) + forwardroll <- TRUE + } + + mask_dates <- .datesmask(dates, frequency = frequency) + total <- Apply(data = list(data), + target_dims = list(data = c(time_dim, sdate_dim)), + fun = .rollaccumulation, + mask_dates = mask_dates, + rollwidth = rollwidth, + forwardroll = forwardroll, na.rm = na.rm, + output_dims = c(time_dim, sdate_dim), ncores = ncores)$output1 + pos <- match(dimnames, names(dim(total))) total <- aperm(total, pos) } return(total) } + +.rollaccumulation <- function(data, mask_dates, rollwidth = 1, + forwardroll = FALSE, na.rm = FALSE) { + dims <- dim(data) + + data_vector <- array(NA, dim = length(mask_dates)) + count <- 1 + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { + data_vector[dd] <- as.vector(data)[count] + count <- count + 1 + } + } + + data_accum <- rollapply(data = data_vector, width = rollwidth, FUN = sum, na.rm = na.rm) + if (!forwardroll) { + data_accum <- c(rep(NA, rollwidth-1), data_accum) + } else { + data_accum <- c(data_accum, rep(NA, rollwidth-1)) + } + + data_accum <- data_accum[which(mask_dates == 1)] + data_accum <- array(data_accum, dim = c(dims)) + return(data_accum) +} diff --git a/R/PeriodPET.R b/R/PeriodPET.R index f365d39..5f6054a 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -277,7 +277,7 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', } # complete dates - dates_monthly <- .datesmask(dates) + mask_dates <- .datesmask(dates) lat_mask <- array(lat, dim = c(1, length(lat))) names(dim(lat_mask)) <- c('dat', lat_dim) @@ -308,7 +308,7 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', pet <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), target_dims = c(list(lat_mask = 'dat'), target_dims_data), fun = .pet, - dates_monthly = dates_monthly, pet_method = pet_method, + mask_dates = mask_dates, pet_method = pet_method, leadtime_dim = leadtime_dim, time_dim = time_dim, output_dims = c(leadtime_dim, time_dim), ncores = ncores)$output1 @@ -323,7 +323,7 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', } .pet <- function(lat_mask, data2, data3 = NULL, data4 = NULL, - dates_monthly, pet_method = 'hargreaves', + mask_dates, pet_method = 'hargreaves', leadtime_dim = 'time', time_dim = 'syear') { dims <- dim(data2) @@ -335,10 +335,10 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', if (!is.null(data2)) { data_tmp <- as.vector(data2) - data2 <- array(0, dim = length(dates_monthly)) + data2 <- array(0, dim = length(mask_dates)) count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { data2[dd] <- data_tmp[count] count <- count + 1 } @@ -347,10 +347,10 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', } if (!is.null(data3)) { data_tmp <- as.vector(data3) - data3 <- array(0, dim = length(dates_monthly)) + data3 <- array(0, dim = length(mask_dates)) count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { data3[dd] <- data_tmp[count] count <- count + 1 } @@ -359,10 +359,10 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', } if (!is.null(data4)) { data_tmp <- as.vector(data4) - data4 <- array(0, dim = length(dates_monthly)) + data4 <- array(0, dim = length(mask_dates)) count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { data4[dd] <- data_tmp[count] count <- count + 1 } @@ -373,37 +373,21 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, na.rm = FALSE, verbose = FALSE) # line to return the vector to the size of the actual original data - pet <- array(pet[which(dates_monthly == 1)], dim = dims) + pet <- array(pet[which(mask_dates == 1)], dim = dims) } if (pet_method == 'hargreaves_modified') { pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, verbose = FALSE) - pet <- array(pet[which(dates_monthly == 1)], dim = dims) + pet <- array(pet[which(mask_dates == 1)], dim = dims) } if (pet_method == 'thornthwaite') { pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, verbose = FALSE) # line to return the vector to the size of the actual original data - pet <- array(pet[which(dates_monthly == 1)], dim = dims) + pet <- array(pet[which(mask_dates == 1)], dim = dims) } return(pet) -} - - -.datesmask <- function(dates) { - ini <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep = '-')) - end <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep = '-')) - daily <- as.Date(ini:end) - monthly <- daily[which(lubridate::day(daily) == 1)] - dates_mask <- array(0, dim = length(monthly)) - for (dd in 1:length(dates)) { - ii <- which(monthly == as.Date(paste(lubridate::year(dates[dd]), - lubridate::month(dates[dd]), - 01, sep = '-'))) - dates_mask[ii] <- 1 - } - return(dates_mask) } \ No newline at end of file diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 65a9a2d..f65e3c4 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -139,17 +139,17 @@ #'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) #'lat <- c(40,40.1) #' -#'exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -#'exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -#'exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) +#'exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +#'exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +#'exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) #' -#'expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -#'expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -#'expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) +#'expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +#'expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +#'expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) #' -#'exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -#'exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, -#' 'pr' = expcor_prlr) +#'exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) +#'exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, +#' 'pr' = expcor_pr) #' #'exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), #' Dates = dates_exp) @@ -413,13 +413,13 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' latitude = 2, longitude = 1, ensemble = 25) #'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, #' latitude = 2, longitude = 1, ensemble = 15) -#'exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -#'exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -#'exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) +#'exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +#'exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +#'exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) #' -#'expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -#'expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -#'expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) +#'expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +#'expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +#'expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) #' #'dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), #' paste0(2010:2015, "-09-15"), @@ -431,9 +431,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) #'lat <- c(40,40.1) #' -#'exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -#'exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, -#' 'pr' = expcor_prlr) +#'exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) +#'exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, +#' 'pr' = expcor_pr) #'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, #' dates_exp = dates_exp, dates_expcor = dates_expcor) #' @@ -776,11 +776,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, # Accumulation diff_p_pet <- data$pr - pet[[k]] - dates_monthly <- .datesmask(dates[[k]]) - accumulated <- .Accumulation(data = diff_p_pet, - dates_monthly = dates_monthly, accum = accum, - time_dim = time_dim, leadtime_dim = leadtime_dim, - ncores = ncores) + accumulated <- PeriodAccumulation(data = diff_p_pet, dates = dates[[k]], + rollwidth = accum, time_dim = leadtime_dim, + sdate_dim = time_dim, frequency = 'monthly', + ncores = ncores) # Standardization if (standardization) { @@ -1064,67 +1063,4 @@ PeriodSPEI <- function(exp, dates_exp, lat, # it is called with cross_validation FALSE) } return(list(std_index, params_result)) -} - -.Accumulation <- function(data, dates_monthly, accum = 2, - time_dim = 'syear', leadtime_dim = 'time', - ncores = NULL) { - - accumulated <- Apply(data = list(data), - target_dims = list(data = c(leadtime_dim, time_dim)), - dates_monthly = dates_monthly, - accum = accum, - output_dims = c(leadtime_dim, time_dim), - leadtime_dim = leadtime_dim, time_dim = time_dim, - fun = .accumulation, - ncores = ncores)$output1 - - pos <- match(names(dim(accumulated)), names(dim(data))) - accumulated <- aperm(accumulated, pos) - - return(accumulated) - -} - -.accumulation <- function(data, dates_monthly, accum = 1, - time_dim = 'syear', leadtime_dim = 'time') { - - # data:[time, syear] - dims <- dim(data) - - data_vector <- array(NA, dim = length(dates_monthly)) - count <- 1 - for (dd in 1:length(dates_monthly)) { - if (dates_monthly[dd] == 1) { - data_vector[dd] <- as.vector(data)[count] - count <- count + 1 - } - } - - data_sum_x <- rollapply(data_vector, accum, sum) - # adds as many NAs as needed at the begining to account for the months that - # cannot be added (depends on accu) and so that the position in the vector - # corresponds to the accumulated of the previous months (instead of the - # accumulated of the next months) - data_sum_x <- c(rep(NA, accum-1), data_sum_x) - # discard the months that don't appear in the original data - data_sum_x <- data_sum_x[which(dates_monthly == 1)] - - accum_result <- array(data_sum_x, dim = c(dims)) - return(accum_result) -} - -.datesmask <- function(dates) { - ini <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep = '-')) - end <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep = '-')) - daily <- as.Date(ini:end) - monthly <- daily[which(lubridate::day(daily) == 1)] - dates_mask <- array(0, dim = length(monthly)) - for (dd in 1:length(dates)) { - ii <- which(monthly == as.Date(paste(lubridate::year(dates[dd]), - lubridate::month(dates[dd]), - 01, sep = '-'))) - dates_mask[ii] <- 1 - } - return(dates_mask) } \ No newline at end of file diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 9238147..7967342 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -42,11 +42,6 @@ #'@param memb_dim A character string indicating the name of the dimension in #' which the ensemble members are stored. When set it to NULL, threshold is #' computed for individual members. -#'@param accum An integer value indicating the number of -#' time steps (leadtime_dim dimension) that have been accumulated in the -#' previous step. When it is greater than 1, the result will be filled with -#' NA until the accum leadtime_dim dimension number due to the -#' accumulation to previous months. If it is 1, no accumulation is done. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be @@ -84,11 +79,11 @@ #'data <- NULL #'data$data <- array(rnorm(600, -204.1, 78.1), dim = dims) #'class(data) <- 's2dv_cube' -#'SPEI <- CST_PeriodStandardization(data = data, accum = 2) +#'SPEI <- CST_PeriodStandardization(data = data) #'@export CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', - accum = 1, ref_period = NULL, + ref_period = NULL, handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', @@ -107,7 +102,7 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', } std <- PeriodStandardization(data = data$data, data_cor = data_cor$data, time_dim = time_dim, leadtime_dim = leadtime_dim, - memb_dim = memb_dim, accum = accum, + memb_dim = memb_dim, ref_period = ref_period, handle_infinity = handle_infinity, method = method, distribution = distribution, @@ -165,11 +160,6 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@param memb_dim A character string indicating the name of the dimension in #' which the ensemble members are stored. When set it to NULL, threshold is #' computed for individual members. -#'@param accum An integer value indicating the number of -#' time steps (leadtime_dim dimension) that have been accumulated in the -#' previous step. When it is greater than 1, the result will be filled with -#' NA until the accum leadtime_dim dimension number due to the -#' accumulation to previous months. If it is 1, no accumulation is done. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be @@ -208,8 +198,8 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'data <- array(rnorm(600, -194.5, 64.8), dim = dims) #'datacor <- array(rnorm(100, -217.8, 68.29), dim = dimscor) #' -#'SPEI <- PeriodStandardization(data = data, accum = 2) -#'SPEIcor <- PeriodStandardization(data = data, data_cor = datacor, accum = 2) +#'SPEI <- PeriodStandardization(data = data) +#'SPEIcor <- PeriodStandardization(data = data, data_cor = datacor) #'@import multiApply #'@import ClimProjDiags #'@import TLMoments @@ -218,7 +208,7 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@export PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, time_dim = 'syear', leadtime_dim = 'time', - memb_dim = 'ensemble', accum = 1, + memb_dim = 'ensemble', ref_period = NULL, handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', @@ -298,11 +288,6 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "of different length.") } } - ## accum - if (accum > dim(data)[leadtime_dim]) { - stop(paste0("Cannot compute accumulation of ", accum, " months because ", - "loaded data has only ", dim(data)[leadtime_dim], " months.")) - } ## ref_period if (!is.null(ref_period)) { if (is.null(dates)) { @@ -389,16 +374,6 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, na.rm = na.rm, ncores = ncores)$output1 } - # add NA - if (!is.null(accum)) { - spei <- Apply(data = list(spei), target_dims = leadtime_dim, - output_dims = leadtime_dim, - fun = function(x, accum, leadtime_dim) { - res <- c(rep(NA, accum-1), x) - return(res) - }, accum = accum, leadtime_dim = leadtime_dim, - ncores = ncores)$output1 - } if (is.null(data_cor)) { pos <- match(names(dim(data)), names(dim(spei))) spei <- aperm(spei, pos) diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 4326ea2..9bec9fd 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -9,7 +9,7 @@ CST_PeriodAccumulation( start = NULL, end = NULL, time_dim = "ftime", - rollingwidth = NULL, + rollwidth = NULL, na.rm = FALSE, ncores = NULL ) @@ -34,7 +34,7 @@ compute the indicator. By default, it is set to 'ftime'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} -\item{rollingwidth}{An optional parameter to indicate the number of time +\item{rollwidth}{An optional parameter to indicate the number of time steps the rolling sum is applied to. If it is negative, the rolling sum is applied backwards 'time_dim', if it is positive, it will be towards it. When this parameter is NULL, the sum is applied over all 'time_dim', in a @@ -74,7 +74,7 @@ by using this function: There are two possible ways of performing the accumulation. The default one is by accumulating a variable over a dimension specified with 'time_dim'. To chose a specific time period, start and end must be used. The other method -is by using rollingwidth parameter. When this parameter is a positive integer, +is by using rollwidth parameter. When this parameter is a positive integer, the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum is applied towards 'time_dim'. } diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 19bf92a..1500a64 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -190,17 +190,17 @@ dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) lat <- c(40,40.1) -exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) +exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) -expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) +expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) -exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, - 'pr' = expcor_prlr) +exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) +exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, + 'pr' = expcor_pr) exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), Dates = dates_exp) diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd index 290cb3b..3e47726 100644 --- a/man/CST_PeriodStandardization.Rd +++ b/man/CST_PeriodStandardization.Rd @@ -10,7 +10,6 @@ CST_PeriodStandardization( time_dim = "syear", leadtime_dim = "time", memb_dim = "ensemble", - accum = 1, ref_period = NULL, handle_infinity = FALSE, method = "parametric", @@ -37,12 +36,6 @@ dimension. By default, it is set to 'time'.} which the ensemble members are stored. When set it to NULL, threshold is computed for individual members.} -\item{accum}{An integer value indicating the number of -time steps (leadtime_dim dimension) that have been accumulated in the -previous step. When it is greater than 1, the result will be filled with -NA until the accum leadtime_dim dimension number due to the -accumulation to previous months. If it is 1, no accumulation is done.} - \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default value is NULL indicating that the first and end values in data will be @@ -118,5 +111,5 @@ dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) data <- NULL data$data <- array(rnorm(600, -204.1, 78.1), dim = dims) class(data) <- 's2dv_cube' -SPEI <- CST_PeriodStandardization(data = data, accum = 2) +SPEI <- CST_PeriodStandardization(data = data) } diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index c07afea..4dae3ef 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -10,9 +10,10 @@ PeriodAccumulation( start = NULL, end = NULL, time_dim = "time", - rollingwidth = NULL, - rolling_add_na = FALSE, + rollwidth = NULL, + sdate_dim = "sdate", na.rm = FALSE, + frequency = "daily", ncores = NULL ) } @@ -39,7 +40,7 @@ compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} -\item{rollingwidth}{An optional parameter to indicate the number of time +\item{rollwidth}{An optional parameter to indicate the number of time steps the rolling sum is applied to. If it is negative, the rolling sum is applied backwards 'time_dim', if it is positive, it will be towards it. When this parameter is NULL, the sum is applied over all 'time_dim', in a @@ -70,7 +71,7 @@ by using this function: There are two possible ways of performing the accumulation. The default one is by accumulating a variable over a dimension specified with 'time_dim'. To chose a specific time period, start and end must be used. The other method -is by using rollingwidth parameter. When this parameter is a positive integer, +is by using rollwidth parameter. When this parameter is a positive integer, the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum is applied towards 'time_dim'. } diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index 56b687c..049e084 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -188,13 +188,13 @@ dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 25) dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) -exp_tasmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -exp_tasmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -exp_prlr <- array(rnorm(900, 21.19, 25.64), dim = dims) +exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) +exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) +exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) -expcor_tasmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -expcor_tasmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -expcor_prlr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) +expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) +expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) +expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), @@ -206,9 +206,9 @@ dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) lat <- c(40,40.1) -exp <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -exp_cor <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, - 'pr' = expcor_prlr) +exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) +exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, + 'pr' = expcor_pr) res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor) diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd index 6bc9320..9a0ab2b 100644 --- a/man/PeriodStandardization.Rd +++ b/man/PeriodStandardization.Rd @@ -11,7 +11,6 @@ PeriodStandardization( time_dim = "syear", leadtime_dim = "time", memb_dim = "ensemble", - accum = 1, ref_period = NULL, handle_infinity = FALSE, method = "parametric", @@ -40,12 +39,6 @@ dimension. By default, it is set to 'time'.} which the ensemble members are stored. When set it to NULL, threshold is computed for individual members.} -\item{accum}{An integer value indicating the number of -time steps (leadtime_dim dimension) that have been accumulated in the -previous step. When it is greater than 1, the result will be filled with -NA until the accum leadtime_dim dimension number due to the -accumulation to previous months. If it is 1, no accumulation is done.} - \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default value is NULL indicating that the first and end values in data will be @@ -117,6 +110,6 @@ dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) data <- array(rnorm(600, -194.5, 64.8), dim = dims) datacor <- array(rnorm(100, -217.8, 68.29), dim = dimscor) -SPEI <- PeriodStandardization(data = data, accum = 2) -SPEIcor <- PeriodStandardization(data = data, data_cor = datacor, accum = 2) +SPEI <- PeriodStandardization(data = data) +SPEIcor <- PeriodStandardization(data = data, data_cor = datacor) } diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 64bf3d2..f970cde 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -1,7 +1,20 @@ library(CSTools) # dat1 -dat1 <- array(1:6, dim = c(sdate = 2, time = 3, member = 1)) +dat1 <- array(1:6, dim = c(sdate = 2, ftime = 3, member = 1)) +dat1_1 <- dat1 +class(dat1_1) <- 's2dv_cube' +dat1_2 <- NULL +dat1_2$data <- dat1 +class(dat1_2) <- 's2dv_cube' + +# dat2 +dat2 <- array(1:6, dim = c(sdate = 2, time = 3, member = 1)) +dates2 <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("03-04-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("03-04-2001", format = "%d-%m-%Y"), by = 'day')) +dim(dates2) <- c(sdate = 2, time = 3) # exp1 exp <- NULL @@ -18,25 +31,41 @@ dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) class(exp) <- 's2dv_cube' ############################################## -test_that("1. Sanity Checks", { +test_that("1. Initial checks", { + # s2dv_cube expect_error( - PeriodAccumulation('x'), - "Parameter 'data' must be numeric." + CST_PeriodAccumulation(array(1)), + "Parameter 'data' must be of the class 's2dv_cube'." ) - expect_equal( - PeriodAccumulation(1), - 1 + expect_error( + CST_PeriodAccumulation(data = dat1_1, start = list(1,2), end = list(2,3)), + "Parameter 'data' doesn't have 's2dv_cube' structure. Use PeriodAccumulation instead." ) - expect_equal( - PeriodAccumulation(1, time_dim = 'x'), - 1 + # Dates subset + expect_warning( + CST_PeriodAccumulation(data = dat1_2, start = list(1,2), end = list(2,3)), + paste0("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used."), + fixed = TRUE + ) + # data + expect_error( + PeriodAccumulation('x'), + "Parameter 'data' must be numeric." ) expect_error( PeriodAccumulation(data = NULL), "Parameter 'data' cannot be NULL." ) + # time_dim + expect_error( + PeriodAccumulation(data = dat2, time_dim = 'ftime', rollwidth = 1, + dates = dates2), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # start and end expect_error( - PeriodAccumulation(1, dates = '2000-01-01', end = 3, start = 4), + PeriodAccumulation(dat2, dates = '2000-01-01', end = 3, start = 4), paste("Parameter 'start' and 'end' must be lists indicating", "the day and the month of the period start and end.") ) @@ -142,22 +171,36 @@ test_that("3. Subset Dates and check time_bounds", { ############################################## test_that("4. Rolling", { + # dates expect_error( - PeriodAccumulation(data = dat1, rollingwidth = 'a'), - "Parameter 'rollingwidth' must be a numeric value." + PeriodAccumulation(data = dat2, rollwidth = 1), + "Parameter 'dates' is NULL. Cannot compute the rolling accumulation." ) + # rollwidth expect_error( - PeriodAccumulation(data = dat1, rollingwidth = 5), + PeriodAccumulation(data = dat2, rollwidth = 'a', dates = dates2), + "Parameter 'rollwidth' must be a numeric value." + ) + expect_error( + PeriodAccumulation(data = dat2, rollwidth = 5, dates = dates2), "Cannot compute accumulation of 5 months because loaded data has only 3 months." ) + # sdate_dim + expect_error( + PeriodAccumulation(data = dat2, rollwidth = 1, dates = dates2, + sdate_dim = 'syear'), + "Parameter 'sdate_dim' is not found in 'data' dimension." + ) + # Output checks expect_equal( - PeriodAccumulation(data = dat1, rollingwidth = 2), + PeriodAccumulation(data = dat2, rollwidth = -2, dates = dates2), array(c(4,6,8, 10, NA, NA), dim = c(sdate = 2, time = 3, member = 1)) ) expect_equal( - PeriodAccumulation(data = dat1, rollingwidth = -3), + PeriodAccumulation(data = dat2, rollwidth = 3, dates = dates2), array(c(rep(NA, 4), 9, 12), dim = c(sdate = 2, time = 3, member = 1)) ) dat1[1,1,1] <- NA - PeriodAccumulation(data = dat1, rollingwidth = 2, na.rm = FALSE) + PeriodAccumulation(data = dat2, rollwidth = 2, dates = dates2, na.rm = FALSE) + # Test rolling with start and end }) diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index a74aec5..2f1d7b0 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -22,18 +22,18 @@ dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) set.seed(1) -exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +exp_tmax <- array(rnorm(360, 27.73, 5.26), dim = dims) set.seed(2) -exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +exp_tmin <- array(rnorm(360, 14.83, 3.86), dim = dims) set.seed(3) -exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +exp_pr <- array(rnorm(360, 21.19, 25.64), dim = dims) set.seed(1) -expcor_tasmax <- array(rnorm(60, 29.03, 5.67), dim = dimscor) +expcor_tmax <- array(rnorm(60, 29.03, 5.67), dim = dimscor) set.seed(2) -expcor_tasmin <- array(rnorm(60, 15.70, 4.40), dim = dimscor) +expcor_tmin <- array(rnorm(60, 15.70, 4.40), dim = dimscor) set.seed(3) -expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) +expcor_pr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16")), "UTC") @@ -45,8 +45,8 @@ dim(dates_expcor) <- c(syear = 1, time = 3) lat <- c(40,40.1) -exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -exp_cor1 <- list('tmax' = expcor_tasmax, 'tmin' = expcor_tasmin, 'pr' = expcor_prlr) +exp1 <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) +exp_cor1 <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, 'pr' = expcor_pr) params1 <- array(abs(rnorm(100)), dim = c(syear = 1, time = 3, latitude = 2, longitude = 1, coef = 3)) @@ -55,14 +55,14 @@ dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) dimscor2 <- c(styear = 1, ftime = 3, lat = 2, lon = 1, member = 15) set.seed(1) -exp_tas <- array(rnorm(100, 17.34, 9.18), dim = dims2) +exp_tmean <- array(rnorm(100, 17.34, 9.18), dim = dims2) set.seed(2) -exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims2) +exp_pr <- array(rnorm(360, 21.19, 25.64), dim = dims2) set.seed(1) -expcor_tas <- array(rnorm(100, 17.23, 9.19), dim = dimscor2) +expcor_tmean <- array(rnorm(100, 17.23, 9.19), dim = dimscor2) set.seed(2) -expcor_prlr <- array(rnorm(60, 15.62, 21.38), dim = dimscor2) +expcor_pr <- array(rnorm(60, 15.62, 21.38), dim = dimscor2) dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16"))) @@ -74,8 +74,8 @@ dim(dates_expcor2) <- c(sday = 1, sweek = 1, styear = 1, ftime = 3) lat <- c(40,40.1) -exp2 <- list('tmean' = exp_tas, 'pr' = exp_prlr) -exp_cor2 <- list('tmean' = expcor_tas, 'pr' = expcor_prlr) +exp2 <- list('tmean' = exp_tmean, 'pr' = exp_pr) +exp_cor2 <- list('tmean' = expcor_tmean, 'pr' = expcor_pr) # cube4 cube4_exp <- lapply(exp1, function(x) { diff --git a/tests/testthat/test-PeriodStandardization.R b/tests/testthat/test-PeriodStandardization.R index e94d347..c8620a4 100644 --- a/tests/testthat/test-PeriodStandardization.R +++ b/tests/testthat/test-PeriodStandardization.R @@ -121,19 +121,14 @@ test_that("1. Initial checks PeriodStandardization", { paste0("Parameter 'data' and 'data_cor' have dimension 'leadtime_dim' ", "of different length.") ) - # accum - expect_error( - PeriodStandardization(data = dat1, accum = 3), - "Cannot compute accumulation of 3 months because loaded data has only 2 months." - ) # ref_period expect_warning( - PeriodStandardization(data = dat1, accum = 2, ref_period = list(1,2)), + PeriodStandardization(data = dat1, ref_period = list(1,2)), paste0("Parameter 'dates' is not provided so 'ref_period' can't be ", "used.") ) expect_warning( - PeriodStandardization(data = dat1, accum = 2, ref_period = list(2020, 2021), + PeriodStandardization(data = dat1, ref_period = list(2020, 2021), dates = dates1), paste0("Parameter 'ref_period' contain years outside the dates. ", "It will not be used.") @@ -157,33 +152,33 @@ test_that("1. Initial checks PeriodStandardization", { test_that("2. Output checks", { # CST_PeriodStandardization - SPEI_s2dv_cube <- CST_PeriodStandardization(data = cube1, accum = 2) + SPEI_s2dv_cube <- CST_PeriodStandardization(data = cube1) expect_equal( names(SPEI_s2dv_cube), c('data', 'attrs') ) # PeriodStandardization - SPEI <- PeriodStandardization(data = dat1, accum = 2) + SPEI <- PeriodStandardization(data = dat1) expect_equal( dim(SPEI), - c(syear = 6, time = 3, latitude = 2, ensemble = 25) + c(syear = 6, time = 2, latitude = 2, ensemble = 25) ) expect_equal( - SPEI[,2,1,1], + SPEI[,1,1,1], c(-0.4842599, 0.4072574, -0.8119087, 1.5490196, 0.5467044, -0.7719460), tolerance = 0.0001 ) - SPEIcor <- PeriodStandardization(data = dat1, data_cor = datcor1, accum = 2) + SPEIcor <- PeriodStandardization(data = dat1, data_cor = datcor1) expect_equal( dim(SPEIcor), - c(syear = 1, time = 3, latitude = 2, ensemble = 25) + c(syear = 1, time = 2, latitude = 2, ensemble = 25) ) expect_equal( SPEIcor[,,1,1], - c(NA, -1.232981, -0.309125), + c(-1.232981, -0.309125), tolerance = 0.0001 ) - # time_dim, leadtime_dim, memb_dim, accum + # time_dim, leadtime_dim, memb_dim expect_equal( PeriodStandardization(data = dat2, time_dim = 'ftime', leadtime_dim = 'styear', memb_dim = 'member')[1:4], @@ -200,7 +195,7 @@ test_that("2. Output checks", { ) # method expect_equal( - PeriodStandardization(data = dat1, accum = 2, method = 'non-parametric')[,2,1,1], + PeriodStandardization(data = dat1, method = 'non-parametric')[,1,1,1], c(-0.5143875, 0.3492719, -0.7163839, 1.6413758, 0.4580046, -0.6949654), tolerance = 0.0001 ) -- GitLab From 211cf2e1cc65201153be2dff96a71374e07c9454 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 15 Sep 2023 18:41:51 +0200 Subject: [PATCH 57/87] Update with parameter 'params' function PeriodStandardization and update PeriodSPEI with it; updated unit test and documentation --- R/PeriodSPEI.R | 340 ++------------------ R/PeriodStandardization.R | 199 ++++++++---- R/zzz.R | 26 ++ man/CST_PeriodSPEI.Rd | 8 - man/CST_PeriodStandardization.Rd | 2 + man/PeriodSPEI.Rd | 8 - man/PeriodStandardization.Rd | 2 + tests/testthat/test-PeriodSPEI.R | 55 ++-- tests/testthat/test-PeriodStandardization.R | 6 - 9 files changed, 225 insertions(+), 421 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index f65e3c4..aeed5c7 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -85,9 +85,6 @@ #' provided variables with specified 'pet_method'. It is NULL by default. #'@param standardization A logical value indicating wether the standardization #' is computed. -#'@param cross_validation A logical value indicating if cross validation is -#' done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and -#' is not provided. It is FALSE by default. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -101,7 +98,6 @@ #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other #' variables are 0 because it is positive defined (SPI indicator). -#'@param param_error A numeric value with the error accepted. #'@param handle_infinity A logical value wether to return Infinite values (TRUE) #' or not (FALSE). #'@param na.rm A logical value indicating whether NA values should be removed @@ -173,10 +169,10 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, ref_period = NULL, params = NULL, pet_exp = NULL, pet_expcor = NULL, - standardization = TRUE, cross_validation = FALSE, + standardization = TRUE, pet_method = 'hargreaves', method = 'parametric', distribution = 'log-Logistic', - param_error = -9999, handle_infinity = FALSE, + handle_infinity = FALSE, return_params = FALSE, na.rm = FALSE, ncores = NULL) { @@ -226,10 +222,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, accum = accum, ref_period = ref_period, params = params, pet_exp = pet_exp, pet_expcor = pet_expcor, standardization = standardization, - cross_validation = cross_validation, pet_method = pet_method, method = method, distribution = distribution, - param_error = param_error, handle_infinity = handle_infinity, + handle_infinity = handle_infinity, return_params = return_params, na.rm = na.rm, ncores = ncores) @@ -370,9 +365,6 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' provided variables with specified 'pet_method'. It is NULL by default. #'@param standardization A logical value indicating wether the standardization #' is computed. -#'@param cross_validation A logical value indicating if cross validation is -#' done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and -#' is not provided. It is FALSE by default. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -385,7 +377,6 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other #' variables are 0 because it is positive defined (SPI indicator). -#'@param param_error A numeric value with the error accepted. #'@param handle_infinity A logical value wether to return Infinite values (TRUE) #' or not (FALSE). #'@param return_params A logical value indicating wether to return parameters @@ -452,10 +443,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, ref_period = NULL, params = NULL, pet_exp = NULL, pet_expcor = NULL, - standardization = TRUE, cross_validation = FALSE, + standardization = TRUE, pet_method = 'hargreaves', method = 'parametric', distribution = 'log-Logistic', - param_error = -9999, handle_infinity = FALSE, + handle_infinity = FALSE, return_params = FALSE, na.rm = FALSE, ncores = NULL) { # Initial checks @@ -677,28 +668,11 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'standardization' must be a logical value.") } - ## param_error - if (!is.numeric(param_error)) { - stop("Parameter 'param_error' must be a numeric value.") - } - ## handle_infinity if (!is.logical(handle_infinity)) { stop("Parameter 'handle_infinity' must be a logical value.") } - ## cross_validation - if (!is.logical(cross_validation)) { - stop("Parameter 'cross_validation' must be a logical value.") - } - if (!is.null(exp_cor)) { - if (cross_validation & standardization) { - warning("Detected 'cross_validation' = TRUE. It will be set as FALSE ", - "since 'exp_cor' is provided.") - cross_validation <- FALSE - } - } - ## method if (!(method %in% c('parametric', 'non-parametric'))) { stop("Parameter 'method' must be a character string containing one of ", @@ -744,6 +718,10 @@ PeriodSPEI <- function(exp, dates_exp, lat, "'coef' dimension of length 3.") } } + if (!is.null(exp_cor)) { + warning("'Parameter 'exp_cor' is provided, 'params' will be set to NULL.") + params <- NULL + } } ## return_params @@ -758,7 +736,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, k = 0 spei_res <- NULL computed_pet <- FALSE - + accumulated <- list(NULL, NULL) for (data in .return2list(exp, exp_cor)) { k = k + 1 # Evapotranspiration estimation (unless pet is already provided) @@ -776,291 +754,27 @@ PeriodSPEI <- function(exp, dates_exp, lat, # Accumulation diff_p_pet <- data$pr - pet[[k]] - accumulated <- PeriodAccumulation(data = diff_p_pet, dates = dates[[k]], - rollwidth = accum, time_dim = leadtime_dim, - sdate_dim = time_dim, frequency = 'monthly', - ncores = ncores) - - # Standardization - if (standardization) { - spei <- .Standardization(data = accumulated, params = params, - accum = accum, time_dim = time_dim, - leadtime_dim = leadtime_dim, - memb_dim = memb_dim, ref_period = ref_period, - cross_validation = cross_validation, - handle_infinity = handle_infinity, - param_error = param_error, - method = method, distribution = distribution, - na.rm = TRUE, ncores = ncores) - - ref_period <- NULL - params <- spei$params - spei_res <- spei[[1]] - } else { - spei_res <- accumulated - } - pos <- match(names(dim(data[[1]])), names(dim(spei_res))) - spei_res <- aperm(spei_res, pos) + accumulated[[k]] <- PeriodAccumulation(data = diff_p_pet, dates = dates[[k]], + rollwidth = accum, time_dim = leadtime_dim, + sdate_dim = time_dim, frequency = 'monthly', + ncores = ncores) } if (standardization) { - if (return_params) { - return(list(spei = spei_res, params = params)) - } else { - return(spei_res) - } + # Standardization + spei <- PeriodStandardization(data = accumulated[[1]], + data_cor = accumulated[[2]], + dates = dates[[1]], + params = params, + time_dim = time_dim, + leadtime_dim = leadtime_dim, + memb_dim = memb_dim, ref_period = ref_period, + handle_infinity = handle_infinity, + return_params = return_params, + method = method, distribution = distribution, + na.rm = TRUE, ncores = ncores) } else { - return(spei_res) - } -} - -.Standardization <- function(data, params = NULL, accum = 1, time_dim = 'syear', - leadtime_dim = 'time', memb_dim = 'ensemble', - ref_period = NULL, cross_validation = FALSE, - handle_infinity = FALSE, param_error = -9999, - method = 'parametric', distribution = 'log-Logistic', - na.rm = FALSE, ncores = NULL) { - - nleadtime <- dim(data)[leadtime_dim] - ntime <- dim(data)[time_dim] - - if (!cross_validation) { - ntime <- 1 - } - - coef = switch(distribution, - "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha', 'beta'))), - "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi', 'alpha', 'kappa'))), - "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu', 'sigma', 'gamma')))) - - if (is.null(params)) { - params <- array(NA, dim = c(ntime, nleadtime, length(coef))) - names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') - } else if (length(dim(params)) < 2) { - params <- array(params, dim = c(length(params), ntime, nleadtime)) - # dim(params): [time_dim, leadtime_dim, coef] - # with the values repeated each time_dim and leadtime_dim - params <- aperm(params, c(2,3,1)) - names(dim(params)) <- c(time_dim, leadtime_dim, 'coef') + spei <- accumulated[[k]] } - - spei <- Apply(data = list(data = data, params = params), - target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), - params = c(time_dim, leadtime_dim, 'coef')), - fun = .standardization, - coef = coef, - leadtime_dim = leadtime_dim, - time_dim = time_dim, memb_dim = memb_dim, - ref_period = ref_period, handle_infinity = handle_infinity, - cross_validation = cross_validation, param_error = param_error, - method = method, distribution = distribution, - na.rm = na.rm, - output_dims = list(spei = c(leadtime_dim, time_dim, memb_dim), - params = c(time_dim, leadtime_dim, 'coef')), - ncores = ncores) return(spei) -} - -.standardization <- function(data, params, coef, leadtime_dim = 'time', - time_dim = 'syear', memb_dim = 'ensemble', - ref_period = NULL, handle_infinity = FALSE, - cross_validation = FALSE, param_error = -9999, - method = 'parametric', distribution = 'log-Logistic', - na.rm = FALSE) { - # data: [leadtime_dim, time_dim, memb_dim] - # params: [time_dim, leadtime_dim, 'coef'] - - # maximum number of parameters needed to define any of the considered distributions - ncoef <- length(coef) - nleadtime <- as.numeric(dim(data)[leadtime_dim]) - ntime <- as.numeric(dim(data)[time_dim]) - nmemb <- as.numeric(dim(data)[memb_dim]) - - if (cross_validation) { - params_result <- array(data = NA, dim = c(ntime, nleadtime, ncoef)) - } else { - params_result <- array(data = NA, dim = c(1, nleadtime, ncoef)) - } - names(dim(params_result)) <- c(time_dim, leadtime_dim, 'coef') - - if (all(is.na(data))) { - spei_mod <- array(NA, dim(data)) - # if the data [time, sdate, memb] has no variability it will raise an error - # further down, so we assign a value to the result and skip the step - } else if (anyNA(data) && !na.rm) { - spei_mod <- array(NA, dim(data)) - } else if (var(data, na.rm = T) == 0) { - spei_mod <- array(param_error, dim(data)) # Add this? - } else { - if (is.null(ref_period)) { - ref.start <- NULL - ref.end <- NULL - } else { - ref.start <- ref_period[[1]] - ref.end <- ref_period[[2]] - } - - spei_mod <- array(data = NA, dim = c(nleadtime, ntime, nmemb)) - names(dim(spei_mod)) <- c(leadtime_dim, time_dim, memb_dim) - - for (ff in 1:nleadtime) { - data_subset <- ClimProjDiags::Subset(data, along = leadtime_dim, - indices = ff, drop = 'selected') - params_tmp <- if (all(is.na(params))) {NULL} else {params[, ff, ]} - - spei_data <- .std(data = data_subset, coef = coef, ntime = ntime, - nmemb = nmemb, method = method, - distribution = distribution, na.rm = na.rm, - ref.start = ref.start, ref.end = ref.end, - params = params_tmp, handle_infinity = handle_infinity, - cross_validation = cross_validation) - - spei_mod[ff, , ] <- spei_data[[1]] - params_ff <- spei_data[[2]] - # lengthen dimension coef of params_ff in case it doesn't match the - # corresponding dimension of parms_months - if (!is.null(params_ff)) { - if (length(params_ff) < ncoef) { - params_ff <- append(params_ff, array(NA, dim = ncoef - length(params_ff))) - } - params_result[, ff, ] <- params_ff - } - } - } - return(list(spei = spei_mod, params = params_result)) -} - -.std <- function(data, coef, ntime, nmemb, method = 'parametric', - distribution = 'log-Logistic', na.rm = FALSE, - ref.start = NULL, ref.end = NULL, params = NULL, - handle_infinity = FALSE, cross_validation = FALSE) { - - # data: [time_dim, memb_dim] - # params: NULL or [(ntime), coef] - - fit = 'ub-pwm' # hard-coded - - if (method == 'non-parametric') { - bp <- matrix(0, length(data), 1) - for (i in 1:length(data)) { - bp[i,1] = sum(data[] <= data[i], na.rm = na.rm); # Writes the rank of the data - } - std_index <- qnorm((bp - 0.44)/(length(data) + 0.12)) - dim(std_index) <- c(ntime, nmemb) - # it won't return params to be used in exp_cor; also it is not using - # handle_infinity nor cross_validation - params_result <- NULL - } else { - std_index <- array(NA, c(ntime, nmemb)) - # Select window if necessary - if (!is.null(ref.start) && !is.null(ref.end)) { - data.fit <- window(data, ref.start, ref.end) - } else { - data.fit <- data - } - - if (cross_validation) { - loop_years <- ntime - } else { - loop_years <- 1 - } - - params_result <- array(NA, dim = c(loop_years, length(coef))) - colnames(params_result) <- names(coef) - - for (nsd in 1:loop_years) { # loop over years (in case of cross_validation) - # Cumulative series (acu) - if (cross_validation) { - acu <- as.vector(data.fit[-nsd, ]) - } else { - acu <- as.vector(data.fit) - } - - acu.sorted <- sort.default(acu, method = "quick") - # remove NAs (no need if(na.rm) because if there are NA and na.rm = F - # we don't get to this point) - acu.sorted <- acu.sorted[!is.na(acu.sorted)] - # else all acu was NA and we don't need to continue with this case - - if (length(acu.sorted) != 0) { - acu_sd <- sd(acu.sorted) - if (!is.na(acu_sd)) { - if (acu_sd != 0) { - if (distribution != "log-Logistic") { - pze <- sum(acu == 0) / length(acu) - acu.sorted = acu.sorted[acu.sorted > 0] - } - if (!is.null(params)) { - f_params <- as.vector(params) - params_result[nsd, ] <- f_params - } else { - # else coef will be NA - if (length(acu.sorted) >= 4) { - # Calculate probability weighted moments based on fit with lmomco or TLMoments - pwm = switch(fit, - "pp-pwm" = pwm.pp(acu.sorted, -0.35, 0, nmom = 3), - pwm.ub(acu.sorted, nmom = 3) - # TLMoments::PWM(acu.sorted, order = 0:2) - ) - - # Check L-moments validity - lmom <- pwm2lmom(pwm) - if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { - # lmom fortran functions need specific inputs L1, L2, T3 - # this is handled by lmomco internally with lmorph - fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) - # Calculate parameters based on distribution with lmom then lmomco - f_params = switch(distribution, - "log-Logistic" = tryCatch(lmom::pelglo(fortran_vec), - error = function(e){parglo(lmom)$para}), - "Gamma" = tryCatch(lmom::pelgam(fortran_vec), - error = function(e){pargam(lmom)$para}), - "PearsonIII" = tryCatch(lmom::pelpe3(fortran_vec), - error = function(e){parpe3(lmom)$para})) - # Adjust if user chose log-Logistic and max-lik - if (distribution == 'log-Logistic' && fit == 'max-lik') { - f_params = parglo.maxlik(acu.sorted, f_params)$para - } - params_result[nsd, ] <- f_params - } # end for the case the L-moments are not valid (std_index will be NA) - } # end for case there are not enough values to estimate the parameters (std_index will be NA) - } # end estimation of f_param - # Calculate cdf based on distribution with lmom - if (all(is.na(params_result[nsd,]))) { - cdf_res <- NA - } else { - f_params <- params_result[nsd,] - f_params <- f_params[which(!is.na(f_params))] - cdf_res = switch(distribution, - "log-Logistic" = lmom::cdfglo(data, f_params), - "Gamma" = lmom::cdfgam(data, f_params), - "PearsonIII" = lmom::cdfpe3(data, f_params)) - } - - std_index_cv <- array(qnorm(cdf_res), dim = c(ntime, nmemb)) - - # Adjust if user chose Gamma or PearsonIII - Not tested: For future development - # if (distribution != 'log-Logistic') { - # std_index[ff,s] = qnorm(pze + (1-pze)*pnorm(std_index[ff,s])) # ff doesn't exist at this point - # } - if (cross_validation) { - std_index[nsd, ] <- std_index_cv[nsd, ] - } else { - std_index <- std_index_cv - } - } - } # end if for the case there is no variability - } # end if for the case all NA in acu - } # next year (in case of cross_validation or all done if cross_validation == F) - - if (handle_infinity) { # could also use "param_error" ?; we are giving it the min/max value of the grid point - std_index[is.infinite(std_index) & std_index < 0] <- min(std_index[!is.infinite(std_index)]) - std_index[is.infinite(std_index) & std_index > 0] <- max(std_index[!is.infinite(std_index)]) - } - # f_params will be params only if cross_validation is FALSE - # (otherwise there will be one f_params per year; - # but the output params will be read only in the case that - # it is called with cross_validation FALSE) - } - return(list(std_index, params_result)) } \ No newline at end of file diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 7967342..e8cb5b3 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -87,6 +87,7 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', + params = NULL, return_params = FALSE, na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (is.null(data)) { @@ -100,17 +101,29 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', stop("Parameter 'data_cor' must be of 's2dv_cube' class.") } } - std <- PeriodStandardization(data = data$data, data_cor = data_cor$data, + res <- PeriodStandardization(data = data$data, data_cor = data_cor$data, time_dim = time_dim, leadtime_dim = leadtime_dim, memb_dim = memb_dim, ref_period = ref_period, handle_infinity = handle_infinity, method = method, distribution = distribution, + params = params, return_params = return_params, na.rm = na.rm, ncores = ncores) + if (return_params) { + std <- res$spei + params <- res$params + } else { + std <- res + } + if (is.null(data_cor)) { data$data <- std data$attrs$Variable$varName <- paste0(data$attrs$Variable$varName, ' standardized') - return(data) + if (return_params) { + return(list(spei = data, params = params)) + } else { + return(data) + } } else { data_cor$data <- std data_cor$attrs$Variable$varName <- paste0(data_cor$attrs$Variable$varName, ' standardized') @@ -212,6 +225,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, ref_period = NULL, handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', + params = NULL, return_params = FALSE, na.rm = FALSE, ncores = NULL) { # Check inputs ## data @@ -334,6 +348,38 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "of the following distributions: 'log-Logistic', 'Gamma' or ", "'PearsonIII'.") } + ## params + if (!is.null(params)) { + if (!is.numeric(params)) { + stop("Parameter 'params' must be numeric.") + } + if (!all(c(time_dim, leadtime_dim, 'coef') %in% names(dim(params)))) { + stop("Parameter 'params' must be a multidimensional array with named ", + "dimensions: '", time_dim, "', '", leadtime_dim, "' and 'coef'.") + } + dims_data <- dim(data)[-which(names(dim(data)) == memb_dim)] + dims_params <- dim(params)[-which(names(dim(params)) == 'coef')] + if (!all(dims_data == dims_params)) { + stop("Parameter 'data' and 'params' must have same common dimensions ", + "except 'memb_dim' and 'coef'.") + } + + if (distribution == "Gamma") { + if (dim(params)['coef'] != 2) { + stop("For '", distribution, "' distribution, params array should have ", + "'coef' dimension of length 2.") + } + } else { + if (dim(params)['coef'] != 3) { + stop("For '", distribution, "' distribution, params array should have ", + "'coef' dimension of length 3.") + } + } + } + ## return_params + if (!is.logical(return_params)) { + stop("Parameter 'return_params' must be logical.") + } ## na.rm if (!is.logical(na.rm)) { stop("Parameter 'na.rm' must be logical.") @@ -346,8 +392,6 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } } - target_dims <- c(leadtime_dim, time_dim, memb_dim) - if (is.null(ref_period)) { ref_start <- NULL ref_end <- NULL @@ -358,20 +402,44 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, # Standardization if (is.null(data_cor)) { - spei <- Apply(data = list(data), - target_dims = target_dims, - fun = .standardization, - leadtime_dim = leadtime_dim, - ref_period = ref_period, handle_infinity = handle_infinity, - method = method, distribution = distribution, - na.rm = na.rm, ncores = ncores)$output1 + if (is.null(params)) { + res <- Apply(data = list(data), + target_dims = c(leadtime_dim, time_dim, memb_dim), + fun = .standardization, data_cor = NULL, params = NULL, + leadtime_dim = leadtime_dim, + ref_start = ref_start, ref_end = ref_end, + handle_infinity = handle_infinity, + method = method, distribution = distribution, + return_params = return_params, + na.rm = na.rm, ncores = ncores) + } else { + res <- Apply(data = list(data = data, params = params), + target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), + params = c(leadtime_dim, time_dim, 'coef')), + fun = .standardization, data_cor = NULL, + leadtime_dim = leadtime_dim, + ref_start = ref_start, ref_end = ref_end, + handle_infinity = handle_infinity, + method = method, distribution = distribution, + return_params = return_params, + na.rm = na.rm, ncores = ncores) + } } else { - spei <- Apply(data = list(data, data_cor), target_dims = target_dims, - fun = .standardization, - leadtime_dim = leadtime_dim, - ref_period = ref_period, handle_infinity = handle_infinity, - method = method, distribution = distribution, - na.rm = na.rm, ncores = ncores)$output1 + res <- Apply(data = list(data = data, data_cor = data_cor), + target_dims = c(leadtime_dim, time_dim, memb_dim), + fun = .standardization, + params = NULL, leadtime_dim = leadtime_dim, + ref_start = ref_start, ref_end = ref_end, + handle_infinity = handle_infinity, + method = method, distribution = distribution, + return_params = return_params, + na.rm = na.rm, ncores = ncores) + } + if (return_params) { + spei <- res$spei + params <- res$params + } else { + spei <- res$output1 } if (is.null(data_cor)) { @@ -381,14 +449,22 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, pos <- match(names(dim(data_cor)), names(dim(spei))) spei <- aperm(spei, pos) } - return(spei) + + if (return_params) { + pos <- match(c(names(dim(spei))[-which(names(dim(spei)) == memb_dim)], 'coef'), + names(dim(params))) + params <- aperm(params, pos) + return(list('spei' = spei, 'params' = params)) + } else { + return(spei) + } } -.standardization <- function(data, data_cor = NULL, leadtime_dim = 'time', - ref_period = NULL, handle_infinity = FALSE, +.standardization <- function(data, data_cor = NULL, params = NULL, leadtime_dim = 'time', + ref_start = NULL, ref_end = NULL, handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', - na.rm = FALSE) { - # data: [leadtime_dim, time_dim, memb_dim] + return_params = FALSE, na.rm = FALSE) { + # data (data_cor): [leadtime_dim, time_dim, memb_dim] dims <- dim(data)[-1] fit = 'ub-pwm' @@ -400,6 +476,9 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, if (is.null(data_cor)) { # cross_val = TRUE spei_mod <- data*NA + if (return_params) { + params_result <- array(dim = c(dim(data)[-length(dim(data))], coef = length(coef))) + } for (ff in 1:dim(data)[leadtime_dim]) { data2 <- data[ff, , ] dim(data2) <- dims @@ -418,37 +497,41 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, data_fit <- data2 } for (nsd in 1:dim(data)[time_dim]) { - acu <- as.vector(data_fit[-nsd, ]) - if (na.rm) { - acu_sorted <- sort.default(acu, method = "quick") - } else { - acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) - } - if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { - acu_sd <- sd(acu_sorted) - if (!is.na(acu_sd) & acu_sd != 0) { - if (distribution != "log-Logistic") { - acu_sorted <- acu_sorted[acu_sorted > 0] - } - if (length(acu_sorted) >= 4) { - f_params <- .std(data = acu_sorted, fit = fit, - distribution = distribution) - } else { - f_params <- NA - } - if (all(is.na(f_params))) { - cdf_res <- NA - } else { - f_params <- f_params[which(!is.na(f_params))] - cdf_res = switch(distribution, - "log-Logistic" = lmom::cdfglo(data2, f_params), - "Gamma" = lmom::cdfgam(data2, f_params), - "PearsonIII" = lmom::cdfpe3(data2, f_params)) + if (is.null(params)) { + acu <- as.vector(data_fit[-nsd, ]) + if (na.rm) { + acu_sorted <- sort.default(acu, method = "quick") + } else { + acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) + } + f_params <- NA + if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { + acu_sd <- sd(acu_sorted) + if (!is.na(acu_sd) & acu_sd != 0) { + if (distribution != "log-Logistic") { + acu_sorted <- acu_sorted[acu_sorted > 0] + } + if (length(acu_sorted) >= 4) { + f_params <- .std(data = acu_sorted, fit = fit, + distribution = distribution) + } } - std_index_cv <- array(qnorm(cdf_res), dim = dims) - spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] } + } else { + f_params <- params[ff, nsd, ] } + if (all(is.na(f_params))) { + cdf_res <- NA + } else { + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data2, f_params), + "Gamma" = lmom::cdfgam(data2, f_params), + "PearsonIII" = lmom::cdfpe3(data2, f_params)) + } + std_index_cv <- array(qnorm(cdf_res), dim = dims) + spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] + if (return_params) params_result[ff, nsd, ] <- f_params } } } @@ -456,6 +539,9 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, # cross_val = FALSE spei_mod <- data_cor*NA dimscor <- dim(data_cor)[-1] + if (return_params) { + params_result <- array(dim = c(dim(data_cor)[-length(dim(data_cor))], coef = length(coef))) + } for (ff in 1:dim(data)[leadtime_dim]) { data_cor2 <- data_cor[ff, , ] dim(data_cor2) <- dimscor @@ -502,6 +588,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } std_index_cv <- array(qnorm(cdf_res), dim = dimscor) spei_mod[ff, , ] <- std_index_cv + if (return_params) params_result[ff, , ] <- f_params } } } @@ -512,7 +599,11 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, spei_mod[is.infinite(spei_mod) & spei_mod < 0] <- min(spei_mod[!is.infinite(spei_mod)]) spei_mod[is.infinite(spei_mod) & spei_mod > 0] <- max(spei_mod[!is.infinite(spei_mod)]) } - return(spei_mod) + if (return_params) { + return(list(spei = spei_mod, params = params_result)) + } else { + return(spei_mod) + } } .std <- function(data, fit = 'pp-pwm', distribution = 'log-Logistic') { @@ -524,7 +615,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, lmom <- pwm2lmom(pwm) if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) - params = switch(distribution, + params_result = switch(distribution, 'log-Logistic' = tryCatch(lmom::pelglo(fortran_vec), error = function(e){parglo(lmom)$para}), 'Gamma' = tryCatch(lmom::pelgam(fortran_vec), @@ -532,9 +623,9 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, 'PearsonIII' = tryCatch(lmom::pelpe3(fortran_vec), error = function(e){parpe3(lmom)$para})) if (distribution == 'log-Logistic' && fit == 'max-lik') { - params = parglo.maxlik(data, params)$para + params_result = parglo.maxlik(data, params_result)$para } - return(params) + return(params_result) } else { return(NA) } diff --git a/R/zzz.R b/R/zzz.R index 47d871d..4c8d0a4 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -106,4 +106,30 @@ wind2CF <- function(wind, pc) { } else { return(list(data1, data2)) } +} + +# Function that creates a mask array from dates for the whole year +.datesmask <- function(dates, frequency = 'monthly') { + ini <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep = '-')) + end <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep = '-')) + daily <- as.Date(ini:end) + if (frequency == 'monthly') { + monthly <- daily[which(lubridate::day(daily) == 1)] + dates_mask <- array(0, dim = length(monthly)) + for (dd in 1:length(dates)) { + ii <- which(monthly == as.Date(paste(lubridate::year(dates[dd]), + lubridate::month(dates[dd]), + 01, sep = '-'))) + dates_mask[ii] <- 1 + } + } else { + # daily + dates_mask <- array(0, dim = length(daily)) + for (dd in 1:length(dates)) { + ii <- which(daily == dates[dd]) + dates_mask[ii] <- 1 + } + } + + return(dates_mask) } \ No newline at end of file diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 1500a64..c8010da 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -17,11 +17,9 @@ CST_PeriodSPEI( pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, - cross_validation = FALSE, pet_method = "hargreaves", method = "parametric", distribution = "log-Logistic", - param_error = -9999, handle_infinity = FALSE, return_params = FALSE, na.rm = FALSE, @@ -88,10 +86,6 @@ provided variables with specified 'pet_method'. It is NULL by default.} \item{standardization}{A logical value indicating wether the standardization is computed.} -\item{cross_validation}{A logical value indicating if cross validation is -done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and -is not provided. It is FALSE by default.} - \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -108,8 +102,6 @@ function to be used for computing the SPEI. The accepted names are: 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive defined (SPI indicator).} -\item{param_error}{A numeric value with the error accepted.} - \item{handle_infinity}{A logical value wether to return Infinite values (TRUE) or not (FALSE).} diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd index 3e47726..5e23bd5 100644 --- a/man/CST_PeriodStandardization.Rd +++ b/man/CST_PeriodStandardization.Rd @@ -14,6 +14,8 @@ CST_PeriodStandardization( handle_infinity = FALSE, method = "parametric", distribution = "log-Logistic", + params = NULL, + return_params = FALSE, na.rm = FALSE, ncores = NULL ) diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index 049e084..b0d039e 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -20,11 +20,9 @@ PeriodSPEI( pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, - cross_validation = FALSE, pet_method = "hargreaves", method = "parametric", distribution = "log-Logistic", - param_error = -9999, handle_infinity = FALSE, return_params = FALSE, na.rm = FALSE, @@ -98,10 +96,6 @@ provided variables with specified 'pet_method'. It is NULL by default.} \item{standardization}{A logical value indicating wether the standardization is computed.} -\item{cross_validation}{A logical value indicating if cross validation is -done (TRUE), or not (FALSE). It only will be used when 'exp_cor' and -is not provided. It is FALSE by default.} - \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -117,8 +111,6 @@ function to be used for computing the SPEI. The accepted names are: 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive defined (SPI indicator).} -\item{param_error}{A numeric value with the error accepted.} - \item{handle_infinity}{A logical value wether to return Infinite values (TRUE) or not (FALSE).} diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd index 9a0ab2b..98b8ba6 100644 --- a/man/PeriodStandardization.Rd +++ b/man/PeriodStandardization.Rd @@ -15,6 +15,8 @@ PeriodStandardization( handle_infinity = FALSE, method = "parametric", distribution = "log-Logistic", + params = NULL, + return_params = FALSE, na.rm = FALSE, ncores = NULL ) diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 2f1d7b0..23f7316 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -49,6 +49,8 @@ exp1 <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) exp_cor1 <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, 'pr' = expcor_pr) params1 <- array(abs(rnorm(100)), dim = c(syear = 1, time = 3, latitude = 2, longitude = 1, coef = 3)) +params2 <- array(abs(rnorm(100)), dim = c(syear = 6, time = 3, latitude = 2, + longitude = 1, coef = 3)) # dat2 dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) @@ -264,21 +266,11 @@ test_that("1. Initial checks PeriodSPEI", { PeriodSPEI(exp = exp1, standardization = 10, dates_exp = dates_exp, lat = lat), "Parameter 'standardization' must be a logical value." ) - # param_error - expect_error( - PeriodSPEI(exp = exp1, param_error = TRUE, dates_exp = dates_exp, lat = lat), - "Parameter 'param_error' must be a numeric value." - ) # handle_infinity expect_error( PeriodSPEI(exp = exp1, handle_infinity = 1, dates_exp = dates_exp, lat = lat), "Parameter 'handle_infinity' must be a logical value." ) - # cross_validation - expect_error( - PeriodSPEI(exp = exp1, cross_validation = 1, dates_exp = dates_exp, lat = lat), - "Parameter 'cross_validation' must be a logical value." - ) # method expect_error( PeriodSPEI(exp = exp1, method = 1, dates_exp = dates_exp, lat = lat), @@ -366,7 +358,7 @@ test_that("2. Output checks", { ) expect_equal( dim(res3[[2]]), - c(syear = 1, time = 3, coef = 3, latitude = 2, longitude = 1) + c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) ) # exp # exp_cor @@ -380,16 +372,22 @@ test_that("2. Output checks", { # tolerance = 0.0001 # ) # ref_period - res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, - dates_exp = dates_exp, dates_expcor = dates_expcor, - na.rm = TRUE, ref_period = list(2011, 2013)) + # res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, + # dates_exp = dates_exp, dates_expcor = dates_expcor, + # na.rm = TRUE, ref_period = list(2011, 2013)) expect_equal( !identical(res1[[1]], res_ref), TRUE ) # params - res5 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - params = params1, return_params = TRUE) + expect_error( + PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + params = params1, return_params = TRUE), + paste0("Parameter 'data' and 'params' must have same common dimensions ", + "except 'memb_dim' and 'coef'.") + ) + res6 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, + params = params2, return_params = TRUE) expect_error( PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, params = array(abs(rnorm(100)), dim = dimscor)), @@ -397,8 +395,8 @@ test_that("2. Output checks", { "dimensions: 'syear', 'time' and 'coef'.") ) expect_equal( - dim(res5$params), - c(syear = 1, time = 3, coef = 3, latitude = 2, longitude = 1) + dim(res6$params), + c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) ) # standarization res4 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, @@ -412,17 +410,10 @@ test_that("2. Output checks", { c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) ) # cross_validation - expect_warning( - PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - cross_validation = TRUE), - paste0("Detected 'cross_validation' = TRUE. It will be set as FALSE ", - "since 'exp_cor' is provided.") - ) res_crossval_T <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - cross_validation = TRUE, return_params = TRUE) + return_params = TRUE) res_crossval_F <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - cross_validation = FALSE, return_params = TRUE) + return_params = TRUE) # cross_validation = TRUE expect_equal( dim(res_crossval_T$spei), @@ -430,13 +421,13 @@ test_that("2. Output checks", { ) expect_equal( dim(res_crossval_T$params), - c(syear = 6, time = 3, coef = 3, latitude = 2, longitude = 1) + c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) ) # cross_validation = FALSE - expect_equal( - dim(res_crossval_F$params)[-which(names(dim(res_crossval_F$params)) == 'coef')], - dimscor[-which(names(dimscor) == 'ensemble')] - ) + # expect_equal( + # dim(res_crossval_F$params)[-which(names(dim(res_crossval_F$params)) == 'coef')], + # dimscor[-which(names(dimscor) == 'ensemble')] + # ) # pet_method - ok res5 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, diff --git a/tests/testthat/test-PeriodStandardization.R b/tests/testthat/test-PeriodStandardization.R index c8620a4..7673db2 100644 --- a/tests/testthat/test-PeriodStandardization.R +++ b/tests/testthat/test-PeriodStandardization.R @@ -210,12 +210,6 @@ test_that("2. Output checks", { ) # na.rm dat1[1,1,1,1] <- NA - expect_equal( - PeriodStandardization(data = dat1, na.rm = FALSE)[,,1,1], - array(c(rep(NA, 6), 0.4493183, 0.6592255, 0.4635960, -0.4217912, - 1.4006941, 0.3011019), dim = c(syear = 6, time = 2)), - tolerance = 0.0001 - ) expect_equal( all(is.na(PeriodStandardization(data = dat1, na.rm = FALSE)[,1,1,1])), TRUE -- GitLab From f47d93253b70eb2d9fe9568917a44a677fbd6a33 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 19 Sep 2023 11:40:37 +0200 Subject: [PATCH 58/87] Improve documentation of PeriodStandardization, PeriodAccumulation, PeriodSPEI and PeriodPET; correct few errors in the code --- R/PeriodAccumulation.R | 52 ++-- R/PeriodPET.R | 48 ++-- R/PeriodSPEI.R | 305 ++++++----------------- R/PeriodStandardization.R | 55 ++-- man/CST_PeriodAccumulation.Rd | 26 +- man/CST_PeriodPET.Rd | 21 +- man/CST_PeriodSPEI.Rd | 76 +++--- man/CST_PeriodStandardization.Rd | 31 ++- man/PeriodAccumulation.Rd | 17 +- man/PeriodPET.Rd | 25 +- man/PeriodSPEI.Rd | 58 ++--- man/PeriodStandardization.Rd | 27 +- tests/testthat/test-PeriodAccumulation.R | 23 +- tests/testthat/test-PeriodSPEI.R | 23 +- 14 files changed, 351 insertions(+), 436 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 73877e9..91220f6 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -12,10 +12,13 @@ #' #'There are two possible ways of performing the accumulation. The default one #'is by accumulating a variable over a dimension specified with 'time_dim'. To -#'chose a specific time period, start and end must be used. The other method -#'is by using rollwidth parameter. When this parameter is a positive integer, -#'the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum -#'is applied towards 'time_dim'. +#'chose a specific time period, 'start' and 'end' must be used. The other method +#'is by using 'rollwidth' parameter. When this parameter is a positive integer, +#'the cumulative backward sum is applied to the time dimension. If it is +#'negative, the rolling sum is applied backwards. This function is build to work +#'be compatible with other tools in that work with 's2dv_cube' object class. The +#'input data must be this object class. If you don't work with 's2dv_cube', see +#'PeriodAccumulation. #' #'@param data An 's2dv_cube' object as provided function \code{CST_Load} in #' package CSTools. @@ -33,8 +36,8 @@ #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param rollwidth An optional parameter to indicate the number of time -#' steps the rolling sum is applied to. If it is negative, the rolling sum is -#' applied backwards 'time_dim', if it is positive, it will be towards it. When +#' steps the rolling sum is applied to. If it is positive, the rolling sum is +#' applied backwards 'time_dim', if it is negative, it will be forward it. When #' this parameter is NULL, the sum is applied over all 'time_dim', in a #' specified period. It is NULL by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -42,15 +45,16 @@ #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' -#'@return An 's2dv_cube' object containing the indicator in the element -#'\code{data}. If 'rollingwithd' is not used, it will have the dimensions of -#'the input parameter 'data' except the dimension where the accumulation has -#'been computed (specified with 'time_dim'). The 'Dates' array is updated to the +#'@return An 's2dv_cube' object containing the accumulated data in the element +#'\code{data}. If parameter 'rollwidth' is not used, it will have the dimensions +#'of the input parameter 'data' except the dimension where the accumulation has +#'been computed (specified with 'time_dim'). If 'rollwidth' is used, it will be +#'of same dimensions as input data. The 'Dates' array is updated to the #'dates corresponding to the beginning of the aggregated time period. A new #'element called 'time_bounds' will be added into the 'attrs' element in the #''s2dv_cube' object. It consists of a list containing two elements, the start #'and end dates of the aggregated period with the same dimensions of 'Dates' -#'element. If 'rollingwithd' is used, it will contain the same dimensions of +#'element. If 'rollwidth' is used, it will contain the same dimensions of #'parameter 'data' and the other elements of the 's2dv_cube' will not be #'modified. #' @@ -143,10 +147,10 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' #'There are two possible ways of performing the accumulation. The default one #'is by accumulating a variable over a dimension specified with 'time_dim'. To -#'chose a specific time period, start and end must be used. The other method -#'is by using rollwidth parameter. When this parameter is a positive integer, -#'the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum -#'is applied towards 'time_dim'. +#'chose a specific time period, 'start' and 'end' must be used. The other method +#'is by using 'rollwidth' parameter. When this parameter is a positive integer, +#'the cumulative backward sum is applied to the time dimension. If it is +#'negative, the rolling sum is applied backwards. #' #'@param data A multidimensional array with named dimensions. #'@param dates A multidimensional array of dates with named dimensions matching @@ -166,8 +170,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param rollwidth An optional parameter to indicate the number of time -#' steps the rolling sum is applied to. If it is negative, the rolling sum is -#' applied backwards 'time_dim', if it is positive, it will be towards it. When +#' steps the rolling sum is applied to. If it is positive, the rolling sum is +#' applied backwards 'time_dim', if it is negative, it will be forward it. When #' this parameter is NULL, the sum is applied over all 'time_dim', in a #' specified period. It is NULL by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -176,7 +180,10 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' computation. #' #'@return A multidimensional array with named dimensions containing the -#'indicator in the element \code{data}. +#'accumulated data in the element \code{data}. If parameter 'rollwidth' is +#'not used, it will have the dimensions of the input 'data' except the dimension +#'where the accumulation has been computed (specified with 'time_dim'). If +#''rollwidth' is used, it will be of same dimensions as input data. #' #'@examples #'exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, @@ -235,7 +242,11 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, } if (!is.null(dim(dates))) { data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + time_dim = time_dim, ncores = ncores) + if (!is.null(rollwidth)) { + dates <- SelectPeriodOnDates(dates = dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } } else { warning("Parameter 'dates' must have named dimensions if 'start' and ", "'end' are not NULL. All data will be used.") @@ -297,10 +308,11 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, return(total) } +data <- array(c(1,3,2,4), dim = c(time = 2, sdate = 2)) + .rollaccumulation <- function(data, mask_dates, rollwidth = 1, forwardroll = FALSE, na.rm = FALSE) { dims <- dim(data) - data_vector <- array(NA, dim = length(mask_dates)) count <- 1 for (dd in 1:length(mask_dates)) { diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 5f6054a..9fdb7e2 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -12,14 +12,17 @@ #'CST_PeriodAccumulation. #' #'@param data A named list with the needed \code{s2dv_cube} objects containing -#' the seasonal forecast experiment in the data element for each variable. +#' the seasonal forecast experiment in the 'data' element for each variable. #' Specific variables are needed for each method used in computing the -#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for -#' 'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' -#' 'tmean' is required. The units for temperature variables -#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -#' precipitation ('pr') need to be in mm/month. +#' Potential Evapotranspiration (see parameter 'pet_method'). The accepted +#' variable names are fixed in order to be recognized by the function. +#' The accepted name corresponding to the Minimum Temperature is 'tmin', +#' for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +#' for Precipitation is 'pr'. The accepted variable names for each method are: +#' For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +#' 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +#' for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +#' degrees; the units for precipitation ('pr') need to be in mm/month. #'@param dates An array of temporal dimensions containing the Dates of #' 'data'. It must be of class 'Date' or 'POSIXct'. #'@param lat A numeric vector containing the latitude values of 'data'. @@ -41,7 +44,6 @@ #' #'@examples #'dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) -#' #'exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) #'exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) #'exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) @@ -50,11 +52,8 @@ #' paste0(2010:end_year, "-09-15"), #' paste0(2010:end_year, "-10-16")), "UTC") #'dim(dates_exp) <- c(syear = 3, time = 3) -#' #'lat <- c(40) -#' #'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -#' #'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) #' #'@import SPEI @@ -111,7 +110,7 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #'Compute the Potential Evapotranspiration #' -#'Compute the Potential evapotranspiration (PET) that is the amount of +#'Compute the Potential Evapotranspiration (PET) that is the amount of #'evaporation and transpiration that would occur if a sufficient water source #'were available. This function calculate PET according to the Thornthwaite, #'Hargreaves or Hargreaves-modified equations. @@ -119,15 +118,18 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #'For more information on the SPEI calculation, see functions #'PeriodStandardization and PeriodAccumulation. #' -#'@param data A named list with the needed \code{s2dv_cube} objects containing -#' the seasonal forecast experiment in the data element for each variable. +#'@param data A named list of multidimensional arrays containing +#' the seasonal forecast experiment data for each variable. #' Specific variables are needed for each method used in computing the -#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for -#' 'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' -#' 'tmean' is required. The units for temperature variables -#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -#' precipitation ('pr') need to be in mm/month. +#' Potential Evapotranspiration (see parameter 'pet_method'). The accepted +#' variable names are fixed in order to be recognized by the function. +#' The accepted name corresponding to the Minimum Temperature is 'tmin', +#' for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +#' for Precipitation is 'pr'. The accepted variable names for each method are: +#' For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +#' 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +#' for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +#' degrees; the units for precipitation ('pr') need to be in mm/month. #'@param dates An array of temporal dimensions containing the Dates of #' 'data'. It must be of class 'Date' or 'POSIXct'. #'@param lat A numeric vector containing the latitude values of 'data'. @@ -149,7 +151,6 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #' #'@examples #'dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) -#' #'exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) #'exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) #'exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) @@ -158,11 +159,8 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #' paste0(2010:end_year, "-09-15"), #' paste0(2010:end_year, "-10-16")), "UTC") #'dim(dates_exp) <- c(syear = 3, time = 3) -#' #'lat <- c(40) -#' #'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) -#' #'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) #' #'@import SPEI @@ -175,7 +173,7 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', ncores = NULL) { # Initial checks - ## data + # data if (!inherits(data, 'list')) { stop("Parameter 'data' needs to be a named list with the needed variables.") } diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index aeed5c7..442209f 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -3,40 +3,43 @@ #'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) #'that is a multiscalar drought index based on climatic data. It can be used for #'determining the onset, duration and magnitude of drought conditions with -#'respect to normal conditions in a variety of natural and managed systems such -#'as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI -#'is to compare the highest possible evapotranspiration with the current water -#'availability. The SPEI uses the monthly (or weekly) difference between -#'precipitation and potential evapotranspiration. This represents a simple -#'climatic water balance which is calculated at different time scales to obtain -#'the SPEI. This function is build to work be compatible with other tools in -#'that work with 's2dv_cube' object class. The input data must be this object -#'class. If you don't work with 's2dv_cube', see PeriodSPEI. +#'respect to normal conditions. The idea behind the SPEI is to compare the +#'highest possible evapotranspiration with the current water availability. The +#'SPEI uses for a specific time frequency the difference between precipitation +#'and potential evapotranspiration. This represents a simple climatic water +#'balance which is calculated at different time scales to obtain the SPEI. This +#'function is build to work be compatible with other tools in that work with +#''s2dv_cube' object class. The input data must be this object class. If you +#'don't work with 's2dv_cube', see PeriodSPEI. #' #'Next, some specifications for the calculation of this indicator will be -#'discussed. On the one hand, the model to be used to calculate potential -#'evapotranspiration is specified with the pet_method parameter (hargreaves, -#'hargraves modified or thornwhite). On the other hand, to choose the time scale -#'in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the -#'accum parameter, where you must indicate the number of time steps you want to -#'accumulate throughout leadtime_dim. Since the accumulation is done for the +#'discussed. On the one hand, the model to be used to calculate Potential +#'Evapotranspiration is specified with the 'pet_method' parameter (it can be +#'hargreaves, hargraves modified or thornwhite). On the other hand, to choose +#'the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is +#'done using the 'accum' parameter, where you must indicate the number of time +#'steps you want to accumulate throughout 'leadtime_dim'. The accumulation will +#'be performed backwards by default. Since the accumulation is done for the #'elapsed time steps, there will be no complete accumulations until reaching the -#'time instant equal to the value of the parameter. For this reason, in the -#'result, we will find that for the dimension where the accumulation has been -#'carried out, the values of the array will be NA since they do not include +#'time instant equal to the value of the 'accum' parameter. For this reason, in +#'the result, we will find that for the dimension where the accumulation has +#'been carried out, the values of the array will be NA since they do not include #'complete accumulations. Also, there is a parameter to specify if the #'standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a #'probability distribution to transform the original values to standardized #'units that are comparable in space and time and at different SPEI time scales. -#'The na.rm parameter is a logical parameter used to decide whether to remove +#'The 'na.rm' parameter is a logical parameter used to decide whether to remove #'the NA values from the data before doing the calculation. It must be taken -#'into account that if na.rm == FALSE and there is some NA value in the specific -#'coordinates which the SPEI is computed, standardization cannot be carried out -#'for those coordinates and therefore, the result will be filled with NA for the -#'specific coordinates. However, when na.rm == TRUE, if the amount of data for -#'those specific coordinates is smaller than 4, it will not be possible to carry -#'out because we will not have enough data and the result will be also filled -#'with NAs for that coordinates. +#'into account that if 'na.rm' is FALSE and there is some NA value in the +#'specific coordinates which the SPEI is computed, standardization cannot be +#'carried out for those coordinates and therefore, the result will be filled +#'with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the +#'amount of data for those specific coordinates is smaller than 4, it will not +#'be possible to carry out because we will not have enough data and the result +#'will be also filled with NAs for that coordinates. When only 'exp' is provided +#'the Standardization is computed with 'cross_validation'. For more information +#'about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation +#'and CST_PeriodStandardization. #' #'@param exp A named list with the needed \code{s2dv_cube} objects containing #' the seasonal forecast experiment in the data element for each variable. @@ -61,8 +64,9 @@ #' dimension. By default it is set by 'latitude'. #'@param accum An integer value indicating the number of months for the #' accumulation for each variable. When it is greater than 1, the result will -#' be filled with NA until the accum time_dim dimension number due to the -#' accumulation to previous months. +#' be filled with NA until the accum 'time_dim' dimension number due to the +#' accumulation to previous months. The accumulation is performed backwards +#' by default. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be @@ -111,14 +115,14 @@ #' parallel computation. #' #'@return An 's2dv_cube' object containing the SPEI multidimensional array in -#'element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' -#'will be provided. The parameters of the standardization will only be returned -#'if 'return_params' is TRUE. The SPEI will only be computed if -#''standardization' is TRUE. If 'standardization' is FALSE, only the climatic -#'water balance (precipitation minus evapotranspiration) will be returned. The -#'resultant arrays will have the same dimensions as the initial input data. The -#'other elements in the 's2dv_cube' will be updated with the combined -#'information of the input data arrays. +#'element \code{data} with same dimensions as input data. If 'exp_cor' is +#'provided, only results from 'exp_cor' will be provided. The parameters of the +#'standardization will only be returned if 'return_params' is TRUE. The SPEI +#'will only be computed if 'standardization' is TRUE. If 'standardization' is +#'FALSE, only the climatic water balance (precipitation minus +#'evapotranspiration) will be returned. The resultant arrays will have the same +#'dimensions as the initial input data. The other elements in the 's2dv_cube' +#'will be updated with the combined information of the input data arrays. #' #'@examples #'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, @@ -160,21 +164,17 @@ #'@import zoo #'@import TLMoments #'@import lmomco -#'@import lmom #'@import lubridate #'@import CSTools #'@export -CST_PeriodSPEI <- function(exp, exp_cor = NULL, - time_dim = 'syear', leadtime_dim = 'time', - memb_dim = 'ensemble', lat_dim = 'latitude', - accum = 1, ref_period = NULL, params = NULL, - pet_exp = NULL, pet_expcor = NULL, - standardization = TRUE, - pet_method = 'hargreaves', method = 'parametric', - distribution = 'log-Logistic', - handle_infinity = FALSE, - return_params = FALSE, na.rm = FALSE, - ncores = NULL) { +CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', + leadtime_dim = 'time', memb_dim = 'ensemble', + lat_dim = 'latitude', accum = 1, ref_period = NULL, + params = NULL, pet_exp = NULL, pet_expcor = NULL, + standardization = TRUE, pet_method = 'hargreaves', + method = 'parametric', distribution = 'log-Logistic', + handle_infinity = FALSE, return_params = FALSE, + na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (is.null(exp)) { @@ -281,38 +281,39 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) #'that is a multiscalar drought index based on climatic data. It can be used for #'determining the onset, duration and magnitude of drought conditions with -#'respect to normal conditions in a variety of natural and managed systems such -#'as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI -#'is to compare the highest possible evapotranspiration with the current water -#'availability. The SPEI uses the monthly (or weekly) difference between -#'precipitation and potential evapotranspiration. This represents a simple -#'climatic water balance which is calculated at different time scales to obtain -#'the SPEI. +#'respect to normal conditions. The idea behind the SPEI is to compare the +#'highest possible evapotranspiration with the current water availability. The +#'SPEI uses for a specific time frequency the difference between precipitation +#'and potential evapotranspiration. #' #'Next, some specifications for the calculation of this indicator will be -#'discussed. On the one hand, the model to be used to calculate potential -#'evapotranspiration is specified with the pet_method parameter (hargreaves, -#'hargraves modified or thornwhite). On the other hand, to choose the time scale -#'in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the -#'accum parameter, where you must indicate the number of time steps you want to -#'accumulate throughout leadtime_dim. Since the accumulation is done for the +#'discussed. On the one hand, the model to be used to calculate Potential +#'Evapotranspiration is specified with the 'pet_method' parameter (it can be +#'hargreaves, hargraves modified or thornwhite). On the other hand, to choose +#'the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is +#'done using the 'accum' parameter, where you must indicate the number of time +#'steps you want to accumulate throughout 'leadtime_dim'. The accumulation will +#'be performed backwards by default. Since the accumulation is done for the #'elapsed time steps, there will be no complete accumulations until reaching the -#'time instant equal to the value of the parameter. For this reason, in the -#'result, we will find that for the dimension where the accumulation has been -#'carried out, the values of the array will be NA since they do not include +#'time instant equal to the value of the 'accum' parameter. For this reason, in +#'the result, we will find that for the dimension where the accumulation has +#'been carried out, the values of the array will be NA since they do not include #'complete accumulations. Also, there is a parameter to specify if the #'standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a #'probability distribution to transform the original values to standardized #'units that are comparable in space and time and at different SPEI time scales. -#'The na.rm parameter is a logical parameter used to decide whether to remove +#'The 'na.rm' parameter is a logical parameter used to decide whether to remove #'the NA values from the data before doing the calculation. It must be taken -#'into account that if na.rm == FALSE and there is some NA value in the specific -#'coordinates which the SPEI is computed, standardization cannot be carried out -#'for those coordinates and therefore, the result will be filled with NA for the -#'specific coordinates. However, when na.rm == TRUE, if the amount of data for -#'those specific coordinates is smaller than 4, it will not be possible to carry -#'out because we will not have enough data and the result will be also filled -#'with NAs for that coordinates. +#'into account that if 'na.rm' is FALSE and there is some NA value in the +#'specific coordinates which the SPEI is computed, standardization cannot be +#'carried out for those coordinates and therefore, the result will be filled +#'with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the +#'amount of data for those specific coordinates is smaller than 4, it will not +#'be possible to carry out because we will not have enough data and the result +#'will be also filled with NAs for that coordinates. When only 'exp' is provided +#'the Standardization is computed with 'cross_validation'. For more information +#'about SPEI calculation, see functions PeriodPET, PeriodAccumulation and +#'PeriodStandardization. #' #'@param exp A named list with multidimensional array objects containing #' the seasonal forecast experiment in the data element for each variable. @@ -343,7 +344,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'@param accum accum An integer value indicating the number of months for the #' accumulation for each variable. When it is greater than 1, the result will #' be filled with NA until the accum time_dim dimension number due to the -#' accumulation to previous months. +#' accumulation to previous months. The accumulation is performed backwards +#' by default. #'@param ref_period A list with two numeric values with the starting and end #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be @@ -391,9 +393,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'@param ncores An integer value indicating the number of cores to use in #' parallel computation. #' -#'@return An 's2dv_cube' object containing the SPEI multidimensional array in -#'element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' -#'will be provided. The parameters of the standardization will only be returned +#'@return A multidimensional array containing the SPEI with same dimensions as +#'input data. If 'exp_cor' is provided, only results from 'exp_cor' will be +#'provided. The parameters of the standardization will only be returned #'if 'return_params' is TRUE. The SPEI will only be computed if #''standardization' is TRUE. If 'standardization' is FALSE, only the climatic #'water balance (precipitation minus evapotranspiration) will be returned. The @@ -428,25 +430,14 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, #'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, #' dates_exp = dates_exp, dates_expcor = dates_expcor) #' -#'@import multiApply -#'@import ClimProjDiags -#'@import SPEI -#'@import zoo -#'@import TLMoments -#'@import lmomco -#'@import lmom -#'@import lubridate #'@export -PeriodSPEI <- function(exp, dates_exp, lat, - exp_cor = NULL, dates_expcor = NULL, +PeriodSPEI <- function(exp, dates_exp, lat, exp_cor = NULL, dates_expcor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', lat_dim = 'latitude', accum = 1, ref_period = NULL, params = NULL, - pet_exp = NULL, pet_expcor = NULL, - standardization = TRUE, + pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, pet_method = 'hargreaves', method = 'parametric', - distribution = 'log-Logistic', - handle_infinity = FALSE, + distribution = 'log-Logistic', handle_infinity = FALSE, return_params = FALSE, na.rm = FALSE, ncores = NULL) { # Initial checks @@ -501,46 +492,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, pet_method <- rep(pet_method, 2) } } - - ## pet_exp - if (!is.null(pet_exp)) { - if (length(dim(exp[['pr']])) != length(dim(pet_exp))) { - stop("Parameter 'pet_exp' must have the same length of all the ", - "dimensions as variable 'pr' in 'exp'.") - } - if (!all(dim(exp[['pr']]) %in% dim(pet_exp))) { - stop("Parameter 'pet_exp' must have the same length of all the ", - "dimensions as variable 'pr' in 'exp'.") - } - if (any(names(dim(exp[['pr']])) != names(dim(pet_exp)))) { - pos <- match(names(dim(exp[['pr']])), names(dim(pet_exp))) - pet_exp <- aperm(pet_exp, pos) - } - pet[[1]] <- pet_exp - } else if (is.null(dates_exp)) { - stop("Parameter 'dates_exp' must be provided.") - } - ## pet_expcor - if (!is.null(exp_cor)) { - if (!is.null(pet_expcor)) { - if (length(dim(exp_cor[['pr']])) != length(dim(pet_expcor))) { - stop("Parameter 'pet_expcor' must have the same length of all the ", - "dimensions as variable 'pr' in 'exp_cor'.") - } - if (!all(dim(exp_cor[['pr']]) %in% dim(pet_expcor))) { - stop("Parameter 'pet_expcor' must have the same length of all the ", - "dimensions as variable 'pr' in 'exp_cor'.") - } - if (any(names(dim(exp_cor[['pr']])) != names(dim(pet_expcor)))) { - pos <- match(names(dim(exp_cor[['pr']])), names(dim(pet_expcor))) - pet_expcor <- aperm(pet_expcor, pos) - } - pet[[2]] <- pet_expcor - } else if (is.null(dates_expcor)) { - stop("Parameter 'dates_expcor' must be provided.") - } - } - ## time_dim if (!is.character(time_dim) | length(time_dim) != 1) { stop("Parameter 'time_dim' must be a character string.") @@ -577,7 +528,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'memb_dim' is not found in 'exp_cor' dimension.") } } - ## lat_dim if (!is.character(lat_dim) | length(lat_dim) != 1) { stop("Parameter 'lat_dim' must be a character string.") @@ -590,7 +540,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'lat_dim' is not found in 'exp_cor' dimension.") } } - ## dates if (is.null(dates_exp)) { stop("Parameter 'dates_exp' is missing, dates must be provided.") @@ -608,7 +557,6 @@ PeriodSPEI <- function(exp, dates_exp, lat, stop("Parameter 'dates_exp' needs to have the same length as 'time_dim' ", "and 'leadtime_dim' as 'exp'.") } - if (!is.null(exp_cor)) { if (is.null(dates_expcor)) { stop("Parameter 'dates_expcor' is missing, dates for 'exp_cor' must be ", @@ -628,107 +576,20 @@ PeriodSPEI <- function(exp, dates_exp, lat, "'time_dim' and 'leadtime_dim' as 'exp_cor'.") } } - ## accum if (accum > dim(exp[[1]])[leadtime_dim]) { stop(paste0("Cannot compute accumulation of ", accum, " months because ", "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) } - - ## ref_period - if (!is.null(ref_period)) { - if (length(ref_period) != 2) { - warning("Parameter 'ref_period' must be of length two indicating the ", - "first and end years of the reference period. It will not ", - "be used.") - ref_period <- NULL - } else if (!all(sapply(ref_period, is.numeric))) { - warning("Parameter 'ref_period' must be a numeric vector indicating the ", - "'start' and 'end' years of the reference period. It will not ", - "be used.") - ref_period <- NULL - } else if (ref_period[[1]] > ref_period[[2]]) { - warning("In parameter 'ref_period' 'start' cannot be after 'end'. It ", - "will not be used.") - ref_period <- NULL - } else if (!all(unlist(ref_period) %in% year(dates_exp))) { - warning("Parameter 'ref_period' contain years outside the dates. ", - "It will not be used.") - ref_period <- NULL - } else { - years <- year(ClimProjDiags::Subset(dates_exp, along = leadtime_dim, - indices = 1)) - ref_period[[1]] <- which(ref_period[[1]] == years) - ref_period[[2]] <- which(ref_period[[2]] == years) - } - } - ## standardization if (!is.logical(standardization)) { stop("Parameter 'standardization' must be a logical value.") } - - ## handle_infinity - if (!is.logical(handle_infinity)) { - stop("Parameter 'handle_infinity' must be a logical value.") - } - - ## method - if (!(method %in% c('parametric', 'non-parametric'))) { - stop("Parameter 'method' must be a character string containing one of ", - "the following methods: 'parametric' or 'non-parametric'.") - } - - ## distribution - if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { - stop("Parameter 'distribution' must be a character string containing one ", - "of the following distributions: 'log-Logistic', 'Gamma' or ", - "'PearsonIII'.") - } - ## ncores - if (!is.null(ncores)) { - if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | - length(ncores) > 1) { - stop("Parameter 'ncores' must be a positive integer.") - } - } - ## na.rm if (!is.logical(na.rm)) { stop("Parameter 'na.rm' must be logical.") } - - ## params - if (!is.null(params)) { - if (!is.numeric(params)) { - stop("Parameter 'params' must be numeric.") - } - if (!all(c(time_dim, leadtime_dim, 'coef') %in% names(dim(params)))) { - stop("Parameter 'params' must be a multidimensional array with named ", - "dimensions: '", time_dim, "', '", leadtime_dim, "' and 'coef'.") - } - if (distribution == "Gamma") { - if (dim(params)['coef'] != 2) { - stop("For '", distribution, "' distribution, params array should have ", - "'coef' dimension of length 2.") - } - } else { - if (dim(params)['coef'] != 3) { - stop("For '", distribution, "' distribution, params array should have ", - "'coef' dimension of length 3.") - } - } - if (!is.null(exp_cor)) { - warning("'Parameter 'exp_cor' is provided, 'params' will be set to NULL.") - params <- NULL - } - } - - ## return_params - if (!is.logical(return_params)) { - stop("Parameter 'return_params' must be logical.") - } - + # Complete dates dates <- .return2list(dates_exp, dates_expcor) @@ -747,7 +608,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) computed_pet <- TRUE } - if (any(is.na(pet[[k]]))) { + if (!na.rm & any(is.na(pet[[k]]))) { mask_na <- which(is.na(pet[[k]])) warning("There are NAs in PET.") } diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index e8cb5b3..d95127d 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -6,15 +6,8 @@ #'standardized units that are comparable in space and time and at different SPEI #'time scales. #' -#'Next, some specifications for the calculation of this indicator will be -#'discussed. To choose the time scale in which you want to accumulate the SPEI -#'(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to -#'be performed in the previous step. However, since the accumulation is done for -#'the elapsed time steps, there will be no complete accumulations until reaching -#'the time instant equal to the value of the parameter. For this reason, in the -#'result, we will find that for the dimension where the accumulation has been -#'carried out, the values of the array will be NA since they do not include -#'complete accumulations. If there are NAs in the data and they are not removed with the +#'Next, some specifications for the calculation of the standardization will be +#'discussed. If there are NAs in the data and they are not removed with the #'parameter 'na.rm', the standardization cannot be carried out for those #'coordinates and therefore, the result will be filled with NA for the #'specific coordinates. When NAs are not removed, if the length of the data for @@ -23,8 +16,7 @@ #'About the distribution used to fit the data, there are only two possibilities: #''log-logistic' and 'Gamma'. The 'Gamma' method only works when only #'precipitation is provided and other variables are 0 because it is positive -#'defined (SPI indicator). For more information about SPEI, see functions -#'PeriodPET and PeriodAccumulation. This function is build to work be compatible +#'defined (SPI indicator). This function is build to work be compatible #'with other tools in that work with 's2dv_cube' object class. The input data #'must be this object class. If you don't work with 's2dv_cube', see #'PeriodStandardization. For more information on the SPEI indicator calculation, @@ -46,6 +38,14 @@ #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be #' used as starting and end points. +#'@param params An optional parameter that needs to be a multidimensional array +#' with named dimensions. This option overrides computation of fitting +#' parameters. It needs to be of same time dimensions (specified in 'time_dim' +#' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +#' of the coefficients needed for the used distribution (for 'Gamma' coef +#' dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length +#' 3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') +#' of length 1. It will only be used if 'data_cor' is not provided. #'@param handle_infinity A logical value wether to return infinite values (TRUE) #' or not (FALSE). When it is TRUE, the positive infinite values (negative #' infinite) are substituted by the maximum (minimum) values of each @@ -59,6 +59,8 @@ #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other #' variables are 0 because it is positive defined (SPI indicator). +#'@param return_params A logical value indicating wether to return parameters +#' array (TRUE) or not (FALSE). It is FALSE by default. #'@param na.rm A logical value indicating whether NA values should be removed #' from data. It is FALSE by default. If it is FALSE and there are NA values, #' standardization cannot be carried out for those coordinates and therefore, @@ -72,7 +74,10 @@ #'@return An object of class \code{s2dv_cube} containing the standardized data. #'If 'data_cor' is provided the array stored in element data will be of the same #'dimensions as 'data_cor'. If 'data_cor' is not provided, the array stored in -#'element data will be of the same dimensions as 'data'. +#'element data will be of the same dimensions as 'data'. The parameters of the +#'standardization will only be returned if 'return_params' is TRUE, in this +#'case, the output will be a list of two objects one for the standardized data +#'and one for the parameters. #' #'@examples #'dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) @@ -140,15 +145,8 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'transform the original values to standardized units that are comparable in #'space and time and at different SPEI time scales. #' -#'Next, some specifications for the calculation of this indicator will be -#'discussed. To choose the time scale in which you want to accumulate the SPEI -#'(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to -#'be performed in the previous step. However, since the accumulation is done for -#'the elapsed time steps, there will be no complete accumulations until reaching -#'the time instant equal to the value of the parameter. For this reason, in the -#'result, we will find that for the dimension where the accumulation has been -#'carried out, the values of the array will be NA since they do not include -#'complete accumulations. If there are NAs in the data and they are not removed with the +#'Next, some specifications for the calculation of the standardization will be +#'discussed. If there are NAs in the data and they are not removed with the #'parameter 'na.rm', the standardization cannot be carried out for those #'coordinates and therefore, the result will be filled with NA for the #'specific coordinates. When NAs are not removed, if the length of the data for @@ -177,6 +175,14 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #' points of the reference period used for computing the index. The default #' value is NULL indicating that the first and end values in data will be #' used as starting and end points. +#'@param params An optional parameter that needs to be a multidimensional array +#' with named dimensions. This option overrides computation of fitting +#' parameters. It needs to be of same time dimensions (specified in 'time_dim' +#' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +#' of the coefficients needed for the used distribution (for 'Gamma' coef +#' dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length +#' 3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') +#' of length 1. It will only be used if 'data_cor' is not provided. #'@param handle_infinity A logical value wether to return infinite values (TRUE) #' or not (FALSE). When it is TRUE, the positive infinite values (negative #' infinite) are substituted by the maximum (minimum) values of each @@ -190,6 +196,8 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other #' variables are 0 because it is positive defined (SPI indicator). +#'@param return_params A logical value indicating wether to return parameters +#' array (TRUE) or not (FALSE). It is FALSE by default. #'@param na.rm A logical value indicating whether NA values should be removed #' from data. It is FALSE by default. If it is FALSE and there are NA values, #' standardization cannot be carried out for those coordinates and therefore, @@ -203,7 +211,9 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@return A multidimensional array containing the standardized data. #'If 'data_cor' is provided the array will be of the same dimensions as #''data_cor'. If 'data_cor' is not provided, the array will be of the same -#'dimensions as 'data'. +#'dimensions as 'data'. The parameters of the standardization will only be +#'returned if 'return_params' is TRUE, in this case, the output will be a list +#'of two objects one for the standardized data and one for the parameters. #' #'@examples #'dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) @@ -216,7 +226,6 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@import multiApply #'@import ClimProjDiags #'@import TLMoments -#'@import lmomco #'@import lmom #'@export PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 9bec9fd..d1f1a46 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -35,8 +35,8 @@ dimension name matching the dimensions provided in the object \code{data$data} can be specified.} \item{rollwidth}{An optional parameter to indicate the number of time -steps the rolling sum is applied to. If it is negative, the rolling sum is -applied backwards 'time_dim', if it is positive, it will be towards it. When +steps the rolling sum is applied to. If it is positive, the rolling sum is +applied backwards 'time_dim', if it is negative, it will be forward it. When this parameter is NULL, the sum is applied over all 'time_dim', in a specified period. It is NULL by default.} @@ -47,15 +47,16 @@ not (FALSE).} computation.} } \value{ -An 's2dv_cube' object containing the indicator in the element -\code{data}. If 'rollingwithd' is not used, it will have the dimensions of -the input parameter 'data' except the dimension where the accumulation has -been computed (specified with 'time_dim'). The 'Dates' array is updated to the +An 's2dv_cube' object containing the accumulated data in the element +\code{data}. If parameter 'rollwidth' is not used, it will have the dimensions +of the input parameter 'data' except the dimension where the accumulation has +been computed (specified with 'time_dim'). If 'rollwidth' is used, it will be +of same dimensions as input data. The 'Dates' array is updated to the dates corresponding to the beginning of the aggregated time period. A new element called 'time_bounds' will be added into the 'attrs' element in the 's2dv_cube' object. It consists of a list containing two elements, the start and end dates of the aggregated period with the same dimensions of 'Dates' -element. If 'rollingwithd' is used, it will contain the same dimensions of +element. If 'rollwidth' is used, it will contain the same dimensions of parameter 'data' and the other elements of the 's2dv_cube' will not be modified. } @@ -73,10 +74,13 @@ by using this function: \details{ There are two possible ways of performing the accumulation. The default one is by accumulating a variable over a dimension specified with 'time_dim'. To -chose a specific time period, start and end must be used. The other method -is by using rollwidth parameter. When this parameter is a positive integer, -the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum -is applied towards 'time_dim'. +chose a specific time period, 'start' and 'end' must be used. The other method +is by using 'rollwidth' parameter. When this parameter is a positive integer, +the cumulative backward sum is applied to the time dimension. If it is +negative, the rolling sum is applied backwards. This function is build to work +be compatible with other tools in that work with 's2dv_cube' object class. The +input data must be this object class. If you don't work with 's2dv_cube', see +PeriodAccumulation. } \examples{ exp <- NULL diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd index 10383af..23a56f4 100644 --- a/man/CST_PeriodPET.Rd +++ b/man/CST_PeriodPET.Rd @@ -16,14 +16,17 @@ CST_PeriodPET( } \arguments{ \item{data}{A named list with the needed \code{s2dv_cube} objects containing -the seasonal forecast experiment in the data element for each variable. +the seasonal forecast experiment in the 'data' element for each variable. Specific variables are needed for each method used in computing the -Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for -'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' -'tmean' is required. The units for temperature variables -('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -precipitation ('pr') need to be in mm/month.} +Potential Evapotranspiration (see parameter 'pet_method'). The accepted +variable names are fixed in order to be recognized by the function. +The accepted name corresponding to the Minimum Temperature is 'tmin', +for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +for Precipitation is 'pr'. The accepted variable names for each method are: +For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +degrees; the units for precipitation ('pr') need to be in mm/month.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: @@ -66,7 +69,6 @@ CST_PeriodAccumulation. } \examples{ dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) - exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) @@ -75,11 +77,8 @@ dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), paste0(2010:end_year, "-09-15"), paste0(2010:end_year, "-10-16")), "UTC") dim(dates_exp) <- c(syear = 3, time = 3) - lat <- c(40) - exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) - res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) } diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index c8010da..d5b8075 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -56,8 +56,9 @@ dimension. By default it is set by 'latitude'.} \item{accum}{An integer value indicating the number of months for the accumulation for each variable. When it is greater than 1, the result will -be filled with NA until the accum time_dim dimension number due to the -accumulation to previous months.} +be filled with NA until the accum 'time_dim' dimension number due to the +accumulation to previous months. The accumulation is performed backwards +by default.} \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default @@ -118,54 +119,57 @@ parallel computation.} } \value{ An 's2dv_cube' object containing the SPEI multidimensional array in -element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' -will be provided. The parameters of the standardization will only be returned -if 'return_params' is TRUE. The SPEI will only be computed if -'standardization' is TRUE. If 'standardization' is FALSE, only the climatic -water balance (precipitation minus evapotranspiration) will be returned. The -resultant arrays will have the same dimensions as the initial input data. The -other elements in the 's2dv_cube' will be updated with the combined -information of the input data arrays. +element \code{data} with same dimensions as input data. If 'exp_cor' is +provided, only results from 'exp_cor' will be provided. The parameters of the +standardization will only be returned if 'return_params' is TRUE. The SPEI +will only be computed if 'standardization' is TRUE. If 'standardization' is +FALSE, only the climatic water balance (precipitation minus +evapotranspiration) will be returned. The resultant arrays will have the same +dimensions as the initial input data. The other elements in the 's2dv_cube' +will be updated with the combined information of the input data arrays. } \description{ Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) that is a multiscalar drought index based on climatic data. It can be used for determining the onset, duration and magnitude of drought conditions with -respect to normal conditions in a variety of natural and managed systems such -as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI -is to compare the highest possible evapotranspiration with the current water -availability. The SPEI uses the monthly (or weekly) difference between -precipitation and potential evapotranspiration. This represents a simple -climatic water balance which is calculated at different time scales to obtain -the SPEI. This function is build to work be compatible with other tools in -that work with 's2dv_cube' object class. The input data must be this object -class. If you don't work with 's2dv_cube', see PeriodSPEI. +respect to normal conditions. The idea behind the SPEI is to compare the +highest possible evapotranspiration with the current water availability. The +SPEI uses for a specific time frequency the difference between precipitation +and potential evapotranspiration. This represents a simple climatic water +balance which is calculated at different time scales to obtain the SPEI. This +function is build to work be compatible with other tools in that work with +'s2dv_cube' object class. The input data must be this object class. If you +don't work with 's2dv_cube', see PeriodSPEI. } \details{ Next, some specifications for the calculation of this indicator will be -discussed. On the one hand, the model to be used to calculate potential -evapotranspiration is specified with the pet_method parameter (hargreaves, -hargraves modified or thornwhite). On the other hand, to choose the time scale -in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the -accum parameter, where you must indicate the number of time steps you want to -accumulate throughout leadtime_dim. Since the accumulation is done for the +discussed. On the one hand, the model to be used to calculate Potential +Evapotranspiration is specified with the 'pet_method' parameter (it can be +hargreaves, hargraves modified or thornwhite). On the other hand, to choose +the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is +done using the 'accum' parameter, where you must indicate the number of time +steps you want to accumulate throughout 'leadtime_dim'. The accumulation will +be performed backwards by default. Since the accumulation is done for the elapsed time steps, there will be no complete accumulations until reaching the -time instant equal to the value of the parameter. For this reason, in the -result, we will find that for the dimension where the accumulation has been -carried out, the values of the array will be NA since they do not include +time instant equal to the value of the 'accum' parameter. For this reason, in +the result, we will find that for the dimension where the accumulation has +been carried out, the values of the array will be NA since they do not include complete accumulations. Also, there is a parameter to specify if the standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a probability distribution to transform the original values to standardized units that are comparable in space and time and at different SPEI time scales. -The na.rm parameter is a logical parameter used to decide whether to remove +The 'na.rm' parameter is a logical parameter used to decide whether to remove the NA values from the data before doing the calculation. It must be taken -into account that if na.rm == FALSE and there is some NA value in the specific -coordinates which the SPEI is computed, standardization cannot be carried out -for those coordinates and therefore, the result will be filled with NA for the -specific coordinates. However, when na.rm == TRUE, if the amount of data for -those specific coordinates is smaller than 4, it will not be possible to carry -out because we will not have enough data and the result will be also filled -with NAs for that coordinates. +into account that if 'na.rm' is FALSE and there is some NA value in the +specific coordinates which the SPEI is computed, standardization cannot be +carried out for those coordinates and therefore, the result will be filled +with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the +amount of data for those specific coordinates is smaller than 4, it will not +be possible to carry out because we will not have enough data and the result +will be also filled with NAs for that coordinates. When only 'exp' is provided +the Standardization is computed with 'cross_validation'. For more information +about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation +and CST_PeriodStandardization. } \examples{ dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd index 5e23bd5..d68dab6 100644 --- a/man/CST_PeriodStandardization.Rd +++ b/man/CST_PeriodStandardization.Rd @@ -59,6 +59,18 @@ function to be used for computing the SPEI. The accepted names are: 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive defined (SPI indicator).} +\item{params}{An optional parameter that needs to be a multidimensional array +with named dimensions. This option overrides computation of fitting +parameters. It needs to be of same time dimensions (specified in 'time_dim' +and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +of the coefficients needed for the used distribution (for 'Gamma' coef +dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length +3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') +of length 1. It will only be used if 'data_cor' is not provided.} + +\item{return_params}{A logical value indicating wether to return parameters +array (TRUE) or not (FALSE). It is FALSE by default.} + \item{na.rm}{A logical value indicating whether NA values should be removed from data. It is FALSE by default. If it is FALSE and there are NA values, standardization cannot be carried out for those coordinates and therefore, @@ -74,7 +86,10 @@ parallel computation.} An object of class \code{s2dv_cube} containing the standardized data. If 'data_cor' is provided the array stored in element data will be of the same dimensions as 'data_cor'. If 'data_cor' is not provided, the array stored in -element data will be of the same dimensions as 'data'. +element data will be of the same dimensions as 'data'. The parameters of the +standardization will only be returned if 'return_params' is TRUE, in this +case, the output will be a list of two objects one for the standardized data +and one for the parameters. } \description{ The Standardization of the data is the last step of computing the SPEI @@ -84,15 +99,8 @@ standardized units that are comparable in space and time and at different SPEI time scales. } \details{ -Next, some specifications for the calculation of this indicator will be -discussed. To choose the time scale in which you want to accumulate the SPEI -(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to -be performed in the previous step. However, since the accumulation is done for -the elapsed time steps, there will be no complete accumulations until reaching -the time instant equal to the value of the parameter. For this reason, in the -result, we will find that for the dimension where the accumulation has been -carried out, the values of the array will be NA since they do not include -complete accumulations. If there are NAs in the data and they are not removed with the +Next, some specifications for the calculation of the standardization will be +discussed. If there are NAs in the data and they are not removed with the parameter 'na.rm', the standardization cannot be carried out for those coordinates and therefore, the result will be filled with NA for the specific coordinates. When NAs are not removed, if the length of the data for @@ -101,8 +109,7 @@ standarize and the result will be also filled with NAs for that coordinates. About the distribution used to fit the data, there are only two possibilities: 'log-logistic' and 'Gamma'. The 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive -defined (SPI indicator). For more information about SPEI, see functions -PeriodPET and PeriodAccumulation. This function is build to work be compatible +defined (SPI indicator). This function is build to work be compatible with other tools in that work with 's2dv_cube' object class. The input data must be this object class. If you don't work with 's2dv_cube', see PeriodStandardization. For more information on the SPEI indicator calculation, diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 4dae3ef..3e134c8 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -41,8 +41,8 @@ dimension name matching the dimensions provided in the object \code{data$data} can be specified.} \item{rollwidth}{An optional parameter to indicate the number of time -steps the rolling sum is applied to. If it is negative, the rolling sum is -applied backwards 'time_dim', if it is positive, it will be towards it. When +steps the rolling sum is applied to. If it is positive, the rolling sum is +applied backwards 'time_dim', if it is negative, it will be forward it. When this parameter is NULL, the sum is applied over all 'time_dim', in a specified period. It is NULL by default.} @@ -54,7 +54,10 @@ computation.} } \value{ A multidimensional array with named dimensions containing the -indicator in the element \code{data}. +accumulated data in the element \code{data}. If parameter 'rollwidth' is +not used, it will have the dimensions of the input 'data' except the dimension +where the accumulation has been computed (specified with 'time_dim'). If +'rollwidth' is used, it will be of same dimensions as input data. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a @@ -70,10 +73,10 @@ by using this function: \details{ There are two possible ways of performing the accumulation. The default one is by accumulating a variable over a dimension specified with 'time_dim'. To -chose a specific time period, start and end must be used. The other method -is by using rollwidth parameter. When this parameter is a positive integer, -the rolling sum is applied over 'time_dim'. If it is negative, the rolling sum -is applied towards 'time_dim'. +chose a specific time period, 'start' and 'end' must be used. The other method +is by using 'rollwidth' parameter. When this parameter is a positive integer, +the cumulative backward sum is applied to the time dimension. If it is +negative, the rolling sum is applied backwards. } \examples{ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd index 7ca1073..1b00339 100644 --- a/man/PeriodPET.Rd +++ b/man/PeriodPET.Rd @@ -17,15 +17,18 @@ PeriodPET( ) } \arguments{ -\item{data}{A named list with the needed \code{s2dv_cube} objects containing -the seasonal forecast experiment in the data element for each variable. +\item{data}{A named list of multidimensional arrays containing +the seasonal forecast experiment data for each variable. Specific variables are needed for each method used in computing the -Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables for each method are: for 'hargreaves', 'tmin' and 'tmax'; for -'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' -'tmean' is required. The units for temperature variables -('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -precipitation ('pr') need to be in mm/month.} +Potential Evapotranspiration (see parameter 'pet_method'). The accepted +variable names are fixed in order to be recognized by the function. +The accepted name corresponding to the Minimum Temperature is 'tmin', +for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +for Precipitation is 'pr'. The accepted variable names for each method are: +For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +degrees; the units for precipitation ('pr') need to be in mm/month.} \item{dates}{An array of temporal dimensions containing the Dates of 'data'. It must be of class 'Date' or 'POSIXct'.} @@ -54,7 +57,7 @@ from data. It is FALSE by default.} parallel computation.} } \description{ -Compute the Potential evapotranspiration (PET) that is the amount of +Compute the Potential Evapotranspiration (PET) that is the amount of evaporation and transpiration that would occur if a sufficient water source were available. This function calculate PET according to the Thornthwaite, Hargreaves or Hargreaves-modified equations. @@ -65,7 +68,6 @@ PeriodStandardization and PeriodAccumulation. } \examples{ dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) - exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) @@ -74,11 +76,8 @@ dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), paste0(2010:end_year, "-09-15"), paste0(2010:end_year, "-10-16")), "UTC") dim(dates_exp) <- c(syear = 3, time = 3) - lat <- c(40) - exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) - res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) } diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index b0d039e..bb7859e 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -68,7 +68,8 @@ dimension. By default it is set by 'latitude'.} \item{accum}{accum An integer value indicating the number of months for the accumulation for each variable. When it is greater than 1, the result will be filled with NA until the accum time_dim dimension number due to the -accumulation to previous months.} +accumulation to previous months. The accumulation is performed backwards +by default.} \item{ref_period}{A list with two numeric values with the starting and end points of the reference period used for computing the index. The default @@ -129,9 +130,9 @@ and the result will include NA.} parallel computation.} } \value{ -An 's2dv_cube' object containing the SPEI multidimensional array in -element \code{data}. If 'exp_cor' is provided, only results from 'exp_cor' -will be provided. The parameters of the standardization will only be returned +A multidimensional array containing the SPEI with same dimensions as +input data. If 'exp_cor' is provided, only results from 'exp_cor' will be +provided. The parameters of the standardization will only be returned if 'return_params' is TRUE. The SPEI will only be computed if 'standardization' is TRUE. If 'standardization' is FALSE, only the climatic water balance (precipitation minus evapotranspiration) will be returned. The @@ -141,39 +142,40 @@ resultant arrays will have the same dimensions as the initial input data. Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) that is a multiscalar drought index based on climatic data. It can be used for determining the onset, duration and magnitude of drought conditions with -respect to normal conditions in a variety of natural and managed systems such -as crops, ecosystems, rivers, water resources, etc. The idea behind the SPEI -is to compare the highest possible evapotranspiration with the current water -availability. The SPEI uses the monthly (or weekly) difference between -precipitation and potential evapotranspiration. This represents a simple -climatic water balance which is calculated at different time scales to obtain -the SPEI. +respect to normal conditions. The idea behind the SPEI is to compare the +highest possible evapotranspiration with the current water availability. The +SPEI uses for a specific time frequency the difference between precipitation +and potential evapotranspiration. } \details{ Next, some specifications for the calculation of this indicator will be -discussed. On the one hand, the model to be used to calculate potential -evapotranspiration is specified with the pet_method parameter (hargreaves, -hargraves modified or thornwhite). On the other hand, to choose the time scale -in which you want to accumulate the SPEI (SPEI3, SPEI6...) is done using the -accum parameter, where you must indicate the number of time steps you want to -accumulate throughout leadtime_dim. Since the accumulation is done for the +discussed. On the one hand, the model to be used to calculate Potential +Evapotranspiration is specified with the 'pet_method' parameter (it can be +hargreaves, hargraves modified or thornwhite). On the other hand, to choose +the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is +done using the 'accum' parameter, where you must indicate the number of time +steps you want to accumulate throughout 'leadtime_dim'. The accumulation will +be performed backwards by default. Since the accumulation is done for the elapsed time steps, there will be no complete accumulations until reaching the -time instant equal to the value of the parameter. For this reason, in the -result, we will find that for the dimension where the accumulation has been -carried out, the values of the array will be NA since they do not include +time instant equal to the value of the 'accum' parameter. For this reason, in +the result, we will find that for the dimension where the accumulation has +been carried out, the values of the array will be NA since they do not include complete accumulations. Also, there is a parameter to specify if the standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a probability distribution to transform the original values to standardized units that are comparable in space and time and at different SPEI time scales. -The na.rm parameter is a logical parameter used to decide whether to remove +The 'na.rm' parameter is a logical parameter used to decide whether to remove the NA values from the data before doing the calculation. It must be taken -into account that if na.rm == FALSE and there is some NA value in the specific -coordinates which the SPEI is computed, standardization cannot be carried out -for those coordinates and therefore, the result will be filled with NA for the -specific coordinates. However, when na.rm == TRUE, if the amount of data for -those specific coordinates is smaller than 4, it will not be possible to carry -out because we will not have enough data and the result will be also filled -with NAs for that coordinates. +into account that if 'na.rm' is FALSE and there is some NA value in the +specific coordinates which the SPEI is computed, standardization cannot be +carried out for those coordinates and therefore, the result will be filled +with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the +amount of data for those specific coordinates is smaller than 4, it will not +be possible to carry out because we will not have enough data and the result +will be also filled with NAs for that coordinates. When only 'exp' is provided +the Standardization is computed with 'cross_validation'. For more information +about SPEI calculation, see functions PeriodPET, PeriodAccumulation and +PeriodStandardization. } \examples{ dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd index 98b8ba6..ab86f9a 100644 --- a/man/PeriodStandardization.Rd +++ b/man/PeriodStandardization.Rd @@ -62,6 +62,18 @@ function to be used for computing the SPEI. The accepted names are: 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive defined (SPI indicator).} +\item{params}{An optional parameter that needs to be a multidimensional array +with named dimensions. This option overrides computation of fitting +parameters. It needs to be of same time dimensions (specified in 'time_dim' +and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +of the coefficients needed for the used distribution (for 'Gamma' coef +dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length +3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') +of length 1. It will only be used if 'data_cor' is not provided.} + +\item{return_params}{A logical value indicating wether to return parameters +array (TRUE) or not (FALSE). It is FALSE by default.} + \item{na.rm}{A logical value indicating whether NA values should be removed from data. It is FALSE by default. If it is FALSE and there are NA values, standardization cannot be carried out for those coordinates and therefore, @@ -77,7 +89,9 @@ parallel computation.} A multidimensional array containing the standardized data. If 'data_cor' is provided the array will be of the same dimensions as 'data_cor'. If 'data_cor' is not provided, the array will be of the same -dimensions as 'data'. +dimensions as 'data'. The parameters of the standardization will only be +returned if 'return_params' is TRUE, in this case, the output will be a list +of two objects one for the standardized data and one for the parameters. } \description{ The Standardization of the data is the last step of computing the SPEI @@ -86,15 +100,8 @@ transform the original values to standardized units that are comparable in space and time and at different SPEI time scales. } \details{ -Next, some specifications for the calculation of this indicator will be -discussed. To choose the time scale in which you want to accumulate the SPEI -(SPEI3, SPEI6...) is done using the accum parameter. The accumulation needs to -be performed in the previous step. However, since the accumulation is done for -the elapsed time steps, there will be no complete accumulations until reaching -the time instant equal to the value of the parameter. For this reason, in the -result, we will find that for the dimension where the accumulation has been -carried out, the values of the array will be NA since they do not include -complete accumulations. If there are NAs in the data and they are not removed with the +Next, some specifications for the calculation of the standardization will be +discussed. If there are NAs in the data and they are not removed with the parameter 'na.rm', the standardization cannot be carried out for those coordinates and therefore, the result will be filled with NA for the specific coordinates. When NAs are not removed, if the length of the data for diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index f970cde..1ce36d9 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -14,7 +14,7 @@ dates2 <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("03-04-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2001", format = "%d-%m-%Y"), as.Date("03-04-2001", format = "%d-%m-%Y"), by = 'day')) -dim(dates2) <- c(sdate = 2, time = 3) +dim(dates2) <- c(time = 3, sdate = 2) # exp1 exp <- NULL @@ -200,7 +200,22 @@ test_that("4. Rolling", { PeriodAccumulation(data = dat2, rollwidth = 3, dates = dates2), array(c(rep(NA, 4), 9, 12), dim = c(sdate = 2, time = 3, member = 1)) ) - dat1[1,1,1] <- NA - PeriodAccumulation(data = dat2, rollwidth = 2, dates = dates2, na.rm = FALSE) + dat2_1 <- dat2 + dat2_1[1,1,1] <- NA + expect_equal( + PeriodAccumulation(data = dat2_1, rollwidth = 2, dates = dates2, na.rm = FALSE), + array(c(rep(NA, 3), 6,8,10), dim = c(sdate = 2, time = 3, member = 1)) + ) + # Test rolling with start and end -}) + expect_equal( + PeriodAccumulation(data = dat2, rollwidth = 1, dates = dates2, + start = list(1, 4), end = list(2, 4)), + array(c(1, 2, 3, 4), dim = c(sdate = 2, time = 2, member = 1)) + ) + expect_equal( + PeriodAccumulation(data = dat2, rollwidth = 2, dates = dates2, + start = list(1, 4), end = list(2, 4)), + array(c(NA, NA, 4, 6), dim = c(sdate = 2, time = 2, member = 1)) + ) +}) \ No newline at end of file diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 23f7316..b16bb69 100644 --- a/tests/testthat/test-PeriodSPEI.R +++ b/tests/testthat/test-PeriodSPEI.R @@ -325,7 +325,7 @@ test_that("2. Output checks: CST_PeriodSPEI", { test_that("2. Output checks", { res1 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, - return_params = TRUE) + return_params = TRUE, na.rm = TRUE) res2 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, dates_exp = dates_exp, dates_expcor = dates_expcor, standardization = FALSE) # No info about accumulation @@ -366,15 +366,15 @@ test_that("2. Output checks", { # accum res11 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, accum = 2, dates_exp = dates_exp, na.rm = TRUE) - # expect_equal( - # res11[1,3,1,1,][1:4], - # c(-0.4292409, -0.1375149, -0.5564081, -0.4273380), - # tolerance = 0.0001 - # ) + expect_equal( + res11[1,3,1,1,][1:4], + c(-0.6130081, -0.3446050, -0.7267427, -0.6112921), + tolerance = 0.0001 + ) # ref_period - # res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, - # dates_exp = dates_exp, dates_expcor = dates_expcor, - # na.rm = TRUE, ref_period = list(2011, 2013)) + res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, + dates_exp = dates_exp, dates_expcor = dates_expcor, + na.rm = TRUE, ref_period = list(2011, 2013)) expect_equal( !identical(res1[[1]], res_ref), TRUE @@ -423,11 +423,6 @@ test_that("2. Output checks", { dim(res_crossval_T$params), c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) ) - # cross_validation = FALSE - # expect_equal( - # dim(res_crossval_F$params)[-which(names(dim(res_crossval_F$params)) == 'coef')], - # dimscor[-which(names(dimscor) == 'ensemble')] - # ) # pet_method - ok res5 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, -- GitLab From 527dddd4f4bb76994d56a95c2ead8cd649d19880 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 19 Sep 2023 12:54:37 +0200 Subject: [PATCH 59/87] Correct few mistakes in documentation --- R/PeriodAccumulation.R | 2 +- R/PeriodPET.R | 2 +- R/PeriodSPEI.R | 12 ++++++------ R/PeriodStandardization.R | 16 +++++++++------- man/CST_PeriodAccumulation.Rd | 2 +- man/CST_PeriodPET.Rd | 2 +- man/CST_PeriodSPEI.Rd | 6 +++--- man/CST_PeriodStandardization.Rd | 11 ++++++----- man/PeriodSPEI.Rd | 6 +++--- man/PeriodStandardization.Rd | 5 +++-- 10 files changed, 34 insertions(+), 30 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 91220f6..09f4211 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -15,7 +15,7 @@ #'chose a specific time period, 'start' and 'end' must be used. The other method #'is by using 'rollwidth' parameter. When this parameter is a positive integer, #'the cumulative backward sum is applied to the time dimension. If it is -#'negative, the rolling sum is applied backwards. This function is build to work +#'negative, the rolling sum is applied backwards. This function is build to #'be compatible with other tools in that work with 's2dv_cube' object class. The #'input data must be this object class. If you don't work with 's2dv_cube', see #'PeriodAccumulation. diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 9fdb7e2..87dc8ca 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -5,7 +5,7 @@ #'were available. This function calculate PET according to the Thornthwaite, #'Hargreaves or Hargreaves-modified equations. #' -#'This function is build to work be compatible with other tools in +#'This function is build to be compatible with other tools in #'that work with 's2dv_cube' object class. The input data must be this object #'class. If you don't work with 's2dv_cube', see PeriodPET. For more information #'on the SPEI calculation, see functions CST_PeriodStandardization and diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 442209f..77e90d5 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -8,7 +8,7 @@ #'SPEI uses for a specific time frequency the difference between precipitation #'and potential evapotranspiration. This represents a simple climatic water #'balance which is calculated at different time scales to obtain the SPEI. This -#'function is build to work be compatible with other tools in that work with +#'function is build to be compatible with other tools in that work with #''s2dv_cube' object class. The input data must be this object class. If you #'don't work with 's2dv_cube', see PeriodSPEI. #' @@ -37,8 +37,8 @@ #'amount of data for those specific coordinates is smaller than 4, it will not #'be possible to carry out because we will not have enough data and the result #'will be also filled with NAs for that coordinates. When only 'exp' is provided -#'the Standardization is computed with 'cross_validation'. For more information -#'about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation +#'('exp_cor' is NULL) the Standardization is computed with cross validation. For +#'more information about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation #'and CST_PeriodStandardization. #' #'@param exp A named list with the needed \code{s2dv_cube} objects containing @@ -311,9 +311,9 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', #'amount of data for those specific coordinates is smaller than 4, it will not #'be possible to carry out because we will not have enough data and the result #'will be also filled with NAs for that coordinates. When only 'exp' is provided -#'the Standardization is computed with 'cross_validation'. For more information -#'about SPEI calculation, see functions PeriodPET, PeriodAccumulation and -#'PeriodStandardization. +#'('exp_cor' is NULL) the Standardization is computed with cross validation. For +#'more information about SPEI calculation, see functions PeriodPET, +#'PeriodAccumulation and PeriodStandardization. #' #'@param exp A named list with multidimensional array objects containing #' the seasonal forecast experiment in the data element for each variable. diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index d95127d..966d648 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -16,11 +16,12 @@ #'About the distribution used to fit the data, there are only two possibilities: #''log-logistic' and 'Gamma'. The 'Gamma' method only works when only #'precipitation is provided and other variables are 0 because it is positive -#'defined (SPI indicator). This function is build to work be compatible -#'with other tools in that work with 's2dv_cube' object class. The input data -#'must be this object class. If you don't work with 's2dv_cube', see -#'PeriodStandardization. For more information on the SPEI indicator calculation, -#'see CST_PeriodPET and CST_PeriodAccumulation. +#'defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +#'standardization is computed with cross validation. This function is build to +#'be compatible with other tools in that work with 's2dv_cube' object +#'class. The input data must be this object class. If you don't work with +#''s2dv_cube', see PeriodStandardization. For more information on the SPEI +#'indicator calculation, see CST_PeriodPET and CST_PeriodAccumulation. #' #'@param data An 's2dv_cube' that element 'data' stores a multidimensional #' array containing the data to be standardized. @@ -155,8 +156,9 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'About the distribution used to fit the data, there are only two possibilities: #''log-logistic' and 'Gamma'. The 'Gamma' method only works when only #'precipitation is provided and other variables are 0 because it is positive -#'defined (SPI indicator). For more information about SPEI, see functions -#'PeriodPET and PeriodAccumulation. +#'defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +#'standardization is computed with cross validation. For more information about +#'SPEI, see functions PeriodPET and PeriodAccumulation. #' #'@param data A multidimensional array containing the data to be standardized. #'@param data_cor A multidimensional array containing the data in which the diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index d1f1a46..3de6d4b 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -77,7 +77,7 @@ is by accumulating a variable over a dimension specified with 'time_dim'. To chose a specific time period, 'start' and 'end' must be used. The other method is by using 'rollwidth' parameter. When this parameter is a positive integer, the cumulative backward sum is applied to the time dimension. If it is -negative, the rolling sum is applied backwards. This function is build to work +negative, the rolling sum is applied backwards. This function is build to be compatible with other tools in that work with 's2dv_cube' object class. The input data must be this object class. If you don't work with 's2dv_cube', see PeriodAccumulation. diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd index 23a56f4..d705a3c 100644 --- a/man/CST_PeriodPET.Rd +++ b/man/CST_PeriodPET.Rd @@ -61,7 +61,7 @@ were available. This function calculate PET according to the Thornthwaite, Hargreaves or Hargreaves-modified equations. } \details{ -This function is build to work be compatible with other tools in +This function is build to be compatible with other tools in that work with 's2dv_cube' object class. The input data must be this object class. If you don't work with 's2dv_cube', see PeriodPET. For more information on the SPEI calculation, see functions CST_PeriodStandardization and diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index d5b8075..7b9aa77 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -137,7 +137,7 @@ highest possible evapotranspiration with the current water availability. The SPEI uses for a specific time frequency the difference between precipitation and potential evapotranspiration. This represents a simple climatic water balance which is calculated at different time scales to obtain the SPEI. This -function is build to work be compatible with other tools in that work with +function is build to be compatible with other tools in that work with 's2dv_cube' object class. The input data must be this object class. If you don't work with 's2dv_cube', see PeriodSPEI. } @@ -167,8 +167,8 @@ with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the amount of data for those specific coordinates is smaller than 4, it will not be possible to carry out because we will not have enough data and the result will be also filled with NAs for that coordinates. When only 'exp' is provided -the Standardization is computed with 'cross_validation'. For more information -about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation +('exp_cor' is NULL) the Standardization is computed with cross validation. For +more information about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation and CST_PeriodStandardization. } \examples{ diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd index d68dab6..823f501 100644 --- a/man/CST_PeriodStandardization.Rd +++ b/man/CST_PeriodStandardization.Rd @@ -109,11 +109,12 @@ standarize and the result will be also filled with NAs for that coordinates. About the distribution used to fit the data, there are only two possibilities: 'log-logistic' and 'Gamma'. The 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive -defined (SPI indicator). This function is build to work be compatible -with other tools in that work with 's2dv_cube' object class. The input data -must be this object class. If you don't work with 's2dv_cube', see -PeriodStandardization. For more information on the SPEI indicator calculation, -see CST_PeriodPET and CST_PeriodAccumulation. +defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +standardization is computed with cross validation. This function is build to +be compatible with other tools in that work with 's2dv_cube' object +class. The input data must be this object class. If you don't work with +'s2dv_cube', see PeriodStandardization. For more information on the SPEI +indicator calculation, see CST_PeriodPET and CST_PeriodAccumulation. } \examples{ dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index bb7859e..c3ee473 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -173,9 +173,9 @@ with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the amount of data for those specific coordinates is smaller than 4, it will not be possible to carry out because we will not have enough data and the result will be also filled with NAs for that coordinates. When only 'exp' is provided -the Standardization is computed with 'cross_validation'. For more information -about SPEI calculation, see functions PeriodPET, PeriodAccumulation and -PeriodStandardization. +('exp_cor' is NULL) the Standardization is computed with cross validation. For +more information about SPEI calculation, see functions PeriodPET, +PeriodAccumulation and PeriodStandardization. } \examples{ dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd index ab86f9a..b2dad6c 100644 --- a/man/PeriodStandardization.Rd +++ b/man/PeriodStandardization.Rd @@ -110,8 +110,9 @@ standarize and the result will be also filled with NAs for that coordinates. About the distribution used to fit the data, there are only two possibilities: 'log-logistic' and 'Gamma'. The 'Gamma' method only works when only precipitation is provided and other variables are 0 because it is positive -defined (SPI indicator). For more information about SPEI, see functions -PeriodPET and PeriodAccumulation. +defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +standardization is computed with cross validation. For more information about +SPEI, see functions PeriodPET and PeriodAccumulation. } \examples{ dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) -- GitLab From 7fcf6a9a1fca8759e853f2fc217531ddf7dd10a2 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 3 Oct 2023 15:53:01 +0200 Subject: [PATCH 60/87] Improve initial checks and change default value time_dim to 'time' --- R/PeriodFun.R | 190 --------------------------- R/PeriodMax.R | 23 +++- R/PeriodMean.R | 19 ++- R/PeriodMin.R | 23 +++- R/PeriodVariance.R | 23 +++- man/CST_PeriodMax.Rd | 4 +- man/CST_PeriodMean.Rd | 4 +- man/CST_PeriodMin.Rd | 4 +- man/CST_PeriodVariance.Rd | 4 +- man/PeriodMax.Rd | 4 +- man/PeriodMin.Rd | 4 +- man/PeriodVariance.Rd | 4 +- tests/testthat/test-PeriodFun.R | 120 ----------------- tests/testthat/test-PeriodMax.R | 30 +++-- tests/testthat/test-PeriodMean.R | 22 +++- tests/testthat/test-PeriodMin.R | 22 +++- tests/testthat/test-PeriodVariance.R | 18 ++- 17 files changed, 142 insertions(+), 376 deletions(-) delete mode 100644 R/PeriodFun.R delete mode 100644 tests/testthat/test-PeriodFun.R diff --git a/R/PeriodFun.R b/R/PeriodFun.R deleted file mode 100644 index 77484a1..0000000 --- a/R/PeriodFun.R +++ /dev/null @@ -1,190 +0,0 @@ -#'Period Function on 's2dv_cube' objects -#' -#'Period Fun computes a calculation of a given variable in a period. -#' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. -#'@param fun An atomic function to compute a calculation over a period. -#'@param start An optional parameter to defined the initial date of the period -#' to select from the data by providing a list of two elements: the initial -#' date of the period and the initial month of the period. By default it is set -#' to NULL and the indicator is computed using all the data provided in -#' \code{data}. -#'@param end An optional parameter to defined the final date of the period to -#' select from the data by providing a list of two elements: the final day of -#' the period and the final month of the period. By default it is set to NULL -#' and the indicator is computed using all the data provided in \code{data}. -#'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. -#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or -#' not (FALSE). -#'@param ncores An integer indicating the number of cores to use in parallel -#' computation. -#' -#'@return An 's2dv_cube' object containing the indicator in the element -#'\code{data} with dimensions of the input parameter 'data' except the -#'dimension where the mean has been computed (specified with 'time_dim'). A new -#'element called 'time_bounds' will be added into the 'attrs' element in the -#''s2dv_cube' object. It consists of a list containing two elements, the start -#'and end dates of the aggregated period with the same dimensions of 'Dates' -#'element. -#' -#'@examples -#'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) -#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) -#'exp$attrs$Dates <- Dates -#'class(exp) <- 's2dv_cube' -#' -#'SA <- CSIndicators:::.CST_PeriodFun(exp, fun = mean, start = list(01, 12), -#' end = list(01, 01)) -#' -#'@import multiApply -#'@importFrom ClimProjDiags Subset -#'@noRd -.CST_PeriodFun <- function(data, fun, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, - ncores = NULL) { - # Check 's2dv_cube' - if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube'.") - } - # Dates subset - if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$attrs$Dates))) { - warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", - "all data would be used.") - start <- NULL - end <- NULL - } - } - - Dates <- data$attrs$Dates - total <- CSIndicators:::.PeriodFun(data = data$data, fun = fun, dates = Dates, start = start, - end = end, time_dim = time_dim, na.rm = na.rm, - ncores = ncores) - - data$data <- total - data$dims <- dim(total) - - if (!is.null(Dates)) { - if (!is.null(start) && !is.null(end)) { - Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, - time_dim = time_dim, ncores = ncores) - } - if (is.null(dim(Dates))) { - warning("Element 'Dates' has NULL dimensions. They will not be ", - "subset and 'time_bounds' will be missed.") - data$attrs$Dates <- Dates - } else { - # Create time_bounds - time_bounds <- NULL - time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, - indices = 1, drop = 'selected') - time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, - indices = dim(Dates)[time_dim], - drop = 'selected') - - # Add Dates in attrs - data$attrs$Dates <- time_bounds$start - data$attrs$time_bounds <- time_bounds - } - } - return(data) -} - -#'Period Function on multidimensional array objects -#' -#'Period Fun computes a calculation of a given variable in a period. -#' -#'@param data A multidimensional array with named dimensions. -#'@param fun An atomic function to compute a calculation over a period. -#'@param dates A multidimensional array of dates with named dimensions matching -#' the temporal dimensions on parameter 'data'. By default it is NULL, to -#' select aperiod this parameter must be provided. -#'@param start An optional parameter to defined the initial date of the period -#' to select from the data by providing a list of two elements: the initial -#' date of the period and the initial month of the period. By default it is set -#' to NULL and the indicator is computed using all the data provided in -#' \code{data}. -#'@param end An optional parameter to defined the final date of the period to -#' select from the data by providing a list of two elements: the final day of -#' the period and the final month of the period. By default it is set to NULL -#' and the indicator is computed using all the data provided in \code{data}. -#'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. -#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or -#' not (FALSE). -#'@param ncores An integer indicating the number of cores to use in parallel -#' computation. -#' -#'@return A multidimensional array with named dimensions containing the -#'indicator in the element \code{data}. -#' -#'@examples -#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) -#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), -#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), -#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) -#'SA <- CSIndicators:::.PeriodFun(data, fun = mean, dates = Dates, start = list(01, 12), -#' end = list(01, 01)) -#' -#'@import multiApply -#'@noRd -.PeriodFun <- function(data, fun, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { - - if (is.null(data)) { - stop("Parameter 'data' cannot be NULL.") - } - if (!is.numeric(data)) { - stop("Parameter 'data' must be numeric.") - } - if (!is.array(data)) { - dim(data) <- length(data) - names(data) <- time_dim - } - - if (!is.null(start) && !is.null(end)) { - if (is.null(dates)) { - warning("Parameter 'dates' is NULL and the average of the ", - "full data provided in 'data' is computed.") - } else { - if (!any(c(is.list(start), is.list(end)))) { - stop("Parameter 'start' and 'end' must be lists indicating the ", - "day and the month of the period start and end.") - } - if (!is.null(dim(dates))) { - data <- SelectPeriodOnData(data = data, dates = dates, start = start, - end = end, time_dim = time_dim, - ncores = ncores) - } else { - warning("Parameter 'dates' must have named dimensions if 'start' and ", - "'end' are not NULL. All data will be used.") - } - } - } - total <- Apply(list(data), target_dims = time_dim, fun = fun, - na.rm = na.rm, ncores = ncores)$output1 - return(total) -} - - diff --git a/R/PeriodMax.R b/R/PeriodMax.R index 0d47033..b8df92b 100644 --- a/R/PeriodMax.R +++ b/R/PeriodMax.R @@ -24,7 +24,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -61,12 +61,13 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodMax <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { - # Check 's2dv_cube' + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -138,7 +139,7 @@ CST_PeriodMax <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -165,17 +166,25 @@ CST_PeriodMax <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodMax <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { - + time_dim = 'time', na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) - names(data) <- time_dim + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") } if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodMean.R b/R/PeriodMean.R index db6a78f..79deb5d 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -22,7 +22,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -60,12 +60,13 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodMean <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { - # Check 's2dv_cube' + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -163,16 +164,24 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'@export PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, time_dim = 'time', na.rm = FALSE, ncores = NULL) { - + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) - names(data) <- time_dim + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") } if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodMin.R b/R/PeriodMin.R index f5ea5b0..0365d47 100644 --- a/R/PeriodMin.R +++ b/R/PeriodMin.R @@ -24,7 +24,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -61,12 +61,13 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodMin <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { - # Check 's2dv_cube' + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -138,7 +139,7 @@ CST_PeriodMin <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -165,17 +166,25 @@ CST_PeriodMin <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodMin <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { - + time_dim = 'time', na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) - names(data) <- time_dim + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") } if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R index b9f3cff..d6b0153 100644 --- a/R/PeriodVariance.R +++ b/R/PeriodVariance.R @@ -28,7 +28,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -65,12 +65,13 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodVariance <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { - # Check 's2dv_cube' + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -146,7 +147,7 @@ CST_PeriodVariance <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -173,17 +174,25 @@ CST_PeriodVariance <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodVariance <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { - + time_dim = 'time', na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) - names(data) <- time_dim + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") } if (!is.null(start) && !is.null(end)) { diff --git a/man/CST_PeriodMax.Rd b/man/CST_PeriodMax.Rd index 02a4a8a..52d3cd6 100644 --- a/man/CST_PeriodMax.Rd +++ b/man/CST_PeriodMax.Rd @@ -8,7 +8,7 @@ CST_PeriodMax( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -29,7 +29,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index 0aa4aa3..7b4611c 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -8,7 +8,7 @@ CST_PeriodMean( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -29,7 +29,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/CST_PeriodMin.Rd b/man/CST_PeriodMin.Rd index 7076ccd..bfe48f4 100644 --- a/man/CST_PeriodMin.Rd +++ b/man/CST_PeriodMin.Rd @@ -8,7 +8,7 @@ CST_PeriodMin( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -29,7 +29,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/CST_PeriodVariance.Rd b/man/CST_PeriodVariance.Rd index fa68197..064cc5c 100644 --- a/man/CST_PeriodVariance.Rd +++ b/man/CST_PeriodVariance.Rd @@ -8,7 +8,7 @@ CST_PeriodVariance( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -29,7 +29,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/PeriodMax.Rd b/man/PeriodMax.Rd index 26e62a4..4ec388c 100644 --- a/man/PeriodMax.Rd +++ b/man/PeriodMax.Rd @@ -9,7 +9,7 @@ PeriodMax( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/PeriodMin.Rd b/man/PeriodMin.Rd index 72d6c78..04d0b01 100644 --- a/man/PeriodMin.Rd +++ b/man/PeriodMin.Rd @@ -9,7 +9,7 @@ PeriodMin( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/man/PeriodVariance.Rd b/man/PeriodVariance.Rd index be4a243..c49fd3e 100644 --- a/man/PeriodVariance.Rd +++ b/man/PeriodVariance.Rd @@ -9,7 +9,7 @@ PeriodVariance( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} diff --git a/tests/testthat/test-PeriodFun.R b/tests/testthat/test-PeriodFun.R deleted file mode 100644 index c743aee..0000000 --- a/tests/testthat/test-PeriodFun.R +++ /dev/null @@ -1,120 +0,0 @@ -library(CSTools) - -############################################## -test_that("1. Sanity Checks", { - expect_error( - PeriodFun('x'), - "Parameter 'data' must be numeric." - ) - suppressWarnings( - expect_equal( - PeriodFun(array(1, c(x = 1)), fun = mean, time_dim = 'x'), - 1 - ) - ) - expect_error( - PeriodFun(data = NULL, fun = mean), - "Parameter 'data' cannot be NULL." - ) - expect_error( - PeriodFun(1, fun = mean, dates = '2000-01-01', end = 3, start = 4), - paste0("Parameter 'start' and 'end' must be lists indicating the day ", - "and the month of the period start and end.") - ) - expect_equal( - PeriodFun(array(1:10, c(ftime = 10)), fun = mean), - 5.5 - ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) - expect_equal( - PeriodFun(data, fun = min), - array(c(1, 2, 7, 8, 13, 14, 19, 20), - c(sdate = 2, lon = 4)) - ) - # Test dates warning - expect_warning( - PeriodFun(array(1:10, c(ftime = 10)), fun = mean, - dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), - as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), - start = list(05, 02), end = list(05, 09)), - paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", - "are not NULL. All data will be used.") - ) - # start and end when dates is not provided - expect_warning( - PeriodFun(array(1:10, c(ftime = 10)), fun = sum, - start = list(05, 02), end = list(05, 09)), - paste0("Parameter 'dates' is NULL and the average of the full data ", - "provided in 'data' is computed.") - ) -}) - -############################################## - -test_that("2. Seasonal", { - exp <- NULL - exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) - exp$dims <- dim(exp$data) - exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), - as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2001", format = "%d-%m-%Y"), - as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2002", format = "%d-%m-%Y"), - as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) - class(exp) <- 's2dv_cube' - output <- exp - output$data <- array(c(min(exp$data[1,1,21:82,1]), min(exp$data[1,2,21:82,1]), - min(exp$data[1,3,21:82,1]), min(exp$data[1,1,21:82,2]), - min(exp$data[1,2,21:82,2]), min(exp$data[1,3,21:82,2])), - c(memb = 1, sdate = 3, lon = 2)) - expect_equal( - CST_PeriodFun(exp, fun = min, start = list(21, 4), end = list(21, 6))$data, - output$data - ) -}) - -############################################## -test_that("3. Subset Dates and check time_bounds", { - exp <- CSTools::lonlat_prec - res <- CST_PeriodFun(data = CSTools::lonlat_prec, fun = min, time_dim = 'ftime', - start = list(10, 03), end = list(20, 03)) - # Check dims - expect_equal( - dim(res$data), - res$dims - ) - # Check Dates - expect_equal( - dim(res$data)['sdate'], - dim(res$attrs$Dates) - ) - # Check time_bounds - expect_equal( - res$attrs$Dates, - res$attrs$time_bounds$start - ) - expect_equal( - dim(res$attrs$time_bounds$start), - dim(res$attrs$time_bounds$end) - ) - # Check 'sdates' - expect_equal( - all(lubridate::month(res$attrs$time_bounds$start) == 3), - TRUE - ) - expect_equal( - all(lubridate::day(res$attrs$time_bounds$start) == 10), - TRUE - ) - expect_equal( - all(lubridate::month(res$attrs$time_bounds$end) == 03), - TRUE - ) - expect_equal( - all(lubridate::day(res$attrs$time_bounds$end) == 20), - TRUE - ) -}) - diff --git a/tests/testthat/test-PeriodMax.R b/tests/testthat/test-PeriodMax.R index 967b086..97907e6 100644 --- a/tests/testthat/test-PeriodMax.R +++ b/tests/testthat/test-PeriodMax.R @@ -2,31 +2,41 @@ library(CSTools) ############################################## test_that("1. Sanity Checks", { + # data + expect_error( + PeriodMax(data = NULL), + "Parameter 'data' cannot be NULL." + ) expect_error( PeriodMax('x'), "Parameter 'data' must be numeric." ) + # time_dim + expect_error( + PeriodMax(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodMax(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) suppressWarnings( expect_equal( PeriodMax(array(1, c(x = 1)), time_dim = 'x'), 1 ) ) - expect_error( - PeriodMax(data = NULL), - "Parameter 'data' cannot be NULL." - ) expect_error( PeriodMax(1, dates = '2000-01-01', end = 3, start = 4), "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." ) suppressWarnings( expect_equal( - PeriodMax(array(1:10, c(ftime = 10))), + PeriodMax(array(1:10, c(time = 10))), 10 ) ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) suppressWarnings( expect_equal( PeriodMax(data), @@ -36,7 +46,7 @@ test_that("1. Sanity Checks", { ) # Test dates warning expect_warning( - PeriodMax(array(1:10, c(ftime = 10)), + PeriodMax(array(1:10, c(time = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), @@ -45,7 +55,7 @@ test_that("1. Sanity Checks", { ) # start and end when dates is not provided expect_warning( - PeriodMax(array(1:10, c(ftime = 10)), + PeriodMax(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -57,7 +67,7 @@ test_that("1. Sanity Checks", { test_that("2. Seasonal", { exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + c(memb = 1, sdate = 3, time = 214, lon = 2)) exp$dims <- dim(exp$data) exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), @@ -65,7 +75,7 @@ test_that("2. Seasonal", { as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(max(exp$data[1,1,21:82,1]), max(exp$data[1,2,21:82,1]), diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index cd9f5fe..f51f7a1 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -2,6 +2,7 @@ library(CSTools) ############################################## test_that("1. Sanity Checks", { + # data expect_error( PeriodMean('x'), "Parameter 'data' must be numeric." @@ -16,17 +17,26 @@ test_that("1. Sanity Checks", { PeriodMean(data = NULL), "Parameter 'data' cannot be NULL." ) + # time_dim + expect_error( + PeriodMean(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodMean(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) expect_error( PeriodMean(1, dates = '2000-01-01', end = 3, start = 4), "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." ) suppressWarnings( expect_equal( - PeriodMean(array(1:10, c(ftime = 10))), + PeriodMean(array(1:10, c(time = 10))), 5.5 ) ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) suppressWarnings( expect_equal( PeriodMean(data), @@ -36,7 +46,7 @@ test_that("1. Sanity Checks", { ) # Test dates warning expect_warning( - PeriodMean(array(1:10, c(ftime = 10)), + PeriodMean(array(1:10, c(time = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), @@ -45,7 +55,7 @@ test_that("1. Sanity Checks", { ) # start and end when dates is not provided expect_warning( - PeriodMean(array(1:10, c(ftime = 10)), + PeriodMean(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -57,7 +67,7 @@ test_that("1. Sanity Checks", { test_that("2. Seasonal", { exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + c(memb = 1, sdate = 3, time = 214, lon = 2)) exp$dims <- dim(exp$data) exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), @@ -65,7 +75,7 @@ test_that("2. Seasonal", { as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(mean(exp$data[1,1,21:82,1]), mean(exp$data[1,2,21:82,1]), diff --git a/tests/testthat/test-PeriodMin.R b/tests/testthat/test-PeriodMin.R index da91a3c..5ed6c1f 100644 --- a/tests/testthat/test-PeriodMin.R +++ b/tests/testthat/test-PeriodMin.R @@ -2,6 +2,7 @@ library(CSTools) ############################################## test_that("1. Sanity Checks", { + # data expect_error( PeriodMin('x'), "Parameter 'data' must be numeric." @@ -16,15 +17,24 @@ test_that("1. Sanity Checks", { PeriodMin(data = NULL), "Parameter 'data' cannot be NULL." ) + # time_dim + expect_error( + PeriodMin(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodMin(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) expect_error( PeriodMin(1, dates = '2000-01-01', end = 3, start = 4), "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." ) expect_equal( - PeriodMin(array(1:10, c(ftime = 10))), + PeriodMin(array(1:10, c(time = 10))), 1 ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) expect_equal( PeriodMin(data), array(c(1, 2, 7, 8, 13, 14, 19, 20), @@ -32,7 +42,7 @@ test_that("1. Sanity Checks", { ) # Test dates warning expect_warning( - PeriodMin(array(1:10, c(ftime = 10)), + PeriodMin(array(1:10, c(time = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), @@ -41,7 +51,7 @@ test_that("1. Sanity Checks", { ) # start and end when dates is not provided expect_warning( - PeriodMin(array(1:10, c(ftime = 10)), + PeriodMin(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -53,7 +63,7 @@ test_that("1. Sanity Checks", { test_that("2. Seasonal", { exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + c(memb = 1, sdate = 3, time = 214, lon = 2)) exp$dims <- dim(exp$data) exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), @@ -61,7 +71,7 @@ test_that("2. Seasonal", { as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(min(exp$data[1,1,21:82,1]), min(exp$data[1,2,21:82,1]), diff --git a/tests/testthat/test-PeriodVariance.R b/tests/testthat/test-PeriodVariance.R index 1ac78c1..e525644 100644 --- a/tests/testthat/test-PeriodVariance.R +++ b/tests/testthat/test-PeriodVariance.R @@ -2,6 +2,7 @@ library(CSTools) ############################################## test_that("1. Sanity Checks", { + # data expect_error( PeriodVariance('x'), "Parameter 'data' must be numeric." @@ -14,16 +15,25 @@ test_that("1. Sanity Checks", { PeriodVariance(data = NULL), "Parameter 'data' cannot be NULL." ) + # time_dim + expect_error( + PeriodVariance(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodVariance(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) expect_error( PeriodVariance(1, dates = '2000-01-01', end = 3, start = 4), "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." ) expect_equal( - PeriodVariance(array(1:10, c(ftime = 10))), + PeriodVariance(array(1:10, c(time = 10))), 9.166667, tolerance = 0.001 ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) expect_equal( PeriodVariance(data), array(rep(4, 8), @@ -31,7 +41,7 @@ test_that("1. Sanity Checks", { ) # Test dates warning expect_warning( - PeriodVariance(array(1:10, c(ftime = 10)), + PeriodVariance(array(1:10, c(time = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), @@ -40,7 +50,7 @@ test_that("1. Sanity Checks", { ) # start and end when dates is not provided expect_warning( - PeriodVariance(array(1:10, c(ftime = 10)), + PeriodVariance(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") -- GitLab From a5a387ac6d5cc7ddd9f999b03c098b51abb6bbb5 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 3 Oct 2023 17:59:24 +0200 Subject: [PATCH 61/87] Correct examples of new functions Period... --- R/PeriodMax.R | 8 ++++---- R/PeriodMean.R | 4 ++-- R/PeriodMin.R | 8 ++++---- R/PeriodVariance.R | 8 ++++---- man/CST_PeriodMax.Rd | 4 ++-- man/CST_PeriodMean.Rd | 4 ++-- man/CST_PeriodMin.Rd | 4 ++-- man/CST_PeriodVariance.Rd | 4 ++-- man/PeriodMax.Rd | 4 ++-- man/PeriodMin.Rd | 4 ++-- man/PeriodVariance.Rd | 4 ++-- 11 files changed, 28 insertions(+), 28 deletions(-) diff --git a/R/PeriodMax.R b/R/PeriodMax.R index b8df92b..0806c51 100644 --- a/R/PeriodMax.R +++ b/R/PeriodMax.R @@ -42,7 +42,7 @@ #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -51,7 +51,7 @@ #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' #' @@ -151,7 +151,7 @@ CST_PeriodMax <- function(data, start = NULL, end = NULL, #'indicator in the element \code{data}. #' #'@examples -#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -160,7 +160,7 @@ CST_PeriodMax <- function(data, start = NULL, end = NULL, #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'res <- PeriodMax(data, dates = Dates, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 79deb5d..7066fdd 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -41,7 +41,7 @@ #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -50,7 +50,7 @@ #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' #' diff --git a/R/PeriodMin.R b/R/PeriodMin.R index 0365d47..842e2e8 100644 --- a/R/PeriodMin.R +++ b/R/PeriodMin.R @@ -42,7 +42,7 @@ #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -51,7 +51,7 @@ #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' #' @@ -151,7 +151,7 @@ CST_PeriodMin <- function(data, start = NULL, end = NULL, #'indicator in the element \code{data}. #' #'@examples -#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -160,7 +160,7 @@ CST_PeriodMin <- function(data, start = NULL, end = NULL, #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'res <- PeriodMin(data, dates = Dates, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R index d6b0153..b702981 100644 --- a/R/PeriodVariance.R +++ b/R/PeriodVariance.R @@ -46,7 +46,7 @@ #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -55,7 +55,7 @@ #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' #' @@ -159,7 +159,7 @@ CST_PeriodVariance <- function(data, start = NULL, end = NULL, #'indicator in the element \code{data}. #' #'@examples -#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) #'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), @@ -168,7 +168,7 @@ CST_PeriodVariance <- function(data, start = NULL, end = NULL, #' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), #' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), #' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) -#'dim(Dates) <- c(sdate = 4, ftime = 3) +#'dim(Dates) <- c(sdate = 4, time = 3) #'res <- PeriodVariance(data, dates = Dates, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply diff --git a/man/CST_PeriodMax.Rd b/man/CST_PeriodMax.Rd index 52d3cd6..7b01d14 100644 --- a/man/CST_PeriodMax.Rd +++ b/man/CST_PeriodMax.Rd @@ -63,7 +63,7 @@ Two bioclimatic indicators can be obtained by using this function: } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -72,7 +72,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index 7b4611c..ab42066 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -62,7 +62,7 @@ this function: } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -71,7 +71,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' diff --git a/man/CST_PeriodMin.Rd b/man/CST_PeriodMin.Rd index bfe48f4..9395699 100644 --- a/man/CST_PeriodMin.Rd +++ b/man/CST_PeriodMin.Rd @@ -63,7 +63,7 @@ Two bioclimatic indicators can be obtained by using this function: } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -72,7 +72,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' diff --git a/man/CST_PeriodVariance.Rd b/man/CST_PeriodVariance.Rd index 064cc5c..e28bf95 100644 --- a/man/CST_PeriodVariance.Rd +++ b/man/CST_PeriodVariance.Rd @@ -67,7 +67,7 @@ Two bioclimatic indicators can be obtained by using this function: } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -76,7 +76,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' diff --git a/man/PeriodMax.Rd b/man/PeriodMax.Rd index 4ec388c..cb776d2 100644 --- a/man/PeriodMax.Rd +++ b/man/PeriodMax.Rd @@ -61,7 +61,7 @@ Two bioclimatic indicators can be obtained by using this function: } } \examples{ -data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -70,7 +70,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) res <- PeriodMax(data, dates = Dates, start = list(01, 12), end = list(01, 01)) } diff --git a/man/PeriodMin.Rd b/man/PeriodMin.Rd index 04d0b01..154acf0 100644 --- a/man/PeriodMin.Rd +++ b/man/PeriodMin.Rd @@ -61,7 +61,7 @@ Two bioclimatic indicators can be obtained by using this function: } } \examples{ -data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -70,7 +70,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) res <- PeriodMin(data, dates = Dates, start = list(01, 12), end = list(01, 01)) } diff --git a/man/PeriodVariance.Rd b/man/PeriodVariance.Rd index c49fd3e..e1e8d7c 100644 --- a/man/PeriodVariance.Rd +++ b/man/PeriodVariance.Rd @@ -65,7 +65,7 @@ Two bioclimatic indicators can be obtained by using this function: } } \examples{ -data <- array(rnorm(45), dim = c(member = 7, sdate = 4, ftime = 3)) +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), @@ -74,7 +74,7 @@ Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) -dim(Dates) <- c(sdate = 4, ftime = 3) +dim(Dates) <- c(sdate = 4, time = 3) res <- PeriodVariance(data, dates = Dates, start = list(01, 12), end = list(01, 01)) } -- GitLab From 07c245d7833d73acd7526d66a60e7b720d68003c Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 13 Oct 2023 10:15:07 +0200 Subject: [PATCH 62/87] Change default time_dim from ftime to time and correct unit tests with it --- R/AbsToProbs.R | 20 ++--- R/AccumulationExceedingThreshold.R | 14 ++-- R/MergeRefToExp.R | 26 +++---- R/PeriodAccumulation.R | 14 ++-- R/QThreshold.R | 10 +-- R/SelectPeriodOnData.R | 16 ++-- R/SelectPeriodOnDates.R | 6 +- R/Threshold.R | 8 +- R/TotalSpellTimeExceedingThreshold.R | 16 ++-- R/TotalTimeExceedingThreshold.R | 16 ++-- R/WindCapacityFactor.R | 8 +- R/WindPowerDensity.R | 8 +- man/AbsToProbs.Rd | 10 +-- man/AccumulationExceedingThreshold.Rd | 6 +- man/CST_AbsToProbs.Rd | 10 +-- man/CST_AccumulationExceedingThreshold.Rd | 8 +- man/CST_MergeRefToExp.Rd | 12 +-- man/CST_PeriodAccumulation.Rd | 10 +-- man/CST_QThreshold.Rd | 10 +-- man/CST_SelectPeriodOnData.Rd | 8 +- man/CST_Threshold.Rd | 8 +- man/CST_TotalSpellTimeExceedingThreshold.Rd | 8 +- man/CST_TotalTimeExceedingThreshold.Rd | 8 +- man/CST_WindCapacityFactor.Rd | 8 +- man/CST_WindPowerDensity.Rd | 8 +- man/MergeRefToExp.Rd | 14 ++-- man/PeriodAccumulation.Rd | 4 +- man/SelectPeriodOnData.Rd | 8 +- man/SelectPeriodOnDates.Rd | 6 +- man/TotalSpellTimeExceedingThreshold.Rd | 8 +- man/TotalTimeExceedingThreshold.Rd | 8 +- tests/testthat/test-AbsToProbs.R | 6 +- .../test-AccumulationExceedingThreshold.R | 58 +++++++-------- tests/testthat/test-MergeRefToExp.R | 74 +++++++++---------- tests/testthat/test-PeriodAccumulation.R | 12 +-- tests/testthat/test-PeriodMax.R | 2 +- tests/testthat/test-PeriodMean.R | 2 +- tests/testthat/test-PeriodMin.R | 2 +- tests/testthat/test-PeriodVariance.R | 6 +- tests/testthat/test-QThreshold.R | 46 ++++++------ tests/testthat/test-SelectPeriod.R | 62 ++++++++-------- tests/testthat/test-Threshold.R | 18 ++--- .../test-TotalSpellTimeExceedingThreshold.R | 54 +++++++------- .../test-TotalTimeExceedingThreshold.R | 54 +++++++------- tests/testthat/test-WindCapacityFactor.R | 8 +- tests/testthat/test-WindPowerDensity.R | 8 +- 46 files changed, 368 insertions(+), 368 deletions(-) diff --git a/R/AbsToProbs.R b/R/AbsToProbs.R index e086e6e..247ba38 100644 --- a/R/AbsToProbs.R +++ b/R/AbsToProbs.R @@ -17,7 +17,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -33,24 +33,24 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#' time = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_AbsToProbs(exp) #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +#'dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) #'exp_probs <- CST_AbsToProbs(data = exp, start = list(21, 4), end = list(21, 6)) #'@import multiApply #'@importFrom stats ecdf #'@export CST_AbsToProbs <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -102,7 +102,7 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -118,17 +118,17 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #' #'@examples #'exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#' time = 9, lat = 2, lon = 2)) #'exp_probs <- AbsToProbs(exp) #'data <- array(rnorm(5 * 3 * 61 * 1), -#' c(member = 5, sdate = 3, ftime = 61, lon = 1)) +#' c(member = 5, sdate = 3, time = 61, lon = 1)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-06-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 61, sdate = 3) +#'dim(Dates) <- c(time = 61, sdate = 3) #'exp_probs <- AbsToProbs(data, dates = Dates, start = list(21, 4), #' end = list(21, 6)) #' @@ -136,7 +136,7 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #'@importFrom stats ecdf #'@export AbsToProbs <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # data if (!is.numeric(data)) { diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index 083b76c..eecded6 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -40,7 +40,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) #' or not (FALSE). @@ -59,7 +59,7 @@ #'@examples #'exp <- NULL #'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'class(exp) <- 's2dv_cube' #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), @@ -67,7 +67,7 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #'exp$attrs$Dates <- Dates #'AT <- CST_AccumulationExceedingThreshold(data = exp, threshold = 100, #' start = list(21, 4), @@ -77,7 +77,7 @@ #'@importFrom ClimProjDiags Subset #'@export CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, - start = NULL, end = NULL, time_dim = 'ftime', + start = NULL, end = NULL, time_dim = 'time', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -184,7 +184,7 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) #' or not (FALSE). @@ -198,14 +198,14 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'@examples #'# Assuming data is already (tasmax + tasmin)/2 - 10 #'data <- array(rnorm(5 * 3 * 214 * 2, mean = 25, sd = 3), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), #' end = list(31, 10)) #'@import multiApply #'@export AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # data if (is.null(data)) { diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index f5d9069..56c3c3d 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -42,7 +42,7 @@ #' the final month of the period. #'@param time_dim A character string indicating the name of the temporal #' dimension that will be used to combine the two arrays. By default, it is set -#' to 'ftime'. Also, it will be used to subset the data in a requested +#' to 'time'. Also, it will be used to subset the data in a requested #' period. #'@param memb_dim A character string indicating the name of the member #' dimension. If the data are not ensemble ones, set as NULL. The default @@ -75,16 +75,16 @@ #' as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), #' seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) -#'dim(data_dates) <- c(ftime = 154, sdate = 2) +#'dim(data_dates) <- c(time = 154, sdate = 2) #'data <- NULL -#'data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) +#'data$data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) #'data$attrs$Dates<- data_dates #'class(data) <- 's2dv_cube' #'ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day") -#'dim(ref_dates) <- c(ftime = 350, sdate = 2) +#'dim(ref_dates) <- c(time = 350, sdate = 2) #'ref <- NULL -#'ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) +#'ref$data <- array(1001:1700, c(time = 350, sdate = 2)) #'ref$attrs$Dates <- ref_dates #'class(ref) <- 's2dv_cube' #'new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, @@ -94,7 +94,7 @@ #'@export CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, start2 = NULL, end2 = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data1, 's2dv_cube')) { @@ -271,7 +271,7 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #' included in the 'dates2' array. #'@param time_dim A character string indicating the name of the temporal #' dimension that will be used to combine the two arrays. By default, it is set -#' to 'ftime'. Also, it will be used to subset the data in a requested +#' to 'time'. Also, it will be used to subset the data in a requested #' period. #'@param memb_dim A character string indicating the name of the member #' dimension. If the 'data1' and 'data2' have no member dimension, set it as @@ -302,22 +302,22 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #' as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), #' seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) -#'dim(data_dates) <- c(ftime = 154, sdate = 2) +#'dim(data_dates) <- c(time = 154, sdate = 2) #'ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day") -#'dim(ref_dates) <- c(ftime = 350, sdate = 2) -#'ref <- array(1001:1700, c(ftime = 350, sdate = 2)) -#'data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) +#'dim(ref_dates) <- c(time = 350, sdate = 2) +#'ref <- array(1001:1700, c(time = 350, sdate = 2)) +#'data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) #'new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), #' end1 = list(30, 6), data2 = data, dates2 = data_dates, #' start2 = list(1, 7), end = list(21, 9), -#' time_dim = 'ftime') +#' time_dim = 'time') #' #'@import multiApply #'@export MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, start1 = NULL, end1 = NULL, start2 = NULL, end2 = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', ncores = NULL) { # Input checks ## data1 and data2 diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 3b0d33d..b8dcf9a 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -22,7 +22,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -42,18 +42,18 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#' time = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' #'TP <- CST_PeriodAccumulation(exp) #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #'exp$attrs$Dates <- Dates #'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) #'dim(SprR$data) @@ -66,7 +66,7 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -150,8 +150,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' #'@examples #'exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) -#'TP <- PeriodAccumulation(exp, time_dim = 'ftime') +#' time = 9, lat = 2, lon = 2)) +#'TP <- PeriodAccumulation(exp, time_dim = 'time') #'data <- array(rnorm(5 * 3 * 214 * 2), #' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), diff --git a/R/QThreshold.R b/R/QThreshold.R index c5089df..4686cb3 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -37,7 +37,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -54,19 +54,19 @@ #'@examples #'threshold <- 26 #'exp <- NULL -#'exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, ftime = 2)) +#'exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, time = 2)) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_QThreshold(exp, threshold) #' #'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*50), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_QThreshold(exp, threshold, start = list(21, 4), #' end = list(21, 6)) @@ -74,7 +74,7 @@ #'@import multiApply #'@export CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { diff --git a/R/SelectPeriodOnData.R b/R/SelectPeriodOnData.R index 94bcfe9..016133b 100644 --- a/R/SelectPeriodOnData.R +++ b/R/SelectPeriodOnData.R @@ -11,7 +11,7 @@ #' the data by providing a list of two elements: the final day of the period #' and the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. More than one +#' compute select the dates. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -23,19 +23,19 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +#'dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) #'class(exp) <- 's2dv_cube' #'Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) #'@import multiApply #'@export -CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', +CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -79,7 +79,7 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', #' to select from the data. The first element is the final day of the period #' and the second element is the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. Parameters +#' compute select the dates. By default, it is set to 'time'. Parameters #' 'data' and 'dates' #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -90,19 +90,19 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', #' #'@examples #'data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 214, sdate = 3) +#'dim(Dates) <- c(time = 214, sdate = 3) #'Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) #'@import multiApply #'@export SelectPeriodOnData <- function(data, dates, start, end, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { if (is.null(dim(dates))) { dim(dates) <- length(dates) names(dim(dates)) <- time_dim diff --git a/R/SelectPeriodOnDates.R b/R/SelectPeriodOnDates.R index fcb1a4c..0919c5d 100644 --- a/R/SelectPeriodOnDates.R +++ b/R/SelectPeriodOnDates.R @@ -10,7 +10,7 @@ #' select from the data by providing a list of two elements: the final day of #' the period and the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. More than one +#' compute select the dates. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -28,11 +28,11 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 214, sdate = 3) +#'dim(Dates) <- c(time = 214, sdate = 3) #'Period <- SelectPeriodOnDates(Dates, start = list(21, 6), end = list(21, 9)) #'@export SelectPeriodOnDates <- function(dates, start, end, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { if (is.null(dim(dates))) { dim(dates) <- length(dates) names(dim(dates)) <- time_dim diff --git a/R/Threshold.R b/R/Threshold.R index 73e3715..9efaebd 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -19,7 +19,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -40,21 +40,21 @@ #'threshold <- 0.9 #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_Threshold(exp, threshold, start = list(21, 4), end = list(21, 6)) #' #'@import multiApply #'@export CST_Threshold <- function(data, threshold, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index 38a3ff4..b7e33cf 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -42,7 +42,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -59,14 +59,14 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' #'TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3, #' start = list(21, 4), @@ -77,7 +77,7 @@ #'@export CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', start = NULL, end = NULL, - time_dim = 'ftime', + time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -188,7 +188,7 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -203,14 +203,14 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'values by values exceeding the threshold. #'@examples -#'data <- array(1:100, c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#'data <- array(1:100, c(member = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #' #'threshold <- array(1:4, c(lat = 4)) #'total <- TotalSpellTimeExceedingThreshold(data, threshold, dates = Dates, @@ -221,7 +221,7 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'@export TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { # data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index 94d2c53..4d46260 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -45,7 +45,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). @@ -65,14 +65,14 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' #'DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 23, start = list(21, 4), #' end = list(21, 6)) @@ -82,7 +82,7 @@ #'@export CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', start = NULL, end = NULL, - time_dim = 'ftime', + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -194,7 +194,7 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). @@ -208,14 +208,14 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' #'@examples #'data <- array(rnorm(5 * 3 * 214 * 2)*23, -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #'DOT <- TotalTimeExceedingThreshold(data, threshold = 23, dates = Dates, #' start = list(21, 4), end = list(21, 6)) #' @@ -223,7 +223,7 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #'@export TotalTimeExceedingThreshold <- function(data, threshold, op = '>', dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # data if (is.null(data)) { diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index 76092dd..dc12fb4 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -32,7 +32,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -42,7 +42,7 @@ #'@examples #'wind <- NULL #'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) #'wind$coords <- list(lat = c(40, 41), lon = 1:5) #'variable <- list(varName = 'sfcWind', #' metadata = list(sfcWind = list(level = 'Surface'))) @@ -54,7 +54,7 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #'wind$attrs$Dates <- Dates #'class(wind) <- 's2dv_cube' #'WCF <- CST_WindCapacityFactor(wind, IEC_class = "III", @@ -62,7 +62,7 @@ #' #'@export CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", "III"), - start = NULL, end = NULL, time_dim = 'ftime', + start = NULL, end = NULL, time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(wind, 's2dv_cube')) { diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index 3944e3d..3dc835a 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -21,7 +21,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -32,7 +32,7 @@ #'@examples #'wind <- NULL #'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) #'wind$coords <- list(lat = c(40, 41), lon = 1:5) #'variable <- list(varName = 'sfcWind', #' metadata = list(sfcWind = list(level = 'Surface'))) @@ -44,7 +44,7 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'dim(Dates) <- c(sdate = 3, time = 214) #'wind$attrs$Dates <- Dates #'class(wind) <- 's2dv_cube' #'WPD <- CST_WindPowerDensity(wind, start = list(21, 4), @@ -52,7 +52,7 @@ #' #'@export CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(wind, 's2dv_cube')) { stop("Parameter 'wind' must be of the class 's2dv_cube'.") diff --git a/man/AbsToProbs.Rd b/man/AbsToProbs.Rd index 7717c91..a4e99ba 100644 --- a/man/AbsToProbs.Rd +++ b/man/AbsToProbs.Rd @@ -9,7 +9,7 @@ AbsToProbs( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -36,7 +36,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -62,17 +62,17 @@ Distribution Function excluding the corresponding initialization. } \examples{ exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) + time = 9, lat = 2, lon = 2)) exp_probs <- AbsToProbs(exp) data <- array(rnorm(5 * 3 * 61 * 1), - c(member = 5, sdate = 3, ftime = 61, lon = 1)) + c(member = 5, sdate = 3, time = 61, lon = 1)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-06-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-06-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-06-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 61, sdate = 3) +dim(Dates) <- c(time = 61, sdate = 3) exp_probs <- AbsToProbs(data, dates = Dates, start = list(21, 4), end = list(21, 6)) diff --git a/man/AccumulationExceedingThreshold.Rd b/man/AccumulationExceedingThreshold.Rd index 0f9a64a..cf6c8df 100644 --- a/man/AccumulationExceedingThreshold.Rd +++ b/man/AccumulationExceedingThreshold.Rd @@ -12,7 +12,7 @@ AccumulationExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -55,7 +55,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) @@ -85,7 +85,7 @@ function: \examples{ # Assuming data is already (tasmax + tasmin)/2 - 10 data <- array(rnorm(5 * 3 * 214 * 2, mean = 25, sd = 3), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), end = list(31, 10)) } diff --git a/man/CST_AbsToProbs.Rd b/man/CST_AbsToProbs.Rd index 055bf6b..ef8f42d 100644 --- a/man/CST_AbsToProbs.Rd +++ b/man/CST_AbsToProbs.Rd @@ -8,7 +8,7 @@ CST_AbsToProbs( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -30,7 +30,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -56,17 +56,17 @@ Distribution Function excluding the corresponding initialization. \examples{ exp <- NULL exp$data <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) + time = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' exp_probs <- CST_AbsToProbs(exp) exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) exp_probs <- CST_AbsToProbs(data = exp, start = list(21, 4), end = list(21, 6)) } diff --git a/man/CST_AccumulationExceedingThreshold.Rd b/man/CST_AccumulationExceedingThreshold.Rd index ff02e4c..2bdee76 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -11,7 +11,7 @@ CST_AccumulationExceedingThreshold( diff = FALSE, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -51,7 +51,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) @@ -86,7 +86,7 @@ function: \examples{ exp <- NULL exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) class(exp) <- 's2dv_cube' Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), @@ -94,7 +94,7 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) exp$attrs$Dates <- Dates AT <- CST_AccumulationExceedingThreshold(data = exp, threshold = 100, start = list(21, 4), diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index a49c9dc..9832912 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -11,7 +11,7 @@ CST_MergeRefToExp( end1 = NULL, start2 = NULL, end2 = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", ncores = NULL ) @@ -49,7 +49,7 @@ the final month of the period.} \item{time_dim}{A character string indicating the name of the temporal dimension that will be used to combine the two arrays. By default, it is set -to 'ftime'. Also, it will be used to subset the data in a requested +to 'time'. Also, it will be used to subset the data in a requested period.} \item{memb_dim}{A character string indicating the name of the member @@ -98,16 +98,16 @@ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) -dim(data_dates) <- c(ftime = 154, sdate = 2) +dim(data_dates) <- c(time = 154, sdate = 2) data <- NULL -data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) +data$data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) data$attrs$Dates<- data_dates class(data) <- 's2dv_cube' ref_dates <- seq(as.Date("01-01-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day") -dim(ref_dates) <- c(ftime = 350, sdate = 2) +dim(ref_dates) <- c(time = 350, sdate = 2) ref <- NULL -ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) +ref$data <- array(1001:1700, c(time = 350, sdate = 2)) ref$attrs$Dates <- ref_dates class(ref) <- 's2dv_cube' new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 77f4a38..2c8fb5a 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -8,7 +8,7 @@ CST_PeriodAccumulation( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -29,7 +29,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -63,18 +63,18 @@ by using this function: \examples{ exp <- NULL exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) + time = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' TP <- CST_PeriodAccumulation(exp) exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) exp$attrs$Dates <- Dates SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) dim(SprR$data) diff --git a/man/CST_QThreshold.Rd b/man/CST_QThreshold.Rd index 5a68bc3..b168375 100644 --- a/man/CST_QThreshold.Rd +++ b/man/CST_QThreshold.Rd @@ -9,7 +9,7 @@ CST_QThreshold( threshold, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -35,7 +35,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -80,19 +80,19 @@ and memb_dim parameters: \examples{ threshold <- 26 exp <- NULL -exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, ftime = 2)) +exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, time = 2)) class(exp) <- 's2dv_cube' exp_probs <- CST_QThreshold(exp, threshold) exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*50), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' exp_probs <- CST_QThreshold(exp, threshold, start = list(21, 4), end = list(21, 6)) diff --git a/man/CST_SelectPeriodOnData.Rd b/man/CST_SelectPeriodOnData.Rd index 22b2a9c..5f12633 100644 --- a/man/CST_SelectPeriodOnData.Rd +++ b/man/CST_SelectPeriodOnData.Rd @@ -4,7 +4,7 @@ \alias{CST_SelectPeriodOnData} \title{Select a period on Data on 's2dv_cube' objects} \usage{ -CST_SelectPeriodOnData(data, start, end, time_dim = "ftime", ncores = NULL) +CST_SelectPeriodOnData(data, start, end, time_dim = "time", ncores = NULL) } \arguments{ \item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in @@ -19,7 +19,7 @@ the data by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. More than one +compute select the dates. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -36,14 +36,14 @@ Auxiliary function to subset data for a specific period. \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) } diff --git a/man/CST_Threshold.Rd b/man/CST_Threshold.Rd index e513ec0..2b4ea2f 100644 --- a/man/CST_Threshold.Rd +++ b/man/CST_Threshold.Rd @@ -9,7 +9,7 @@ CST_Threshold( threshold, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", na.rm = FALSE, @@ -35,7 +35,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -67,14 +67,14 @@ given a dataset. threshold <- 0.9 exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' exp_probs <- CST_Threshold(exp, threshold, start = list(21, 4), end = list(21, 6)) diff --git a/man/CST_TotalSpellTimeExceedingThreshold.Rd b/man/CST_TotalSpellTimeExceedingThreshold.Rd index 0715414..940478f 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -11,7 +11,7 @@ CST_TotalSpellTimeExceedingThreshold( op = ">", start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -48,7 +48,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -83,14 +83,14 @@ by using function \code{AbsToProbs}. See section @examples. \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3, start = list(21, 4), diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index 4a1f736..cd99163 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -10,7 +10,7 @@ CST_TotalTimeExceedingThreshold( op = ">", start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -46,7 +46,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or @@ -90,14 +90,14 @@ indices for heat stress can be obtained by using this function: \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(sdate = 3, ftime = 214) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 23, start = list(21, 4), end = list(21, 6)) diff --git a/man/CST_WindCapacityFactor.Rd b/man/CST_WindCapacityFactor.Rd index 84c057d..cea2b06 100644 --- a/man/CST_WindCapacityFactor.Rd +++ b/man/CST_WindCapacityFactor.Rd @@ -9,7 +9,7 @@ CST_WindCapacityFactor( IEC_class = c("I", "I/II", "II", "II/III", "III"), start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -35,7 +35,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -60,7 +60,7 @@ below). \examples{ wind <- NULL wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), - c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) wind$coords <- list(lat = c(40, 41), lon = 1:5) variable <- list(varName = 'sfcWind', metadata = list(sfcWind = list(level = 'Surface'))) @@ -72,7 +72,7 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) wind$attrs$Dates <- Dates class(wind) <- 's2dv_cube' WCF <- CST_WindCapacityFactor(wind, IEC_class = "III", diff --git a/man/CST_WindPowerDensity.Rd b/man/CST_WindPowerDensity.Rd index 4b04aed..d37fd9d 100644 --- a/man/CST_WindPowerDensity.Rd +++ b/man/CST_WindPowerDensity.Rd @@ -9,7 +9,7 @@ CST_WindPowerDensity( ro = 1.225, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -53,7 +53,7 @@ it will give inaccurate results if used with period means. \examples{ wind <- NULL wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), - c(member = 5, sdate = 3, ftime = 214, lon = 2, lat = 5)) + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) wind$coords <- list(lat = c(40, 41), lon = 1:5) variable <- list(varName = 'sfcWind', metadata = list(sfcWind = list(level = 'Surface'))) @@ -65,7 +65,7 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) wind$attrs$Dates <- Dates class(wind) <- 's2dv_cube' WPD <- CST_WindPowerDensity(wind, start = list(21, 4), diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index 33b5d42..81cda03 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -13,7 +13,7 @@ MergeRefToExp( end1 = NULL, start2 = NULL, end2 = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", ncores = NULL ) @@ -57,7 +57,7 @@ included in the 'dates2' array.} \item{time_dim}{A character string indicating the name of the temporal dimension that will be used to combine the two arrays. By default, it is set -to 'ftime'. Also, it will be used to subset the data in a requested +to 'time'. Also, it will be used to subset the data in a requested period.} \item{memb_dim}{A character string indicating the name of the member @@ -103,16 +103,16 @@ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) -dim(data_dates) <- c(ftime = 154, sdate = 2) +dim(data_dates) <- c(time = 154, sdate = 2) ref_dates <- seq(as.Date("01-01-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day") -dim(ref_dates) <- c(ftime = 350, sdate = 2) -ref <- array(1001:1700, c(ftime = 350, sdate = 2)) -data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member = 2)) +dim(ref_dates) <- c(time = 350, sdate = 2) +ref <- array(1001:1700, c(time = 350, sdate = 2)) +data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), end1 = list(30, 6), data2 = data, dates2 = data_dates, start2 = list(1, 7), end = list(21, 9), - time_dim = 'ftime') + time_dim = 'time') } \references{ diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 614b65c..e9ee608 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -60,8 +60,8 @@ by using this function: } \examples{ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) -TP <- PeriodAccumulation(exp, time_dim = 'ftime') + time = 9, lat = 2, lon = 2)) +TP <- PeriodAccumulation(exp, time_dim = 'time') data <- array(rnorm(5 * 3 * 214 * 2), c(memb = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), diff --git a/man/SelectPeriodOnData.Rd b/man/SelectPeriodOnData.Rd index caaa0fb..2c6181f 100644 --- a/man/SelectPeriodOnData.Rd +++ b/man/SelectPeriodOnData.Rd @@ -4,7 +4,7 @@ \alias{SelectPeriodOnData} \title{Select a period on Data on multidimensional array objects} \usage{ -SelectPeriodOnData(data, dates, start, end, time_dim = "ftime", ncores = NULL) +SelectPeriodOnData(data, dates, start, end, time_dim = "time", ncores = NULL) } \arguments{ \item{data}{A multidimensional array with named dimensions with at least the @@ -24,7 +24,7 @@ to select from the data. The first element is the final day of the period and the second element is the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. Parameters +compute select the dates. By default, it is set to 'time'. Parameters 'data' and 'dates'} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -40,13 +40,13 @@ Auxiliary function to subset data for a specific period. } \examples{ data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 214, sdate = 3) +dim(Dates) <- c(time = 214, sdate = 3) Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) } diff --git a/man/SelectPeriodOnDates.Rd b/man/SelectPeriodOnDates.Rd index 386fb92..49ecd9b 100644 --- a/man/SelectPeriodOnDates.Rd +++ b/man/SelectPeriodOnDates.Rd @@ -4,7 +4,7 @@ \alias{SelectPeriodOnDates} \title{Select a period on Dates} \usage{ -SelectPeriodOnDates(dates, start, end, time_dim = "ftime", ncores = NULL) +SelectPeriodOnDates(dates, start, end, time_dim = "time", ncores = NULL) } \arguments{ \item{dates}{An array of dates with named dimensions.} @@ -18,7 +18,7 @@ select from the data by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. More than one +compute select the dates. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -39,6 +39,6 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 214, sdate = 3) +dim(Dates) <- c(time = 214, sdate = 3) Period <- SelectPeriodOnDates(Dates, start = list(21, 6), end = list(21, 9)) } diff --git a/man/TotalSpellTimeExceedingThreshold.Rd b/man/TotalSpellTimeExceedingThreshold.Rd index 10124de..ea1a6ab 100644 --- a/man/TotalSpellTimeExceedingThreshold.Rd +++ b/man/TotalSpellTimeExceedingThreshold.Rd @@ -12,7 +12,7 @@ TotalSpellTimeExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -52,7 +52,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -86,14 +86,14 @@ different behaviour consider to modify the 'data' input by substituting NA values by values exceeding the threshold. } \examples{ -data <- array(1:100, c(member = 5, sdate = 3, ftime = 214, lon = 2)) +data <- array(1:100, c(member = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) threshold <- array(1:4, c(lat = 4)) total <- TotalSpellTimeExceedingThreshold(data, threshold, dates = Dates, diff --git a/man/TotalTimeExceedingThreshold.Rd b/man/TotalTimeExceedingThreshold.Rd index 4dc00d0..31f3161 100644 --- a/man/TotalTimeExceedingThreshold.Rd +++ b/man/TotalTimeExceedingThreshold.Rd @@ -11,7 +11,7 @@ TotalTimeExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -50,7 +50,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or @@ -88,14 +88,14 @@ indices for heat stress can be obtained by using this function: } \examples{ data <- array(rnorm(5 * 3 * 214 * 2)*23, - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, ftime = 214) +dim(Dates) <- c(sdate = 3, time = 214) DOT <- TotalTimeExceedingThreshold(data, threshold = 23, dates = Dates, start = list(21, 4), end = list(21, 6)) diff --git a/tests/testthat/test-AbsToProbs.R b/tests/testthat/test-AbsToProbs.R index c2cdc9f..c5693df 100644 --- a/tests/testthat/test-AbsToProbs.R +++ b/tests/testthat/test-AbsToProbs.R @@ -2,7 +2,7 @@ # dat1 dat1 <- NULL dat1$data <- array(rnorm(5 * 2 * 61 * 1), - c(member = 5, sdate = 2, ftime = 61, lon = 1)) + c(member = 5, sdate = 2, time = 61, lon = 1)) Dates1 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), @@ -11,7 +11,7 @@ dat1$attrs$Dates <- Dates1 class(dat1) <- 's2dv_cube' # dat2 Dates2 <- Dates1 -dim(Dates2) <- c(ftime = 61, sdate = 2) +dim(Dates2) <- c(time = 61, sdate = 2) ############################################## test_that("1. Sanity checks", { @@ -53,7 +53,7 @@ test_that("1. Sanity checks", { expect_equal( dim(AbsToProbs(data = dat1$data, dates = Dates2, start = list(21, 4), end = list(21, 6))), - c(member = 5, sdate = 2, ftime = 52, lon = 1) + c(member = 5, sdate = 2, time = 52, lon = 1) ) expect_equal( AbsToProbs(1), diff --git a/tests/testthat/test-AccumulationExceedingThreshold.R b/tests/testthat/test-AccumulationExceedingThreshold.R index baa2c50..2b55776 100644 --- a/tests/testthat/test-AccumulationExceedingThreshold.R +++ b/tests/testthat/test-AccumulationExceedingThreshold.R @@ -6,32 +6,32 @@ library(CSTools) dat1 <- 1:20 # dat2 -dat2_1 <- array(1:40, c(x = 2, ftime = 20)) -thres2_1 <- array(10, dim = c(member = 1, ftime = 1)) -dat2_3 <- array(1:20, c(ftime = 5, sdate = 2, lat = 2)) -thres2_3 <- array(1:5, c(ftime = 5)) -dat2_4 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat2_1 <- array(1:40, c(x = 2, time = 20)) +thres2_1 <- array(10, dim = c(member = 1, time = 1)) +dat2_3 <- array(1:20, c(time = 5, sdate = 2, lat = 2)) +thres2_3 <- array(1:5, c(time = 5)) +dat2_4 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) thres2_4 <- array(1:2, c(lat = 2)) # dat3 -dat3_1 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) -dat3_2 <- array(1:40, c(x = 2, ftime = 20)) +dat3_1 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) +dat3_2 <- array(1:40, c(x = 2, time = 20)) # dat4 set.seed(1) -dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat4 <- array(rnorm(60, 23), c(time = 5, fyear = 3, sdate = 2, lat = 2)) set.seed(1) -thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +thres4_1 <- array(rnorm(20, 20), c(time = 5, sdate = 2, lat = 2)) set.seed(2) -thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +thres4_2 <- array(rnorm(20, 25), c(time = 5, sdate = 2, lat = 2)) set.seed(1) -thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +thres4_3 <- array(rnorm(20, 20), c(time = 5, sdate = 2)) set.seed(2) -thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +thres4_4 <- array(rnorm(20, 25), c(time = 5, sdate = 2)) set.seed(1) -thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +thres4_5 <- array(rnorm(5, 20), c(time = 5)) set.seed(2) -thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +thres4_6 <- array(rnorm(5, 25), c(time = 5)) set.seed(1) thres4_7 <- rnorm(5, 20) set.seed(2) @@ -144,19 +144,19 @@ test_that("2. Output checks", { 155 ) expect_equal( - AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'ftime'), + AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'time'), array(c(375, 390), c(x = 2)) ) expect_equal( - AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'ftime'), + AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'time'), array(c(375, 390), c(x = 2)) ) expect_equal( AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'x'), - array(c(rep(0,5), seq(23, 79, 4)), c(ftime = 20)) + array(c(rep(0,5), seq(23, 79, 4)), c(time = 20)) ) expect_equal( - AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'ftime'), + AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'time'), array(c(375, 390), c(x = 2)) ) # dimensions @@ -169,7 +169,7 @@ test_that("2. Output checks", { c(sdate = 2, lat = 2) ) expect_equal( - dim(AccumulationExceedingThreshold(dat2_4, thres2_4, time_dim = 'ftime')), + dim(AccumulationExceedingThreshold(dat2_4, thres2_4, time_dim = 'time')), c(fyear = 3, sdate = 2, lat = 2) ) @@ -191,11 +191,11 @@ test_that("3. Output checks", { array(c(rep(0,10),55,171), dim = c(fyear = 3, sdate = 2, lat = 2)) ) expect_equal( - AccumulationExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'ftime'), + AccumulationExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'time'), array(c(76, 114), c(x = 2)) ) expect_equal( - AccumulationExceedingThreshold(dat3_2, c(7,11), op = c('>=', '<='), time_dim = 'ftime'), + AccumulationExceedingThreshold(dat3_2, c(7,11), op = c('>=', '<='), time_dim = 'time'), array(c(27, 18), c(x = 2)) ) expect_equal( @@ -219,17 +219,17 @@ test_that("4. Output checks", { tolerance = 0.0001 ) expect_equal( - as.vector(AccumulationExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'ftime'))[1:5], + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'time'))[1:5], c(91.05107, 115.67568, 69.89353, 117.29783, 115.40615), tolerance = 0.0001 ) expect_equal( - as.vector(AccumulationExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'ftime'))[1:5], + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'time'))[1:5], c(91.05107, 115.67568, 69.89353, 117.29783, 94.39550), tolerance = 0.0001 ) expect_equal( - as.vector(AccumulationExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'ftime'))[4:10], + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'time'))[4:10], c(117.29783, 94.39550, 113.25711, 90.85402, 91.89458, 115.14699, 116.19438), tolerance = 0.0001 ) @@ -249,7 +249,7 @@ test_that("5. Seasonal forecasts", { ) # GDD - exp <- array(NA, dim = c(member = 6, sdate = 3, ftime = 214, lat = 4, lon = 4)) + exp <- array(NA, dim = c(member = 6, sdate = 3, time = 214, lat = 4, lon = 4)) exp1 <- drop(CSTools::lonlat_prec$data) * 86400000 exp[, , 1:31, , ] <- exp1 + 10; exp[, , 32:62, , ] <- exp1 + 11 exp[, , 63:93, , ] <- exp1 + 12; exp[, , 94:124, , ] <- exp1 + 13 @@ -262,8 +262,8 @@ test_that("5. Seasonal forecasts", { as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) - dim(Dates) <- c(sdate = 3, ftime = 214) - GDD <- AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime', + dim(Dates) <- c(sdate = 3, time = 214) + GDD <- AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'time', start = list(1, 4), end = list(31, 10), na.rm = TRUE) expect_equal( @@ -275,11 +275,11 @@ test_that("5. Seasonal forecasts", { c(member = 6, sdate = 3, lat = 4, lon = 4) ) expect_error( - AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, start = list(1, 4), end = list(31, 10), time_dim = 'time'), + AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, start = list(1, 4), end = list(31, 10), time_dim = 'ftime'), "Parameter 'time_dim' is not found in 'data' dimension." ) expect_equal( - !any(is.na(AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime',start = list(1, 4), end = list(31, 10)))), + !any(is.na(AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'time',start = list(1, 4), end = list(31, 10)))), !any(is.na(c(1, 1))) ) diff --git a/tests/testthat/test-MergeRefToExp.R b/tests/testthat/test-MergeRefToExp.R index 57cd425..bce5827 100644 --- a/tests/testthat/test-MergeRefToExp.R +++ b/tests/testthat/test-MergeRefToExp.R @@ -5,18 +5,18 @@ dates_data1 <- c(seq(as.Date("11-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("20-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), seq(as.Date("11-07-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("20-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) -dim(dates_data1) <- c(ftime = 10, sdate = 2) +dim(dates_data1) <- c(time = 10, sdate = 2) cube1 <- NULL -cube1$data <- array(1:(2*10*2), c(ftime = 10, sdate = 2, member = 2)) +cube1$data <- array(1:(2*10*2), c(time = 10, sdate = 2, member = 2)) cube1$attrs$Dates <- dates_data1 class(cube1) <- 's2dv_cube' ref_dates1 <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("10-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("10-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) -dim(ref_dates1) <- c(ftime = 10, sdate = 2) +dim(ref_dates1) <- c(time = 10, sdate = 2) cube_ref <- NULL -cube_ref$data <- array(1001:1020, c(ftime = 10, sdate = 2)) +cube_ref$data <- array(1001:1020, c(time = 10, sdate = 2)) cube_ref$attrs$Dates <- ref_dates1 class(cube_ref) <- 's2dv_cube' start1 <- list(3, 7) @@ -25,13 +25,13 @@ start2 <- list(11, 7) end2 <- list(15, 7) # dat1 -ref1 <- array(1001:1020, c(ftime = 10, sdate = 2, member = 1)) -data1 <- array(1:40, c(ftime = 10, sdate = 2, member = 2)) +ref1 <- array(1001:1020, c(time = 10, sdate = 2, member = 1)) +data1 <- array(1:40, c(time = 10, sdate = 2, member = 2)) # dat2 -ref2 <- array(1001:1015, c(ftime = 5, sdate = 1, member = 3)) -data2 <- array(1:6, c(ftime = 3, sdate = 1, member = 2)) +ref2 <- array(1001:1015, c(time = 5, sdate = 1, member = 3)) +data2 <- array(1:6, c(time = 3, sdate = 1, member = 2)) ########################################################################### test_that("1. Input checks", { @@ -59,7 +59,7 @@ test_that("1. Input checks", { "Parameter 'time_dim' must be a character string." ) expect_error( - MergeRefToExp(data1 = ref1, data2 = data1, time_dim = 'time'), + MergeRefToExp(data1 = ref1, data2 = data1, time_dim = 'ftime'), paste0("Parameter 'time_dim' is not found in 'data1' or 'data2' dimension ", "names.") ) @@ -69,29 +69,29 @@ test_that("1. Input checks", { "Parameter 'memb_dim' must be a character string." ) expect_error( - MergeRefToExp(data1 = ref1, data2 = data1, memb_dim = 'time'), + MergeRefToExp(data1 = ref1, data2 = data1, memb_dim = 'ensemble'), paste0("Parameter 'memb_dim' is not found in 'data1' or 'data2' dimension. ", "Set it to NULL if there is no member dimension.") ) # common dimensions expect_error( - MergeRefToExp(data1 = array(1:12, c(sdate = 2, ftime = 2, dat = 3)), - data2 = array(1:16, c(sdate = 2, ftime = 2, var = 4)), + MergeRefToExp(data1 = array(1:12, c(sdate = 2, time = 2, dat = 3)), + data2 = array(1:16, c(sdate = 2, time = 2, var = 4)), memb_dim = NULL), paste0("Parameter 'data1' and 'data2' must have same length of ", "all dimensions except 'memb_dim'.") ) expect_error( - MergeRefToExp(data1 = array(1:12, c(sdate = 2, ftime = 2, dat = 1)), - data2 = array(1:16, c(sdate = 2, ftime = 2)), + MergeRefToExp(data1 = array(1:12, c(sdate = 2, time = 2, dat = 1)), + data2 = array(1:16, c(sdate = 2, time = 2)), memb_dim = NULL), paste0("Parameter 'data1' and 'data2' must have same length of ", "all dimensions except 'memb_dim'.") ) # dates expect_warning( - MergeRefToExp(data1 = array(1:4, c(sdate = 2, ftime = 2, lat = 1)), - data2 = array(1:16, c(sdate = 2, ftime = 2, lat = 1)), + MergeRefToExp(data1 = array(1:4, c(sdate = 2, time = 2, lat = 1)), + data2 = array(1:16, c(sdate = 2, time = 2, lat = 1)), memb_dim = NULL, start1 = list(1, 1), end1 = list(3, 1), start2 = NULL, end2 = NULL), paste0("Parameter 'dates' is NULL and the average of the ", @@ -134,7 +134,7 @@ test_that("2. Output checks: CST_MergeRefToExp", { ) # Dates expect_equal( - dim(res1$data)[c('ftime', 'sdate')], + dim(res1$data)[c('time', 'sdate')], dim(res1$attrs$Dates) ) # data @@ -149,28 +149,28 @@ test_that("2. Output checks: CST_MergeRefToExp", { test_that("3. Output checks: MergeRefToExp", { # Minimum dimensions expect_equal( - MergeRefToExp(data1 = array(1:2, c(ftime = 2)), - data2 = array(1, c(ftime = 1)), memb_dim = NULL), - array(c(1,2,1), dim = c(ftime = 3)) + MergeRefToExp(data1 = array(1:2, c(time = 2)), + data2 = array(1, c(time = 1)), memb_dim = NULL), + array(c(1,2,1), dim = c(time = 3)) ) # res2 res2 <- MergeRefToExp(data1 = ref1, data2 = data1) ## dims expect_equal( dim(res2), - c(ftime = 20, sdate = 2, member = 2) + c(time = 20, sdate = 2, member = 2) ) ## data expect_equal( res2[,1,], - array(c(1001:1010, 1:10, 1001:1010, 21:30), dim = c(ftime = 20, member = 2)) + array(c(1001:1010, 1:10, 1001:1010, 21:30), dim = c(time = 20, member = 2)) ) # res3: multiple different members res3 <- MergeRefToExp(data1 = ref2, data2 = data2) ## dims expect_equal( dim(res3), - c(ftime = 8, sdate = 1, member = 6) + c(time = 8, sdate = 1, member = 6) ) expect_equal( as.vector(res3[1:5, 1, ]), @@ -190,16 +190,16 @@ test_that("3. Output checks: Dates", { seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) - dim(data_dates) <- c(ftime = 154, sdate = 2) + dim(data_dates) <- c(time = 154, sdate = 2) ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1994", "%d-%m-%Y", tz = 'UTC'), "day") - dim(ref_dates) <- c(ftime = 350, sdate = 2) + dim(ref_dates) <- c(time = 350, sdate = 2) ref <- NULL - ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) + ref$data <- array(1001:1700, c(time = 350, sdate = 2)) ref$attrs$Dates <- ref_dates class(ref) <- 's2dv_cube' data <- NULL - data$data <- array(1:(2 * 154 * 2), c(ftime = 154, sdate = 2, member= 2)) + data$data <- array(1:(2 * 154 * 2), c(time = 154, sdate = 2, member= 2)) data$attrs$Dates <- data_dates class(data) <- 's2dv_cube' @@ -211,7 +211,7 @@ test_that("3. Output checks: Dates", { ) output <- array(c(1172:1181, 1:83, 1537:1546, 155:237, 1172:1181, 309:391, - 1537:1546, 463:545), c(ftime = 93, sdate = 2, member = 2)) + 1537:1546, 463:545), c(time = 93, sdate = 2, member = 2)) expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), @@ -227,16 +227,16 @@ test_that("3. Output checks: Dates", { as.Date("01-06-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) - dim(data_dates) <- c(ftime = 2, sdate = 2) + dim(data_dates) <- c(time = 2, sdate = 2) ref_dates <- c(as.Date("01-05-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-05-1994", "%d-%m-%Y", tz = 'UTC')) - dim(ref_dates) <- c(ftime = 1, sdate = 2) + dim(ref_dates) <- c(time = 1, sdate = 2) ref <- NULL - ref$data <- array(1:2, c(ftime = 1, sdate = 2)) + ref$data <- array(1:2, c(time = 1, sdate = 2)) ref$attrs$Dates <- ref_dates class(ref) <- 's2dv_cube' data <- NULL - data$data <- array(1:(2 * 3 * 2), c(ftime = 2, sdate = 2, member = 3)) + data$data <- array(1:(2 * 3 * 2), c(time = 2, sdate = 2, member = 3)) data$attrs$Dates <- data_dates class(data) <- 's2dv_cube' @@ -246,7 +246,7 @@ test_that("3. Output checks: Dates", { as.Date("01-05-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-06-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) - dim(res_dates) <- c(ftime = 3, sdate = 2) + dim(res_dates) <- c(time = 3, sdate = 2) expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), @@ -257,7 +257,7 @@ test_that("3. Output checks: Dates", { output <- abind::abind(t(matrix(rep(1:2, 3), ncol = 2, nrow = 3, byrow = T)), data$data, along = 1) - names(dim(output)) <- c('ftime', 'sdate', 'member') + names(dim(output)) <- c('time', 'sdate', 'member') expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), @@ -280,15 +280,15 @@ test_that("4. Test Seasonal", { tz = 'UTC'), "day"), "%Y-%m-%d")) } dates <- as.Date(dates, tz = 'UTC') - dim.dates <- c(ftime = 215, sweek = 1, sday = 1, + dim.dates <- c(time = 215, sweek = 1, sday = 1, sdate = (hcst.endyear - hcst.inityear) + 1) dim(dates) <- dim.dates ref <- NULL - ref$data <- array(1:(215*25), c(ftime = 215, sdate = 25)) + ref$data <- array(1:(215*25), c(time = 215, sdate = 25)) ref$attrs$Dates <- dates class(ref) <- 's2dv_cube' data <- NULL - data$data <- array(1:(215*25*3), c(ftime = 215, sdate = 25, member=3)) + data$data <- array(1:(215*25*3), c(time = 215, sdate = 25, member=3)) data$attrs$Dates <- dates class(data) <- 's2dv_cube' diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 6898a93..441b021 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -27,14 +27,14 @@ test_that("1. Sanity Checks", { PeriodAccumulation(1:10), 55 ) - data <- array(1:24, c(sdate = 2, ftime = 3, lon = 4)) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) expect_equal( PeriodAccumulation(data), array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4)) ) # Test dates warning expect_warning( - PeriodAccumulation(array(1:10, c(ftime = 10)), + PeriodAccumulation(array(1:10, c(time = 10)), dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), start = list(05, 02), end = list(05, 09)), @@ -43,7 +43,7 @@ test_that("1. Sanity Checks", { ) # start and end when dates is not provided expect_warning( - PeriodAccumulation(array(1:10, c(ftime = 10)), + PeriodAccumulation(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -55,7 +55,7 @@ test_that("1. Sanity Checks", { test_that("2. Seasonal", { exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + c(memb = 1, sdate = 3, time = 214, lon = 2)) exp$dims <- dim(exp$data) exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), @@ -63,7 +63,7 @@ test_that("2. Seasonal", { as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(sum(exp$data[1,1,21:82,1]), sum(exp$data[1,2,21:82,1]), @@ -132,4 +132,4 @@ test_that("3. Subset Dates and check time_bounds", { all(lubridate::day(res$attrs$time_bounds$end) == 20), TRUE ) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-PeriodMax.R b/tests/testthat/test-PeriodMax.R index 97907e6..1d7437a 100644 --- a/tests/testthat/test-PeriodMax.R +++ b/tests/testthat/test-PeriodMax.R @@ -17,7 +17,7 @@ test_that("1. Sanity Checks", { "Parameter 'time_dim' must be a character string." ) expect_error( - PeriodMax(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + PeriodMax(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), "Parameter 'time_dim' is not found in 'data' dimension." ) suppressWarnings( diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index f51f7a1..9f8c4cf 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -23,7 +23,7 @@ test_that("1. Sanity Checks", { "Parameter 'time_dim' must be a character string." ) expect_error( - PeriodMean(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + PeriodMean(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), "Parameter 'time_dim' is not found in 'data' dimension." ) expect_error( diff --git a/tests/testthat/test-PeriodMin.R b/tests/testthat/test-PeriodMin.R index 5ed6c1f..fb97fc2 100644 --- a/tests/testthat/test-PeriodMin.R +++ b/tests/testthat/test-PeriodMin.R @@ -23,7 +23,7 @@ test_that("1. Sanity Checks", { "Parameter 'time_dim' must be a character string." ) expect_error( - PeriodMin(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + PeriodMin(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), "Parameter 'time_dim' is not found in 'data' dimension." ) expect_error( diff --git a/tests/testthat/test-PeriodVariance.R b/tests/testthat/test-PeriodVariance.R index e525644..e1de032 100644 --- a/tests/testthat/test-PeriodVariance.R +++ b/tests/testthat/test-PeriodVariance.R @@ -21,7 +21,7 @@ test_that("1. Sanity Checks", { "Parameter 'time_dim' must be a character string." ) expect_error( - PeriodVariance(array(1:10, dim = c(ftime = 10)), time_dim = 'time'), + PeriodVariance(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), "Parameter 'time_dim' is not found in 'data' dimension." ) expect_error( @@ -62,7 +62,7 @@ test_that("1. Sanity Checks", { test_that("2. Seasonal", { exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + c(memb = 1, sdate = 3, time = 214, lon = 2)) exp$dims <- dim(exp$data) exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), @@ -70,7 +70,7 @@ test_that("2. Seasonal", { as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(var(exp$data[1,1,21:82,1]), var(exp$data[1,2,21:82,1]), diff --git a/tests/testthat/test-QThreshold.R b/tests/testthat/test-QThreshold.R index 57883b1..4d7fc59 100644 --- a/tests/testthat/test-QThreshold.R +++ b/tests/testthat/test-QThreshold.R @@ -4,15 +4,15 @@ library(CSTools) # dat1 threshold <- 26 dat1 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), - as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-05-2001", format = "%d-%m-%Y"), - as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-05-2002", format = "%d-%m-%Y"), - as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) dates1 <- dates0 -dim(dates1) <- c(sdate = 3, ftime = 214) +dim(dates1) <- c(sdate = 3, time = 214) ############################################## test_that("1. Sanity checks", { @@ -56,23 +56,23 @@ test_that("1. Sanity checks", { dim(QThreshold(data, threshold)), c(sdate = 20, x = 2) ) - data <- array(1:40, c(x = 2, ftime = 20)) + data <- array(1:40, c(x = 2, time = 20)) expect_error( QThreshold(data, threshold), "Could not find dimension 'sdate' in 1th object provided in 'data'." ) expect_equal( - dim(QThreshold(data, threshold, sdate_dim = 'ftime')), - c(ftime = 20, x = 2) + dim(QThreshold(data, threshold, sdate_dim = 'time')), + c(time = 20, x = 2) ) - dim(threshold) <- c(member = 1, ftime = 1) + dim(threshold) <- c(member = 1, time = 1) expect_equal( - dim(QThreshold(data, threshold, sdate_dim = 'ftime')), - c(ftime = 20, x = 2) + dim(QThreshold(data, threshold, sdate_dim = 'time')), + c(time = 20, x = 2) ) expect_equal( - dim(QThreshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), - c(ftime = 20, x = 2) + dim(QThreshold(data, threshold, memb_dim = 'x', sdate_dim = 'time')), + c(time = 20, x = 2) ) expect_error( QThreshold(data, threshold, sdate_dim = 'x', ncores = 'Z'), @@ -104,21 +104,21 @@ test_that("1. Sanity checks", { # test different common dimensions - exp <- array(1:61, dim = c(ftime = 61, sdate = 3)) - threshold <- array(1:61, dim = c(ftime = 61)) + exp <- array(1:61, dim = c(time = 61, sdate = 3)) + threshold <- array(1:61, dim = c(time = 61)) Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-06-2002", format = "%d-%m-%Y"), by = 'day')) - dim(Dates) <- c(ftime = 61, sdate = 3, syear = 1) + dim(Dates) <- c(time = 61, sdate = 3, syear = 1) res <- QThreshold(data = exp, dates = Dates, start = list(21, 4), end = list(21, 6), threshold = threshold, - time_dim = 'ftime', sdate_dim = 'sdate') + time_dim = 'time', sdate_dim = 'sdate') expect_equal( dim(res), - c(sdate = 3, ftime = 52) + c(sdate = 3, time = 52) ) # test start and end expect_warning( @@ -130,11 +130,11 @@ test_that("1. Sanity checks", { expect_equal( dim(QThreshold(dat1, threshold = 26, dates = dates1, start = list(21, 4), end = list(21, 6))), - c(sdate = 3, member = 5, ftime = 52, lon = 2) + c(sdate = 3, member = 5, time = 52, lon = 2) ) # start and end when dates is not provided expect_warning( - QThreshold(array(1:61, dim = c(ftime = 61, sdate = 3)), threshold = 25, + QThreshold(array(1:61, dim = c(time = 61, sdate = 3)), threshold = 25, start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -164,7 +164,7 @@ test_that("2. Seasonal forecasts", { obs1_percentile <- QThreshold(obs1, threshold = 35), "'x' must have 1 or more non-missing values" ) - obs2 <- obs[,,,2,,] # one ftime + obs2 <- obs[,,,2,,] # one time obs2_percentile <- QThreshold(obs2, threshold = 35) expect_equal( dim(obs2), diff --git a/tests/testthat/test-SelectPeriod.R b/tests/testthat/test-SelectPeriod.R index deb8656..93fc6eb 100644 --- a/tests/testthat/test-SelectPeriod.R +++ b/tests/testthat/test-SelectPeriod.R @@ -42,19 +42,19 @@ test_that("2. Output checks", { ) # test different common dimensions - exp <- array(1:61, dim = c(ftime = 61)) + exp <- array(1:61, dim = c(time = 61)) Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-06-2002", format = "%d-%m-%Y"), by = 'day')) - dim(Dates) <- c(ftime = 61, sdate = 3) + dim(Dates) <- c(time = 61, sdate = 3) res <- SelectPeriodOnData(data = exp, dates = Dates, start = list(21, 4), end = list(21, 6)) expect_equal( dim(res), - c(ftime = 52) + c(time = 52) ) }) @@ -65,7 +65,7 @@ test_that("3. Decadal", { # decadal: 1 sdate several consequtive years: dates <- seq(as.Date("01-01-2000", "%d-%m-%Y", tz = 'UTC'), as.Date("31-12-2005","%d-%m-%Y", tz = 'UTC'), "day") - dim(dates) <- c(ftime = length(dates)) + dim(dates) <- c(time = length(dates)) # No dims -> test .position output <- c( seq(as.Date("2000-02-01", "%Y-%m-%d"), as.Date("2000-02-10", "%Y-%m-%d"), 'day'), @@ -74,20 +74,20 @@ test_that("3. Decadal", { seq(as.Date("2003-02-01", "%Y-%m-%d"), as.Date("2003-02-10", "%Y-%m-%d"), 'day'), seq(as.Date("2004-02-01", "%Y-%m-%d"), as.Date("2004-02-10", "%Y-%m-%d"), 'day'), seq(as.Date("2005-02-01", "%Y-%m-%d"), as.Date("2005-02-10", "%Y-%m-%d"), 'day')) - dim(output) <- c(ftime = 60) + dim(output) <- c(time = 60) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output ) data <- array(1:(length(dates)*3), - c(memb = 1, ftime = length(dates), lon = 3)) + c(memb = 1, time = length(dates), lon = 3)) expect_equal( SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2)), array(c(c(32:41, 398:407, 763:772, 1128:1137, 1493:1502, 1859:1868), c(32:41, 398:407, 763:772, 1128:1137, 1493:1502, 1859:1868) + 2192, c(32:41, 398:407, 763:772, 1128:1137, 1493:1502, 1859:1868) + 2 * 2192), - c(memb = 1, ftime = 60, lon = 3)) + c(memb = 1, time = 60, lon = 3)) ) output2 <- c( @@ -97,7 +97,7 @@ test_that("3. Decadal", { seq(as.Date("2003-02-01", "%Y-%m-%d"), as.Date("2003-04-10", "%Y-%m-%d"), 'day'), seq(as.Date("2004-02-01", "%Y-%m-%d"), as.Date("2004-04-10", "%Y-%m-%d"), 'day'), seq(as.Date("2005-02-01", "%Y-%m-%d"), as.Date("2005-04-10", "%Y-%m-%d"), 'day')) - dim(output2) <- c(ftime = 416) + dim(output2) <- c(time = 416) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), output2 @@ -108,11 +108,11 @@ test_that("3. Decadal", { array(c(c(32:101, 398:466, 763:831, 1128:1196, 1493:1562, 1859:1927), c(32:101, 398:466, 763:831, 1128:1196, 1493:1562, 1859:1927) + 2192, c(32:101, 398:466, 763:831, 1128:1196, 1493:1562, 1859:1927) + 2 * 2192), - c(memb = 1, ftime = 416, lon = 3)) + c(memb = 1, time = 416, lon = 3)) ) # 1 dim -> test Apply - dim(dates) <- c(ftime = length(dates)) + dim(dates) <- c(time = length(dates)) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output @@ -125,50 +125,50 @@ test_that("3. Decadal", { # decadal: 5 sdates several consequtive years dates <- rep(seq(as.Date("01-01-2000", "%d-%m-%Y", tz = 'UTC'), as.Date("31-12-2005","%d-%m-%Y", tz = 'UTC'), "day"), 5) - dim(dates) <- c(ftime = 2192, sdate = 5) + dim(dates) <- c(time = 2192, sdate = 5) output3 <- rep(output, 5) - dim(output3) <- c(ftime = 60, sdate = 5) + dim(output3) <- c(time = 60, sdate = 5) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output3) data <- array(1:(length(dates)*3), - c(memb = 1, sdate = 5, ftime = length(dates)/5, lon = 3)) + c(memb = 1, sdate = 5, time = length(dates)/5, lon = 3)) expect_equal( #To be extended for all sdate dimensions: SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2))[1,1, ,1], c(1:10 * 5 + 151, 1:10 * 5 + 1981, 1:10 * 5 + 3806, 1:10 * 5 + 5631, 1:10 * 5 + 7456, 1:10 * 5 + 9286) ) output4 <- rep(output2, 5) - dim(output4) <- c(ftime = 416, sdate = 5) + dim(output4) <- c(time = 416, sdate = 5) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), output4 ) - expect_equal( #To be extended for all ftime dimensions: + expect_equal( #To be extended for all time dimensions: SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4))[1, ,1,1], 156:160 ) - # Multiple dims: sdate, fyear, ftime + # Multiple dims: sdate, fyear, time dates <- CSTools::SplitDim(dates, indices = dates[,1], - split_dim = 'ftime', freq = 'year') + split_dim = 'time', freq = 'year') dates <- as.POSIXct(dates * 24 * 3600, origin = '1970-01-01', tz = 'UTC') - output5 <- CSTools::SplitDim(output3, indices = output3[,1], split_dim = 'ftime' , freq = 'year') + output5 <- CSTools::SplitDim(output3, indices = output3[,1], split_dim = 'time' , freq = 'year') output5 <- as.POSIXct(output5 * 24 * 3600, origin = '1970-01-01', tz = 'UTC') expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output5 ) data <- array(1:(366*6*5*3), - c(memb = 1, sdate = 5, year = 6, ftime = 366, lon = 3)) + c(memb = 1, sdate = 5, year = 6, time = 366, lon = 3)) expect_equal( SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2)), - InsertDim(Reorder(data[, , , 32:41, ], c('sdate', 'year', 'ftime', 'lon')), + InsertDim(Reorder(data[, , , 32:41, ], c('sdate', 'year', 'time', 'lon')), len = 1, pos = 1, name = 'memb') ) - output6 <- CSTools::SplitDim(output4, indices = output4[,1], split_dim = 'ftime' , freq = 'year') + output6 <- CSTools::SplitDim(output4, indices = output4[,1], split_dim = 'time' , freq = 'year') output6 <- as.POSIXct(output6 * 24 * 3600, origin = '1970-01-01', tz = 'UTC') expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), @@ -177,13 +177,13 @@ test_that("3. Decadal", { # expect_equal( # to be fixed: # SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4)), # (931:935), outer(seq(931, 3001, 30), 0:4, '+') - # InsertDim(Reorder(data[,,,32:41,], c('ftime', 'sdate', 'year', 'lon')), + # InsertDim(Reorder(data[,,,32:41,], c('time', 'sdate', 'year', 'lon')), # len = 1, pos = 2, name = 'memb')) }) ############################################## test_that("4. Seasonal", { - # 1 start month, select the required 'ftime' of each 'sdate' in-between the entire timeseries + # 1 start month, select the required 'time' of each 'sdate' in-between the entire timeseries dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2001", format = "%d-%m-%Y"), @@ -192,7 +192,7 @@ test_that("4. Seasonal", { as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2003", format = "%d-%m-%Y"), as.Date("31-10-2003", format = "%d-%m-%Y"), by = 'day')) - dim(dates) <- c(ftime = 214, sdate = 4) + dim(dates) <- c(time = 214, sdate = 4) output <- c(seq(as.Date("21-04-2000", format = "%d-%m-%Y"), as.Date("21-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("21-04-2001", format = "%d-%m-%Y"), @@ -201,7 +201,7 @@ test_that("4. Seasonal", { as.Date("21-06-2002", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("21-04-2003", format = "%d-%m-%Y"), as.Date("21-06-2003", format = "%d-%m-%Y"), by = 'day')) - dim(output) <- c(ftime = 62, sdate = 4) + dim(output) <- c(time = 62, sdate = 4) expect_equal( SelectPeriodOnDates(dates, start = list(21, 4), end = list(21, 6)), output @@ -209,8 +209,8 @@ test_that("4. Seasonal", { # following the above case, and select the data data <- array(1:(5 * 4 * 214 * 2), - c(memb = 5, sdate = 4, ftime = 214, lon = 2)) - dim(dates) <- c(ftime = 214, sdate = 4) + c(memb = 5, sdate = 4, time = 214, lon = 2)) + dim(dates) <- c(time = 214, sdate = 4) expect_equal( SelectPeriodOnData(data, dates, start = list(21, 4), end = list(21, 6))[1,1, ,1], @@ -220,7 +220,7 @@ test_that("4. Seasonal", { # when selecting the days across two years dates <- seq(as.Date("2000-01-01", "%Y-%m-%d"), as.Date("2003-12-31", "%Y-%m-%d"), 'day') - dim(dates) <- c(ftime = 1461) + dim(dates) <- c(time = 1461) output1 <- c(seq(as.Date("01-01-2000", format = "%d-%m-%Y"), as.Date("31-01-2000", format = "%d-%m-%Y"), by = 'day'), @@ -232,7 +232,7 @@ test_that("4. Seasonal", { as.Date("31-01-2003", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-12-2003", format = "%d-%m-%Y"), as.Date("31-12-2003", format = "%d-%m-%Y"), by = 'day')) - dim(output1) <- c(ftime = 31 * 8) + dim(output1) <- c(time = 31 * 8) expect_equal( SelectPeriodOnDates(dates, start = list(1, 12), end = list(31, 1)), @@ -241,12 +241,12 @@ test_that("4. Seasonal", { # following the above case, and select the data data1 <- array(1:(length(dates) * 2), - c(memb = 1, ftime = length(dates), lon = 2)) + c(memb = 1, time = length(dates), lon = 2)) expect_equal( SelectPeriodOnData(data1, dates, start = list(1, 12), end = list(31, 1)), array(c(c(1:31, 336:397, 701:762, 1066:1127, 1431:1461), c(1:31, 336:397, 701:762, 1066:1127, 1431:1461) + 1461), - c(memb = 1, ftime = 31 * 8, lon = 2)) + c(memb = 1, time = 31 * 8, lon = 2)) ) }) diff --git a/tests/testthat/test-Threshold.R b/tests/testthat/test-Threshold.R index 7cb83cf..677c21e 100644 --- a/tests/testthat/test-Threshold.R +++ b/tests/testthat/test-Threshold.R @@ -4,7 +4,7 @@ library(CSTools) # dat1 threshold <- 0.9 dat1 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), @@ -12,7 +12,7 @@ dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) dates1 <- dates0 -dim(dates1) <- c(sdate = 3, ftime = 214) +dim(dates1) <- c(sdate = 3, time = 214) ############################################## test_that("1. Sanity checks", { @@ -57,23 +57,23 @@ test_that("1. Sanity checks", { Threshold(data, threshold, memb_dim = NULL), array(c(2.8, 4.6, 3.8, 5.6), c(probs = 2, lat = 2)) ) - data <- array(1:40, c(x = 2, ftime = 20)) + data <- array(1:40, c(x = 2, time = 20)) expect_error( Threshold(data, threshold), "Could not find dimension 'sdate' in 1th object provided in 'data'." ) expect_equal( - dim(Threshold(data, threshold, sdate_dim = 'ftime', memb_dim = NULL)), + dim(Threshold(data, threshold, sdate_dim = 'time', memb_dim = NULL)), c(probs = 2, x = 2) ) # threshold with dimensions ? - dim(threshold) <- c(member = 2, ftime = 1) + dim(threshold) <- c(member = 2, time = 1) expect_equal( - dim(Threshold(data, threshold, sdate_dim = 'ftime', memb_dim = NULL)), + dim(Threshold(data, threshold, sdate_dim = 'time', memb_dim = NULL)), c(probs = 2, x = 2) ) expect_equal( - dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), + dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'time')), c(probs = 2) ) # test start and end @@ -86,11 +86,11 @@ test_that("1. Sanity checks", { expect_equal( dim(Threshold(dat1, threshold = 0.8, dates = dates1, start = list(21, 4), end = list(21, 6))), - c(ftime = 52, lon = 2) + c(time = 52, lon = 2) ) # start and end when dates is not provided expect_warning( - Threshold(array(1:366, dim = c(ftime = 61, sdate = 3, member = 2)), + Threshold(array(1:366, dim = c(time = 61, sdate = 3, member = 2)), threshold = 0.8, start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") diff --git a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R index b66c5ae..e65ec1e 100644 --- a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R @@ -5,36 +5,36 @@ dat <- array(1:20, dim = c(2, 10)) thres <- 10 dat1 <- array(1:20, dim = c(time = 2, lat = 10)) thres1 <- array(1:2, dim = c(time = 2)) -dat1_2 <- array(1:40, c(x = 2, ftime = 20)) -threshold1_2 <- array(rep(10, 20), dim = c(member = 1, ftime = 20)) +dat1_2 <- array(1:40, c(x = 2, time = 20)) +threshold1_2 <- array(rep(10, 20), dim = c(member = 1, time = 20)) # dat2 -dat2_1 <- array(1:40, c(x = 2, ftime = 20)) -thres2_1 <- array(10, dim = c(member = 1, ftime = 1)) -dat2_3 <- array(1:20, c(ftime = 5, sdate = 2, lat = 2)) -thres2_3 <- array(1:5, c(ftime = 5)) -dat2_4 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat2_1 <- array(1:40, c(x = 2, time = 20)) +thres2_1 <- array(10, dim = c(member = 1, time = 1)) +dat2_3 <- array(1:20, c(time = 5, sdate = 2, lat = 2)) +thres2_3 <- array(1:5, c(time = 5)) +dat2_4 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) thres2_4 <- array(1:2, c(lat = 2)) # dat3 -dat3_1 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) -dat3_2 <- array(1:40, c(x = 2, ftime = 20)) +dat3_1 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) +dat3_2 <- array(1:40, c(x = 2, time = 20)) # dat4 set.seed(1) -dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat4 <- array(rnorm(60, 23), c(time = 5, fyear = 3, sdate = 2, lat = 2)) set.seed(1) -thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +thres4_1 <- array(rnorm(20, 20), c(time = 5, sdate = 2, lat = 2)) set.seed(2) -thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +thres4_2 <- array(rnorm(20, 25), c(time = 5, sdate = 2, lat = 2)) set.seed(1) -thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +thres4_3 <- array(rnorm(20, 20), c(time = 5, sdate = 2)) set.seed(2) -thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +thres4_4 <- array(rnorm(20, 25), c(time = 5, sdate = 2)) set.seed(1) -thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +thres4_5 <- array(rnorm(5, 20), c(time = 5)) set.seed(2) -thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +thres4_6 <- array(rnorm(5, 25), c(time = 5)) set.seed(1) thres4_7 <- rnorm(5, 20) set.seed(2) @@ -144,7 +144,7 @@ test_that("1. Sanity checks", { ) # start and end when dates is not provided expect_warning( - TotalSpellTimeExceedingThreshold(array(1:10, c(ftime = 10)), threshold = 5, spell = 2, + TotalSpellTimeExceedingThreshold(array(1:10, c(time = 10)), threshold = 5, spell = 2, start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -172,7 +172,7 @@ test_that("2. Output checks", { ) expect_equal( TotalSpellTimeExceedingThreshold(dat2_1, thres2_1, spell = 2, time_dim = 'x'), - array(c(rep(0,5), rep(2,15)), c(ftime = 20)) + array(c(rep(0,5), rep(2,15)), c(time = 20)) ) # dimensions expect_equal( @@ -184,7 +184,7 @@ test_that("2. Output checks", { c(sdate = 2, lat = 2) ) expect_equal( - dim(TotalSpellTimeExceedingThreshold(dat2_4, thres2_4, spell = 3, time_dim = 'ftime')), + dim(TotalSpellTimeExceedingThreshold(dat2_4, thres2_4, spell = 3, time_dim = 'time')), c(fyear = 3, sdate = 2, lat = 2) ) }) @@ -206,11 +206,11 @@ test_that("3. Output checks", { array(c(rep(0,11),3), dim = c(fyear = 3, sdate = 2, lat = 2)) ) expect_equal( - TotalSpellTimeExceedingThreshold(dat3_2, c(46, 35), spell = 3, op = c("<", ">"), time_dim = 'ftime'), + TotalSpellTimeExceedingThreshold(dat3_2, c(46, 35), spell = 3, op = c("<", ">"), time_dim = 'time'), array(c(0, 3), c(x = 2)) ) expect_equal( - TotalSpellTimeExceedingThreshold(dat3_2, c(7,11), spell = 3, op = c('>=', '<='), time_dim = 'ftime'), + TotalSpellTimeExceedingThreshold(dat3_2, c(7,11), spell = 3, op = c('>=', '<='), time_dim = 'time'), array(c(3, 0), c(x = 2)) ) expect_equal( @@ -233,15 +233,15 @@ test_that("4. Output checks", { c(3, 5, 0) ) expect_equal( - as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), spell = 4, c(">", "<="), time_dim = 'ftime'))[1:5], + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), spell = 4, c(">", "<="), time_dim = 'time'))[1:5], c(0, 5, 0, 5, 5) ) expect_equal( - as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), spell = 3, op = c("<", ">="), time_dim = 'ftime'))[1:5], + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), spell = 3, op = c("<", ">="), time_dim = 'time'))[1:5], c(3, 5, 0, 5, 3) ) expect_equal( - as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), spell = 3, op = c('>=', '<='), time_dim = 'ftime'))[4:10], + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), spell = 3, op = c('>=', '<='), time_dim = 'time'))[4:10], c(5, 3, 5, 4, 3, 5, 5) ) @@ -252,20 +252,20 @@ test_that("4. Output checks", { test_that("5. Seasonal Forecasts", { exp <- CSTools::lonlat_temp$exp exp$data <- exp$data[1,1:3,1:3,,,] - res <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 260, spell = 2) + res <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 260, spell = 2, time_dim = 'ftime') expect_equal( res$data[,,1,1], array(c(3,3,3,3,3,3,3,3,3), c(member = 3, sdate = 3)) ) # compare with percentile thresholdP <- Threshold(exp$data, threshold = 0.9) - WSDI <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP, spell = 2) + WSDI <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP, spell = 2, time_dim = 'ftime') expect_equal( WSDI$data[3,3,3,], c(rep(0, 6), rep(2, 2), 0, 2, 0, 2, rep(0, 29), 2, rep(0, 11)) ) thresholdP1 <- thresholdP[1,,] - WSDI1 <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP1, spell = 2) + WSDI1 <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP1, spell = 2, time_dim = 'ftime') expect_equal( WSDI1$data[3,3,3,], c(rep(0, 53))) diff --git a/tests/testthat/test-TotalTimeExceedingThreshold.R b/tests/testthat/test-TotalTimeExceedingThreshold.R index c025c3e..cba27ae 100644 --- a/tests/testthat/test-TotalTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalTimeExceedingThreshold.R @@ -5,36 +5,36 @@ dat <- array(1:20, dim = c(2, 10)) thres <- 10 dat1 <- array(1:20, dim = c(time = 2, lat = 10)) thres1 <- array(1:2, dim = c(time = 2)) -dat1_2 <- array(1:40, c(x = 2, ftime = 20)) -threshold1_2 <- array(rep(10, 20), dim = c(member = 1, ftime = 20)) +dat1_2 <- array(1:40, c(x = 2, time = 20)) +threshold1_2 <- array(rep(10, 20), dim = c(member = 1, time = 20)) # dat2 -dat2_1 <- array(1:40, c(x = 2, ftime = 20)) -thres2_1 <- array(10, dim = c(member = 1, ftime = 1)) -dat2_3 <- array(1:20, c(ftime = 5, sdate = 2, lat = 2)) -thres2_3 <- array(1:5, c(ftime = 5)) -dat2_4 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat2_1 <- array(1:40, c(x = 2, time = 20)) +thres2_1 <- array(10, dim = c(member = 1, time = 1)) +dat2_3 <- array(1:20, c(time = 5, sdate = 2, lat = 2)) +thres2_3 <- array(1:5, c(time = 5)) +dat2_4 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) thres2_4 <- array(1:2, c(lat = 2)) # dat3 -dat3_1 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) -dat3_2 <- array(1:40, c(x = 2, ftime = 20)) +dat3_1 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) +dat3_2 <- array(1:40, c(x = 2, time = 20)) # dat4 set.seed(1) -dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat4 <- array(rnorm(60, 23), c(time = 5, fyear = 3, sdate = 2, lat = 2)) set.seed(1) -thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +thres4_1 <- array(rnorm(20, 20), c(time = 5, sdate = 2, lat = 2)) set.seed(2) -thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +thres4_2 <- array(rnorm(20, 25), c(time = 5, sdate = 2, lat = 2)) set.seed(1) -thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +thres4_3 <- array(rnorm(20, 20), c(time = 5, sdate = 2)) set.seed(2) -thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +thres4_4 <- array(rnorm(20, 25), c(time = 5, sdate = 2)) set.seed(1) -thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +thres4_5 <- array(rnorm(5, 20), c(time = 5)) set.seed(2) -thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +thres4_6 <- array(rnorm(5, 25), c(time = 5)) set.seed(1) thres4_7 <- rnorm(5, 20) set.seed(2) @@ -136,7 +136,7 @@ test_that("1. Sanity checks", { ) # start and end when dates is not provided expect_warning( - TotalTimeExceedingThreshold(array(1:10, c(ftime = 10)), threshold = 5, + TotalTimeExceedingThreshold(array(1:10, c(time = 10)), threshold = 5, start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -165,7 +165,7 @@ test_that("2. Output checks", { ) expect_equal( TotalTimeExceedingThreshold(dat2_1, thres2_1, time_dim = 'x'), - array(c(rep(0,5), rep(2,15)), c(ftime = 20)) + array(c(rep(0,5), rep(2,15)), c(time = 20)) ) # dimensions expect_equal( @@ -177,7 +177,7 @@ test_that("2. Output checks", { c(sdate = 2, lat = 2) ) expect_equal( - dim(TotalTimeExceedingThreshold(dat2_4, thres2_4, time_dim = 'ftime')), + dim(TotalTimeExceedingThreshold(dat2_4, thres2_4, time_dim = 'time')), c(fyear = 3, sdate = 2, lat = 2) ) }) @@ -198,11 +198,11 @@ test_that("3. Output checks", { array(c(rep(0, 10), 1, 3), dim = c(fyear = 3, sdate = 2, lat = 2)) ) expect_equal( - TotalTimeExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'ftime'), + TotalTimeExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'time'), array(c(2, 3), c(x = 2)) ) expect_equal( - TotalTimeExceedingThreshold(dat3_2, c(7, 11), op = c('>=', '<='), time_dim = 'ftime'), + TotalTimeExceedingThreshold(dat3_2, c(7, 11), op = c('>=', '<='), time_dim = 'time'), array(c(3, 2), c(x = 2)) ) expect_equal( @@ -223,15 +223,15 @@ test_that("4. Output checks", { c(4, 5, 3) ) expect_equal( - as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'ftime'))[1:5], + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'time'))[1:5], c(4, 5, 3, 5, 5) ) expect_equal( - as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'ftime'))[1:5], + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'time'))[1:5], c(4, 5, 3, 5, 4) ) expect_equal( - as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'ftime'))[4:10], + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'time'))[4:10], c(5, 4, 5, 4, 4, 5, 5) ) }) @@ -243,17 +243,17 @@ test_that("5. Seasonal forecasts", { exp <- CSTools::lonlat_temp$exp obs <- CSTools::lonlat_temp$obs exp$data <- exp$data[1, 1:3, , , , ] - 247 - SU35_NoP <- CST_TotalTimeExceedingThreshold(exp, threshold = 35)$data + SU35_NoP <- CST_TotalTimeExceedingThreshold(exp, threshold = 35, time_dim = 'ftime')$data expect_equal( SU35_NoP[1, , 15, 3], c(0, 1, 1, 1, 0, 0) ) # convert to percentile exp_percentile <- AbsToProbs(exp$data) - obs_percentile <- drop(QThreshold(obs$data, threshold = 35)) + obs_percentile <- drop(QThreshold(obs$data, threshold = 35, time_dim = 'ftime')) data <- exp data$data <- exp_percentile - SU35_P <- CST_TotalTimeExceedingThreshold(data, threshold = obs_percentile)$data + SU35_P <- CST_TotalTimeExceedingThreshold(data, threshold = obs_percentile, time_dim = 'ftime')$data expect_equal( SU35_P[2, , 5, 5], c(3, 3, 3, 3, 3, 3) diff --git a/tests/testthat/test-WindCapacityFactor.R b/tests/testthat/test-WindCapacityFactor.R index 3afa27e..a2c3fbf 100644 --- a/tests/testthat/test-WindCapacityFactor.R +++ b/tests/testthat/test-WindCapacityFactor.R @@ -14,7 +14,7 @@ WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") # dat2 dat2 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), @@ -22,7 +22,7 @@ dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) dates2 <- dates0 -dim(dates2) <- c(sdate = 3, ftime = 214) +dim(dates2) <- c(sdate = 3, time = 214) ################################################### test_that("1. Input checks", { @@ -47,7 +47,7 @@ test_that("1. Input checks", { ) # start and end when dates is not provided expect_warning( - WindCapacityFactor(array(1:10, c(ftime = 10)), + WindCapacityFactor(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -74,7 +74,7 @@ test_that("2. Output checks", { expect_equal( dim(WindCapacityFactor(wind = dat2, IEC_class = "III", dates = dates2, start = list(21, 4), end = list(21, 6))), - c(member = 5, sdate = 3, ftime = 52, lon = 2) + c(member = 5, sdate = 3, time = 52, lon = 2) ) }) diff --git a/tests/testthat/test-WindPowerDensity.R b/tests/testthat/test-WindPowerDensity.R index 999235a..e6e981e 100644 --- a/tests/testthat/test-WindPowerDensity.R +++ b/tests/testthat/test-WindPowerDensity.R @@ -13,7 +13,7 @@ class(wind) <- 's2dv_cube' # dat2 dat2 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), @@ -21,7 +21,7 @@ dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) dates2 <- dates0 -dim(dates2) <- c(sdate = 3, ftime = 214) +dim(dates2) <- c(sdate = 3, time = 214) ########################################################################### test_that("1. Input checks", { @@ -46,7 +46,7 @@ test_that("1. Input checks", { ) # start and end when dates is not provided expect_warning( - WindPowerDensity(array(1:10, c(ftime = 10)), + WindPowerDensity(array(1:10, c(time = 10)), start = list(05, 02), end = list(05, 09)), paste0("Parameter 'dates' is NULL and the average of the full data ", "provided in 'data' is computed.") @@ -73,7 +73,7 @@ test_that("2. Output checks", { expect_equal( dim(WindPowerDensity(wind = dat2, dates = dates2, start = list(21, 4), end = list(21, 6))), - c(member = 5, sdate = 3, ftime = 52, lon = 2) + c(member = 5, sdate = 3, time = 52, lon = 2) ) }) -- GitLab From 620c7f6c9a786309080dd0b6c632ba81bd16d69c Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 23 Oct 2023 12:21:17 +0200 Subject: [PATCH 63/87] Subset 'coords' element for CST functions --- R/AccumulationExceedingThreshold.R | 1 + R/PeriodAccumulation.R | 1 + R/PeriodMax.R | 7 ++++--- R/PeriodMean.R | 1 + R/PeriodMin.R | 1 + R/PeriodVariance.R | 1 + R/QThreshold.R | 1 + R/Threshold.R | 3 +++ R/TotalSpellTimeExceedingThreshold.R | 1 + R/TotalTimeExceedingThreshold.R | 1 + 10 files changed, 15 insertions(+), 3 deletions(-) diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index eecded6..0b312e9 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -113,6 +113,7 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = na.rm = na.rm, ncores = ncores) data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index b8dcf9a..41c9b67 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -87,6 +87,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodMax.R b/R/PeriodMax.R index 0806c51..d0004e0 100644 --- a/R/PeriodMax.R +++ b/R/PeriodMax.R @@ -61,8 +61,8 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodMax <- function(data, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, - ncores = NULL) { + time_dim = 'time', na.rm = FALSE, + ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") @@ -80,10 +80,11 @@ CST_PeriodMax <- function(data, start = NULL, end = NULL, Dates <- data$attrs$Dates total <- PeriodMax(data = data$data, dates = Dates, start = start, end = end, - time_dim = time_dim, na.rm = na.rm, ncores = ncores) + time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 7066fdd..69ffc8c 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -83,6 +83,7 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodMin.R b/R/PeriodMin.R index 842e2e8..afe5eb8 100644 --- a/R/PeriodMin.R +++ b/R/PeriodMin.R @@ -84,6 +84,7 @@ CST_PeriodMin <- function(data, start = NULL, end = NULL, data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R index b702981..77bf68d 100644 --- a/R/PeriodVariance.R +++ b/R/PeriodVariance.R @@ -88,6 +88,7 @@ CST_PeriodVariance <- function(data, start = NULL, end = NULL, data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/QThreshold.R b/R/QThreshold.R index 4686cb3..0f20858 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -97,6 +97,7 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, sdate_dim = sdate_dim, ncores = ncores) data$data <- probs data$dims <- dim(probs) + if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, diff --git a/R/Threshold.R b/R/Threshold.R index 9efaebd..ee4fa38 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -76,6 +76,9 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, sdate_dim = sdate_dim, na.rm = na.rm, ncores = ncores) data$data <- thres data$dims <- dim(thres) + data$coords[[memb_dim]] <- NULL + data$coords[[sdate_dim]] <- NULL + if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index b7e33cf..1bc1bb3 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -115,6 +115,7 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> ncores = ncores) data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index 4d46260..5c6bb62 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -119,6 +119,7 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', ncores = ncores) data$data <- total data$dims <- dim(total) + data$coords[[time_dim]] <- NULL if (!is.null(Dates)) { if (!is.null(start) && !is.null(end)) { -- GitLab From f73a36a8a9376f16672a15d1cfa2970a7fa03d96 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 24 Oct 2023 10:11:13 +0200 Subject: [PATCH 64/87] Add ClimProjDiags::Subset and remove auxiliary function .insertdim --- R/QThreshold.R | 3 ++- R/SelectPeriodOnData.R | 20 ++++++++++---------- R/zzz.R | 29 ----------------------------- man/CST_SelectPeriodOnData.Rd | 6 +++--- man/SelectPeriodOnData.Rd | 6 +++--- 5 files changed, 18 insertions(+), 46 deletions(-) diff --git a/R/QThreshold.R b/R/QThreshold.R index 0f20858..19cda3c 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -177,6 +177,7 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #' start = list(21, 4), end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, time_dim = 'time', memb_dim = 'member', @@ -231,7 +232,7 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (time_dim %in% names(dim(threshold))) { if (dim(threshold)[time_dim] == dim(data)[time_dim]) { if (!is.null(dim(dates)) && sdate_dim %in% names(dim(dates))) { - dates_thres <- .arraysubset(dates, dim = sdate_dim, value = 1) + dates_thres <- Subset(dates, along = sdate_dim, indices = 1) threshold <- SelectPeriodOnData(data = threshold, dates = dates_thres, start, end, time_dim = time_dim, ncores = ncores) } else { diff --git a/R/SelectPeriodOnData.R b/R/SelectPeriodOnData.R index 016133b..aedf0b0 100644 --- a/R/SelectPeriodOnData.R +++ b/R/SelectPeriodOnData.R @@ -11,7 +11,7 @@ #' the data by providing a list of two elements: the final day of the period #' and the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'time'. More than one +#' compute select the dates. By default, it is set to 'ftime'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -23,14 +23,14 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, time = 214, lon = 2)) +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) +#'dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) #'class(exp) <- 's2dv_cube' #'Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) #'@import multiApply @@ -79,7 +79,7 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'time', #' to select from the data. The first element is the final day of the period #' and the second element is the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'time'. Parameters +#' compute select the dates. By default, it is set to 'ftime'. Parameters #' 'data' and 'dates' #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -90,16 +90,17 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'time', #' #'@examples #'data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, time = 214, lon = 2)) +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(time = 214, sdate = 3) +#'dim(Dates) <- c(ftime = 214, sdate = 3) #'Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export SelectPeriodOnData <- function(data, dates, start, end, time_dim = 'time', ncores = NULL) { @@ -149,11 +150,10 @@ SelectPeriodOnData <- function(data, dates, start, end, names_data <- sort(names(dim(data))) if (!all(names_res %in% names_data)) { dim_remove <- names_res[-which(names_res %in% names_data)] - res <- .arraysubset(res, dim = dim_remove, value = 1) - dim(res) <- dim(res)[-which(names(dim(res)) %in% dim_remove)] + indices <- as.list(rep(1, length(dim_remove))) + res <- Subset(res, along = dim_remove, indices, drop = 'selected') } - pos <- match(names(dim(data)), names(dim(res))) res <- aperm(res, pos) return(res) -} \ No newline at end of file +} diff --git a/R/zzz.R b/R/zzz.R index cf91639..0724f06 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -24,35 +24,6 @@ return(position) } -# Function to subset dimension indices of an array -.arraysubset <- function(x, dim, value, drop = FALSE) { - indices <- rep(list(bquote()), length(dim(x))) - if (is.character(dim)) { - dim <- which(names(dim(x)) %in% dim) - } - indices[dim] <- value - call <- as.call(c(list(as.name("["), quote(x)), indices, drop = drop)) - eval(call) -} - -# Function to insert a dimension in an array -.insertdim <- function(data, posdim, lendim, name = NULL) { - names(lendim) <- name - data <- array(data, dim = c(dim(data), lendim)) - ## Reorder dimension - if (posdim == 1) { - order <- c(length(dim(data)), 1:(length(dim(data)) - 1)) - data <- aperm(data, order) - } else if (posdim == length(dim(data))) { # last dim - - } else { # middle dim - order <- c(1:(posdim - 1), length(dim(data)), posdim:(length(dim(data)) - 1)) - data <- aperm(data, order) - } - return(data) -} - - #======================= # Read a powercurve file # Create the approximation function diff --git a/man/CST_SelectPeriodOnData.Rd b/man/CST_SelectPeriodOnData.Rd index 5f12633..c3bda0c 100644 --- a/man/CST_SelectPeriodOnData.Rd +++ b/man/CST_SelectPeriodOnData.Rd @@ -19,7 +19,7 @@ the data by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'time'. More than one +compute select the dates. By default, it is set to 'ftime'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -36,14 +36,14 @@ Auxiliary function to subset data for a specific period. \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, time = 214, lon = 2)) + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) +dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) class(exp) <- 's2dv_cube' Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) } diff --git a/man/SelectPeriodOnData.Rd b/man/SelectPeriodOnData.Rd index 2c6181f..18aa296 100644 --- a/man/SelectPeriodOnData.Rd +++ b/man/SelectPeriodOnData.Rd @@ -24,7 +24,7 @@ to select from the data. The first element is the final day of the period and the second element is the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'time'. Parameters +compute select the dates. By default, it is set to 'ftime'. Parameters 'data' and 'dates'} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -40,13 +40,13 @@ Auxiliary function to subset data for a specific period. } \examples{ data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, time = 214, lon = 2)) + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(time = 214, sdate = 3) +dim(Dates) <- c(ftime = 214, sdate = 3) Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) } -- GitLab From 1a35651abd1e03e5409300ad8c2b497a7a99e2bf Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 24 Oct 2023 10:17:09 +0200 Subject: [PATCH 65/87] Correct example; fix pipeline --- R/SelectPeriodOnData.R | 12 ++++++------ man/CST_SelectPeriodOnData.Rd | 6 +++--- man/SelectPeriodOnData.Rd | 6 +++--- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/R/SelectPeriodOnData.R b/R/SelectPeriodOnData.R index aedf0b0..bef70be 100644 --- a/R/SelectPeriodOnData.R +++ b/R/SelectPeriodOnData.R @@ -11,7 +11,7 @@ #' the data by providing a list of two elements: the final day of the period #' and the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. More than one +#' compute select the dates. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -23,14 +23,14 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +#'dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) #'class(exp) <- 's2dv_cube' #'Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) #'@import multiApply @@ -79,7 +79,7 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'time', #' to select from the data. The first element is the final day of the period #' and the second element is the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. Parameters +#' compute select the dates. By default, it is set to 'time'. Parameters #' 'data' and 'dates' #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -90,14 +90,14 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'time', #' #'@examples #'data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 214, sdate = 3) +#'dim(Dates) <- c(time = 214, sdate = 3) #'Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) #'@import multiApply #'@importFrom ClimProjDiags Subset diff --git a/man/CST_SelectPeriodOnData.Rd b/man/CST_SelectPeriodOnData.Rd index c3bda0c..5f12633 100644 --- a/man/CST_SelectPeriodOnData.Rd +++ b/man/CST_SelectPeriodOnData.Rd @@ -19,7 +19,7 @@ the data by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. More than one +compute select the dates. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -36,14 +36,14 @@ Auxiliary function to subset data for a specific period. \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) } diff --git a/man/SelectPeriodOnData.Rd b/man/SelectPeriodOnData.Rd index 18aa296..2c6181f 100644 --- a/man/SelectPeriodOnData.Rd +++ b/man/SelectPeriodOnData.Rd @@ -24,7 +24,7 @@ to select from the data. The first element is the final day of the period and the second element is the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. Parameters +compute select the dates. By default, it is set to 'time'. Parameters 'data' and 'dates'} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -40,13 +40,13 @@ Auxiliary function to subset data for a specific period. } \examples{ data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 214, sdate = 3) +dim(Dates) <- c(time = 214, sdate = 3) Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) } -- GitLab From 06b315dcd7d470867498f3e5f9e6c3880c4ee111 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 27 Oct 2023 17:01:04 +0200 Subject: [PATCH 66/87] Add CST_Start in documentation and substitute it in vignettes --- R/AbsToProbs.R | 4 +- R/AccumulationExceedingThreshold.R | 4 +- R/PeriodAccumulation.R | 4 +- R/PeriodMax.R | 4 +- R/PeriodMean.R | 4 +- R/PeriodMin.R | 4 +- R/PeriodVariance.R | 4 +- R/QThreshold.R | 4 +- R/SelectPeriodOnData.R | 4 +- R/Threshold.R | 4 +- R/TotalSpellTimeExceedingThreshold.R | 4 +- R/TotalTimeExceedingThreshold.R | 4 +- R/WindPowerDensity.R | 2 +- man/CST_AbsToProbs.Rd | 4 +- man/CST_AccumulationExceedingThreshold.Rd | 4 +- man/CST_PeriodAccumulation.Rd | 4 +- man/CST_PeriodMax.Rd | 4 +- man/CST_PeriodMean.Rd | 4 +- man/CST_PeriodMin.Rd | 4 +- man/CST_PeriodVariance.Rd | 4 +- man/CST_QThreshold.Rd | 4 +- man/CST_SelectPeriodOnData.Rd | 4 +- man/CST_Threshold.Rd | 4 +- man/CST_TotalSpellTimeExceedingThreshold.Rd | 4 +- man/CST_TotalTimeExceedingThreshold.Rd | 4 +- man/CST_WindPowerDensity.Rd | 2 +- vignettes/AgriculturalIndicators.Rmd | 321 ++++++++++++------ vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png | Bin 16049 -> 4847 bytes vignettes/Figures/GST_ERA5_Climatology-1.png | Bin 14335 -> 4549 bytes vignettes/Figures/HarvestR_Bias_2013-1.png | Bin 8941 -> 4149 bytes vignettes/Figures/SU35_ERA5_Y2016-1.png | Bin 8124 -> 4229 bytes .../Figures/SU35_Percentile_SEAS5_Y2016-1.png | Bin 9212 -> 4563 bytes vignettes/Figures/SU35_SEAS5_BC_Y2016-1.png | Bin 8836 -> 4694 bytes vignettes/Figures/SU35_SEAS5_Y2016-1.png | Bin 7520 -> 3440 bytes .../Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png | Bin 8902 -> 4738 bytes 35 files changed, 270 insertions(+), 151 deletions(-) diff --git a/R/AbsToProbs.R b/R/AbsToProbs.R index 247ba38..db8891e 100644 --- a/R/AbsToProbs.R +++ b/R/AbsToProbs.R @@ -5,8 +5,8 @@ #'(start dates) are provided, the function will create the Cumulative #'Distribution Function excluding the corresponding initialization. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to define the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index 0b312e9..feee031 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -12,8 +12,8 @@ #' temperatures and 10°C between April 1st and October 31st} #'} #' -#'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold If only one threshold is used, it can be an 's2dv_cube' #' object or a multidimensional array with named dimensions. It must be in the #' same units and with the common dimensions of the same length as parameter diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 41c9b67..89a4d37 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -10,8 +10,8 @@ #' August 21st to October 21st} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/PeriodMax.R b/R/PeriodMax.R index d0004e0..8c56156 100644 --- a/R/PeriodMax.R +++ b/R/PeriodMax.R @@ -12,8 +12,8 @@ #' that prevails during the wettest month.} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 69ffc8c..9106927 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -10,8 +10,8 @@ #' maximum temperature from April 1st to May 31st} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/PeriodMin.R b/R/PeriodMin.R index afe5eb8..74547cc 100644 --- a/R/PeriodMin.R +++ b/R/PeriodMin.R @@ -12,8 +12,8 @@ #' that prevails during the driest month.} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R index 77bf68d..f95b8e4 100644 --- a/R/PeriodVariance.R +++ b/R/PeriodVariance.R @@ -16,8 +16,8 @@ #' and is expressed as a percentage} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set diff --git a/R/QThreshold.R b/R/QThreshold.R index 19cda3c..6bd8d83 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -22,8 +22,8 @@ #' the sample used must be especified in sdate_dim parameter.} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold An 's2dv_cube' object as output of a 'CST_' function in the #' same units as parameter 'data' and with the common dimensions of the element #' 'data' of the same length. A single scalar is also possible. diff --git a/R/SelectPeriodOnData.R b/R/SelectPeriodOnData.R index bef70be..a4cc07c 100644 --- a/R/SelectPeriodOnData.R +++ b/R/SelectPeriodOnData.R @@ -2,8 +2,8 @@ #' #' Auxiliary function to subset data for a specific period. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start A parameter to defined the initial date of the period to select #' from the data by providing a list of two elements: the initial date of the #' period and the initial month of the period. diff --git a/R/Threshold.R b/R/Threshold.R index ee4fa38..314bc70 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -5,8 +5,8 @@ #'day (time). This function calculates the corresponding value of a percentile #'given a dataset. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold A single scalar or vector indicating the relative #' threshold(s). It must contain values between 0 and 1. #'@param start An optional parameter to defined the initial date of the period diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index 1bc1bb3..cd2676e 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -16,8 +16,8 @@ #'by using function \code{AbsToProbs}. See section @examples. #'@seealso [Threshold()] and [AbsToProbs()]. #' -#'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold If only one threshold is used, it can be an 's2dv_cube' #' object or a multidimensional array with named dimensions. It must be in the #' same units and with the common dimensions of the same length as parameter diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index 5c6bb62..fa57208 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -20,8 +20,8 @@ #' 32 between April 21st and June 21st} #'} #' -#'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold If only one threshold is used, it can be an 's2dv_cube' #' object or a multidimensional array with named dimensions. It must be in the #' same units and with the common dimensions of the same length as parameter diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index 3dc835a..4a2e51e 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -7,7 +7,7 @@ #'it will give inaccurate results if used with period means. #' #'@param wind An 's2dv_cube' object with instantaneous wind speeds expressed in -#' m/s obtained from CST_Load or s2dv_cube functions from CSTools pacakge. +#' m/s obtained from CST_Start or s2dv_cube functions from CSTools pacakge. #'@param ro A scalar, or alternatively a multidimensional array with the same #' dimensions as wind, with the air density expressed in kg/m^3. By default it #' takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa. diff --git a/man/CST_AbsToProbs.Rd b/man/CST_AbsToProbs.Rd index ef8f42d..45a733d 100644 --- a/man/CST_AbsToProbs.Rd +++ b/man/CST_AbsToProbs.Rd @@ -15,8 +15,8 @@ CST_AbsToProbs( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to define the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/CST_AccumulationExceedingThreshold.Rd b/man/CST_AccumulationExceedingThreshold.Rd index 2bdee76..0bea015 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -17,8 +17,8 @@ CST_AccumulationExceedingThreshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{If only one threshold is used, it can be an 's2dv_cube' object or a multidimensional array with named dimensions. It must be in the diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 2c8fb5a..0820a0d 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -14,8 +14,8 @@ CST_PeriodAccumulation( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/CST_PeriodMax.Rd b/man/CST_PeriodMax.Rd index 7b01d14..a372a1d 100644 --- a/man/CST_PeriodMax.Rd +++ b/man/CST_PeriodMax.Rd @@ -14,8 +14,8 @@ CST_PeriodMax( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index ab42066..323adae 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -14,8 +14,8 @@ CST_PeriodMean( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/CST_PeriodMin.Rd b/man/CST_PeriodMin.Rd index 9395699..9d3833f 100644 --- a/man/CST_PeriodMin.Rd +++ b/man/CST_PeriodMin.Rd @@ -14,8 +14,8 @@ CST_PeriodMin( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/CST_PeriodVariance.Rd b/man/CST_PeriodVariance.Rd index e28bf95..b04b4ed 100644 --- a/man/CST_PeriodVariance.Rd +++ b/man/CST_PeriodVariance.Rd @@ -14,8 +14,8 @@ CST_PeriodVariance( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial diff --git a/man/CST_QThreshold.Rd b/man/CST_QThreshold.Rd index b168375..a07d130 100644 --- a/man/CST_QThreshold.Rd +++ b/man/CST_QThreshold.Rd @@ -16,8 +16,8 @@ CST_QThreshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{An 's2dv_cube' object as output of a 'CST_' function in the same units as parameter 'data' and with the common dimensions of the element diff --git a/man/CST_SelectPeriodOnData.Rd b/man/CST_SelectPeriodOnData.Rd index 5f12633..5e4eff4 100644 --- a/man/CST_SelectPeriodOnData.Rd +++ b/man/CST_SelectPeriodOnData.Rd @@ -7,8 +7,8 @@ CST_SelectPeriodOnData(data, start, end, time_dim = "time", ncores = NULL) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{A parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial date of the diff --git a/man/CST_Threshold.Rd b/man/CST_Threshold.Rd index 2b4ea2f..07571b5 100644 --- a/man/CST_Threshold.Rd +++ b/man/CST_Threshold.Rd @@ -17,8 +17,8 @@ CST_Threshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{A single scalar or vector indicating the relative threshold(s). It must contain values between 0 and 1.} diff --git a/man/CST_TotalSpellTimeExceedingThreshold.Rd b/man/CST_TotalSpellTimeExceedingThreshold.Rd index 940478f..831bf2c 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -16,8 +16,8 @@ CST_TotalSpellTimeExceedingThreshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{If only one threshold is used, it can be an 's2dv_cube' object or a multidimensional array with named dimensions. It must be in the diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index cd99163..db9a3d6 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -16,8 +16,8 @@ CST_TotalTimeExceedingThreshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{If only one threshold is used, it can be an 's2dv_cube' object or a multidimensional array with named dimensions. It must be in the diff --git a/man/CST_WindPowerDensity.Rd b/man/CST_WindPowerDensity.Rd index d37fd9d..ec82d8a 100644 --- a/man/CST_WindPowerDensity.Rd +++ b/man/CST_WindPowerDensity.Rd @@ -15,7 +15,7 @@ CST_WindPowerDensity( } \arguments{ \item{wind}{An 's2dv_cube' object with instantaneous wind speeds expressed in -m/s obtained from CST_Load or s2dv_cube functions from CSTools pacakge.} +m/s obtained from CST_Start or s2dv_cube functions from CSTools pacakge.} \item{ro}{A scalar, or alternatively a multidimensional array with the same dimensions as wind, with the air density expressed in kg/m^3. By default it diff --git a/vignettes/AgriculturalIndicators.Rmd b/vignettes/AgriculturalIndicators.Rmd index 3c9cf7d..46f7acd 100644 --- a/vignettes/AgriculturalIndicators.Rmd +++ b/vignettes/AgriculturalIndicators.Rmd @@ -65,40 +65,81 @@ The spatial domain covers part of Douro Valley of Northern Portugal lon=[352.25, With `grid` set to **r1440x721**, the SEAS5 forecast would be interpolated to the 0.25-degree ERA5 grid by using the **bicubic** method given in `method`. -``` -S5path_prlr <- list(path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_s0-24h/$VAR_NAME$_$START_DATE$.nc') - -path_ERA5prlr_CDS <- list(path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - +```r sdates <- paste0(2013:2016, '04', '01') -c(prlr_exp, prlr_obs) %<-% CST_Load(var = 'prlr', - exp = list(S5path_prlr), - obs = list(path_ERA5prlr_CDS), - sdates = sdates, - lonmax = 353, lonmin = 352.25, - latmax = 41.75, latmin = 41, - storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, - nmember = 3, output = "lonlat", - grid = "r1440x721", method = 'bicubic') +lat_min = 41 +lat_max = 41.75 +lon_min = 352.25 +lon_max = 353 + +S5path_prlr <- paste0("/esarchive/exp/ecmwf/system5c3s/daily_mean/$var$_s0-24h/$var$_$sdate$.nc") +prlr_exp <- CST_Start(dataset = S5path_prlr, + var = "prlr", + member = startR::indices(1:3), + sdate = sdates, + ftime = startR::indices(1:214), + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + member = c('member', 'ensemble'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lat = NULL, + lon = NULL, ftime = 'sdate'), + retrieve = TRUE) + +dates_exp <- prlr_exp$attrs$Dates + +path_ERA5prlr_CDS <- paste0("/esarchive/recon/ecmwf/era5/daily_mean/$var$_f1h-r1440x721cds/$var$_$date$.nc") +prlr_obs <- CST_Start(dataset = path_ERA5prlr_CDS, + var = "prlr", + date = unique(format(dates_exp, '%Y%m')), + ftime = startR::values(dates_exp), + ftime_across = 'date', + ftime_var = 'ftime', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lon = NULL, + lat = NULL, + ftime = 'date'), + retrieve = TRUE) ``` The output contains data and metadata for the experiment and the observations. The elements `prlr_exp$data` and `prlr_obs$data` have dimensions: -``` +```r dim(prlr_exp$data) -#dataset member sdate ftime lat lon -# 1 3 4 214 4 4 +# dataset var member sdate ftime lat lon +# 1 1 3 4 214 4 4 dim(prlr_obs$data) -#dataset member sdate ftime lat lon -# 1 1 4 214 4 4 +# dataset var sdate ftime lat lon +# 1 1 4 214 4 4 ``` To compute **SprR** of forecast and observation, we can run: -``` +```r SprR_exp <- CST_PeriodAccumulation(prlr_exp, start = list(21, 4), end = list(21, 6)) SprR_obs <- CST_PeriodAccumulation(prlr_obs, start = list(21, 4), end = list(21, 6)) ``` @@ -109,41 +150,41 @@ As mentioned, these parameters are optional, the function will take the entire t The dimensions of SprR forecasts and observations are: -``` +```r dim(SprR_exp$data) -#dataset member sdate lat lon -# 1 3 4 4 4 +# dataset var member sdate lat lon +# 1 1 3 4 4 4 dim(SprR_obs$data) -#dataset member sdate lat lon -# 1 1 4 4 4 +# dataset var sdate lat lon +# 1 1 4 4 4 ``` The forecast SprR for the 1st member from 2013-2016 of the 1st grid point in mm are: -``` -SprR_exp$data[1, 1, , 1, 1] * 86400 * 1000 -#[1] 93.23205 230.41904 194.01412 226.52614 +```r +SprR_exp$data[1, 1, 1, , 1, 1] * 86400 * 1000 +# [1] 93.23236 230.41754 194.01401 226.52564 ``` Dry springs will delay vegetative growth and reduce vigour and leaf area total surface. Fungal disease pressure will be lower and therefore there will be less need for protective and / or curative treatments, translating as less costs. Wet springs will promote higher vigour, increase the risk of fungal disease and disrupt vineyard operations as it may prevent machinery from getting in the vineyard due to mud. They are usually associated with higher costs. On the other hand, another moisture-related indicators, **HarvestR**, can be computed by using `PeriodAccumulation` as well, with the defined period as the following lines. -``` +```r HarvestR_exp <- CST_PeriodAccumulation(prlr_exp, start = list(21, 8), end = list(21, 10)) HarvestR_obs <- CST_PeriodAccumulation(prlr_obs, start = list(21, 8), end = list(21, 10)) ``` The forecast HarvestR for the 1st member from 2013-2016 of the 1st grid point in mm are: -``` -HarvestR_exp$data[1, 1, , 1, 1] * 86400 * 1000 -#[1] 52.30026 42.88068 156.87961 32.18579 +```r +HarvestR_exp$data[1, 1, 1, , 1, 1] * 86400 * 1000 +# [1] 52.30058 42.88070 156.87922 32.18567 ``` To compute the 2013-2016 ensemble-mean bias of forecast HarvestR, run -``` +```r fcst <- drop(HarvestR_exp$data) * 86400 * 1000 obs <- drop(HarvestR_obs$data) * 86400 * 1000 @@ -152,7 +193,7 @@ Bias <- MeanDims((fcst - InsertDim(obs, 1, dim(fcst)['member'])), 'member') To plot the map of ensemble-mean bias of HarvestR forecast, run -``` +```r cols <- c('#b2182b', '#d6604d', '#f4a582', '#fddbc7', '#d1e5f0', '#92c5de', '#4393c3', '#2166ac') @@ -178,42 +219,81 @@ For the function `PeriodMean`, we use Growing Season Temperature (**GST**) as an Firstly, we prepare a sample data of daily mean temperature of SEAS5 and ERA5 data sets with the same starting dates, spatial domain, interpolation grid and method by running -``` -S5path <- list(path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$YEAR$$MONTH$01.nc') -ERA5path <- list(path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - -c(tas_exp, tas_obs) %<-% CST_Load(var = 'tas', exp = list(S5path), obs = list(ERA5path), - sdates = sdates, lonmax = 353, lonmin = 352.25, - latmax = 41.75, latmin = 41, - storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, - nmember = 3, output = "lonlat", - grid = "r1440x721", method = 'bicubic') +```r +S5path <- paste0("/esarchive/exp/ecmwf/system5c3s/daily_mean/$var$_f6h/$var$_$sdate$.nc") +tas_exp <- CST_Start(dataset = S5path, + var = "tas", + member = startR::indices(1:3), + sdate = sdates, + ftime = startR::indices(1:214), + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + member = c('member', 'ensemble'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lat = NULL, + lon = NULL, ftime = 'sdate'), + retrieve = TRUE) +dates_exp <- tas_exp$attrs$Dates + +ERA5path <- paste0("/esarchive/recon/ecmwf/era5/daily_mean/$var$_f1h-r1440x721cds/$var$_$date$.nc") +tas_obs <- CST_Start(dataset = ERA5path, + var = "tas", + date = unique(format(dates_exp, '%Y%m')), + ftime = startR::values(dates_exp), + ftime_across = 'date', + ftime_var = 'ftime', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lon = NULL, + lat = NULL, + ftime = 'date'), + retrieve = TRUE) ``` The output contains observations `tas_dv$obs$data` and forecast `tas_dv$exp$data`, and their dimensions and summaries are like -``` +```r dim(tas_obs$data) -#dataset member sdate ftime lat lon -# 1 1 4 214 4 4 +# dataset var sdate ftime lat lon +# 1 1 4 214 4 4 dim(tas_exp$data) -#dataset member sdate ftime lat lon -# 1 3 4 214 4 4 +# dataset var member sdate ftime lat lon +# 1 1 3 4 214 4 4 summary(tas_obs$data - 273.15) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 3.63 13.97 17.25 17.29 20.75 30.21 +# 3.627 13.974 17.248 17.294 20.752 30.206 summary(tas_exp$data - 273.15) -# Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.54 11.65 16.56 16.50 21.25 31.41 +# Min. 1st Qu. Median Mean 3rd Qu. Max. +# 0.5363 11.6517 16.5610 16.4961 21.2531 31.4063 ``` To compute the GST for both observation and forecast, run the following lines -``` +```r # change the unit of temperature from °C to K tas_exp$data <- tas_exp$data - 273.15 @@ -230,7 +310,7 @@ Since the period considered for GST is the entire period for starting month of A The summaries and dimensions of the output are as follows: -``` +```r summary(GST_exp$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. # 14.23 15.78 16.50 16.50 17.17 18.70 @@ -240,17 +320,17 @@ summary(GST_obs$data) # 15.34 16.77 17.22 17.29 18.00 18.75 dim(GST_exp$data) -#dataset member sdate lat lon -# 1 3 4 4 4 +# dataset var member sdate lat lon +# 1 1 3 4 4 4 dim(GST_obs$data) -#dataset member sdate lat lon -# 1 1 4 4 4 +# dataset var sdate lat lon +# 1 1 4 4 4 ``` Here, we plot the 2013-2016 mean climatology of ERA5 GST by running -``` +```r # compute ERA5 GST climatology GST_Clim <- MeanDims(drop(GST_obs$data), 'sdate') @@ -288,29 +368,68 @@ Here, we take SU35 as example, therefore the daily temperature maximum of the en Load SEAS5 and ERA5 daily temperature maximum by running -``` -S5path <- list(path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$/$VAR_NAME$/$VAR_NAME$_$YEAR$$MONTH$01.nc') -ERA5path <- list(path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$/$VAR_NAME$-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - -c(tasmax_exp, tasmax_obs) %<-% CST_Load(var = 'tasmax', exp = list(S5path), - obs = list(ERA5path), sdates = sdates, - lonmax = 353, lonmin = 352.25, - latmax = 41.75, latmin = 41, storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, nmember = 3, - output = "lonlat", grid = "r1440x721", - method = 'bicubic', nprocs = 1) +```r +S5path <- paste0("/esarchive/exp/ecmwf/system5c3s/daily/$var$/$var$_$sdate$.nc") +tasmax_exp <- CST_Start(dataset = S5path, + var = "tasmax", + member = startR::indices(1:3), + sdate = sdates, + ftime = startR::indices(1:214), + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + member = c('member', 'ensemble'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lat = NULL, + lon = NULL, ftime = 'sdate'), + retrieve = TRUE) +dates_exp <- tasmax_exp$attrs$Dates + +ERA5path <- paste0("/esarchive/recon/ecmwf/era5/daily/$var$-r1440x721cds/$var$_$date$.nc") +tasmax_obs <- CST_Start(dataset = ERA5path, + var = "tasmax", + date = unique(format(dates_exp, '%Y%m')), + ftime = startR::values(dates_exp), + ftime_across = 'date', + ftime_var = 'ftime', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lon = NULL, + lat = NULL, + ftime = 'date'), + retrieve = TRUE) ``` Check the unit of temperature to from °C to K for the comparison with the threshold defined (for example 35°C here). -``` +```r tasmax_exp$data <- tasmax_exp$data - 273.15 tasmax_obs$data <- tasmax_obs$data - 273.15 ``` Computing SU35 for forecast and observation by running -``` +```r threshold <- 35 SU35_exp <- CST_TotalTimeExceedingThreshold(tasmax_exp, threshold = threshold, start = list(1, 4), end = list(31, 10)) @@ -320,40 +439,40 @@ SU35_obs <- CST_TotalTimeExceedingThreshold(tasmax_obs, threshold = threshold, The summaries of SU35 forecasts and observations are given below. -``` +```r summary(SU35_exp$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.00 2.00 5.00 7.12 12.00 26.00 +# 0.000 2.000 5.000 7.135 12.000 26.000 summary(SU35_obs$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.000 0.000 1.000 2.609 5.000 10.000 +# 0.000 0.000 1.000 2.609 5.000 10.000 ``` As shown in the summaries, SEAS5 SU35 forecasts are overestimated by 5 days in terms of mean value. Therefore, `CST_BiasCorrection` is used to bias adjust the SU35 forecasts. -``` +```r res <- CST_BiasCorrection(obs = SU35_obs, exp = SU35_exp) SU35_exp_BC <- drop(res$data) summary(SU35_exp_BC) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# -1.419 0.000 1.613 2.831 4.756 17.768 +# -1.523 0.000 1.613 2.830 4.756 17.768 ``` Since there are negative values after bias adjustment, all negative data is converted to zero. -``` +```r SU35_exp_BC[SU35_exp_BC < 0] <- 0 summary(SU35_exp_BC) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.000 0.000 1.613 2.943 4.756 17.768 +# 0.000 0.000 1.613 2.941 4.756 17.768 ``` Plot the bias-adjusted SU35 forecast in 2016 by running -``` +```r SU35_obs_Y2016 <- drop(SU35_obs$data)[4, , ] SU35_exp_Y2016 <- MeanDims(drop(SU35_exp$data)[, 4, , ], 'member') SU35_exp_BC_Y2016 <- MeanDims(SU35_exp_BC[, 4, , ], 'member') @@ -414,34 +533,34 @@ The revised definition of SU35 is to reduce the potential influence induced by t As mentioned, the forecast is translated to its percentile by using the function `ABsToProbs` by running -``` +```r exp_percentile <- AbsToProbs(tasmax_exp$data) S5txP <- aperm(drop(exp_percentile), c(2, 1, 3, 4, 5)) ``` After that, based on 35 of threshold, the percentile corresponding to each observational value can be calculated as follows. -``` +```r obs_percentile <- QThreshold(tasmax_obs$data, threshold = 35) obs_percentile <- drop(obs_percentile) ``` After translating both forecasts and observations into probabilities, the comparison can then be done by running -``` +```r SU35_exp_Percentile <- TotalTimeExceedingThreshold(S5txP, threshold = obs_percentile, time_dim = 'ftime') ``` Compute the same ensemble-mean SU35 **with percentile adjustment** in 2016 by running -``` +```r SU35_exp_per_Y2016 <- MeanDims(SU35_exp_Percentile[4, , , ], 'member') ``` Plot the same map for comparison -``` +```r toptitle <- 'SU35 forecast with percentile adjustment in 2016' PlotEquiMap(SU35_exp_per_Y2016, lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, @@ -468,14 +587,14 @@ The definition of GDD is the summation of daily differences between daily averag *Note: The data is in degrees Celsiusi at this point* -``` +```r GDD_exp <- CST_AccumulationExceedingThreshold(tas_exp, threshold = 10, diff = TRUE) GDD_obs <- CST_AccumulationExceedingThreshold(tas_obs, threshold = 10, diff = TRUE) ``` The summaries of GDD are -``` +```r summary(GDD_exp$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. # 1021 1331 1480 1469 1596 1873 @@ -487,7 +606,7 @@ summary(GDD_obs$data) To compute the correlation coefficient for the period from 2013-2016, run the following lines -``` +```r # reorder the dimension fcst <- Reorder(drop(GDD_exp$data), c(4, 3, 2, 1)) obs <- Reorder(drop(GDD_obs$data), c(3, 2, 1)) @@ -498,7 +617,7 @@ GDD_Corr <- Reorder(EnsCorr, c(2, 1)) To plot the map of correlation coefficient of GDD for the 2013-2016 period. -``` +```r cols <- c("#f7fcf5", "#e5f5e0", "#c7e9c0", "#a1d99b", "#74c476") toptitle <- '2013-2016 correlation coefficient of GDD' PlotEquiMap(GDD_Corr, lon = tas_obs$coords$lon, lat = tas_obs$coords$lat, @@ -522,32 +641,32 @@ One of the critical agricultural indicators related to dry spell is the **Warm S The maximum temperature data used in Section 3. Since the daily maximum temperature needs to compare to its 90th percentile, the function `Threshold` in the `CSIndicators` package is required to compute the percentile of observations used for each day. Here the same period (2013-2016) is considered. -``` -tx_p <- CST_Threshold(tasmax_obs, threshold = 0.9) +```r +tx_p <- CST_Threshold(tasmax_obs, threshold = 0.9, memb_dim = NULL) ``` The output will be the 90th percentile of each day of each grid point derived by using all the years in the data.See the dimension and summary as below. -``` +```r dim(tx_p$data) -#dataset ftime lat lon -# 1 214 4 4 +# dataset var ftime lat lon +# 1 1 214 4 4 summary(tx_p$data) -# Min. 1st Qu. Median Mean 3rd Qu. Max. +# Min. 1st Qu. Median Mean 3rd Qu. Max. # 13.83 22.08 26.08 26.22 30.72 36.72 ``` With the prepared threshold (90th percentile), the WSDI can be computed by running -``` +```r WSDI_exp <- CST_TotalSpellTimeExceedingThreshold(tasmax_exp, threshold = tx_p, spell = 6) WSDI_obs <- CST_TotalSpellTimeExceedingThreshold(tasmax_obs, threshold = tx_p, spell = 6) ``` After checking the summaries, compute the Fair Ranked Probability Skill Score (FRPSS) of WSDI by running the following lines -``` +```r # Reorder the data fcst <- Reorder(drop(WSDI_exp$data), c(4, 3, 2, 1)) obs <- Reorder(drop(WSDI_obs$data), c(3, 2, 1)) @@ -559,7 +678,7 @@ summary(fcst) summary(obs) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 9.00 19.00 22.50 23.16 26.00 33.00 +# 9.00 19.00 22.50 23.25 26.00 33.00 # compute FRPSS f <- veriApply('FairRpss', fcst = fcst, obs = obs, ensdim = 4, tdim = 3, prob = 1:2/3)$skillscore @@ -568,7 +687,7 @@ WSDI_FRPSS <- Reorder(f, c(2,1)) Plot the map of WSDI FRPSS for the period from 2013-2016 -``` +```r cols <- c("#edf8fb", "#ccece6", "#99d8c9", "#66c2a4") toptitle <- 'SEAS5 WSDI FRPSS (2013-2016)' diff --git a/vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png b/vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png index 5d05be945f1dc68da843d2b67436a05a23315cee..87158fd6fcf36a307f081621f3d0a567142a6b0b 100644 GIT binary patch literal 4847 zcmeI0YgALm7JvzeyhMs65rP;+tVIFas!#=zTBM-7DnfDuAwjDUd4nMk2*Dy?MWNLS zl?Z7;K}bptDDPK*0v3!}fE*qP1c{Lg;UR_a2!!0wyY9VRt9P~id%OHGYi9P$-e=C9 znQyN>Uw!WGq^ph8R#8#WJ?VVHQ$LVUsuW@zv;e`~9Z!0f|$Ko0GHD=z{HBjHz}|GzL~;1io)ZIPJ{I|2oNWH!S^A zRYb}r3vDgHVB4P!)IJH-2o$}^C|Y`)tH|k3yco_0=b#Z#J~3MRq^cR22{r^$R~_i) z8KQ{xq3EVuM|%xPr<@;qccXd+|Mhsa7kfhJ*=#b2G~G{-_9L68clP%`Y|wzjnjTG=<54y8SR{IQ`0-$I&5|@Q zZXR)*eYs&f6nn$Hs?;Ukm^F_dJ}m`vn*0Y@id{Q&^R`PqsR~{j99ui}@kqB_(aSZH zsp>&4RN)hE%mAv`^QrSzX?3!|o{@+MKOZ*t(mkLaH z={s2s6r{Xyvwf>5r>=c`(GMKbneU6Y_Pu{66g}8_4=dwSx~TkY`+I`P$tIEo+NtDdp7O&np27^#+cxx?H;a=(zzE43p=yrQ4;=L)Z&O z?RCH;;oJEF91a`o0eF2J-)e7t{Yh&7|9Z*Us3u&OhDNH}$VXrkM* zE7y`-KftYDj7qm9xOp{dK-P>rb=J(2k&3~DO8m7x!J7#%^^E5>$mr=6N@+`N!=UDj zH?XHXM%3ns(hBy)ZybZ|yU3bxk&m-{4idGPd_FjGd0Fn6Zq6nr_}GP%^@a}ku71-NQdjU8Vb064TcU9`U)q zurfV}b|RSe7SLVZ93r}j5=!O~#m^3n26>bcI5Po=MirtJ>=Q<8o*o_ z@rCB9S?DF#Gn*`^GxrKL0h!>Cn?ATu6PWW>;jNec`qB6*pe9h(kEg9h(?aBT=y1?9 ziaB&uo%OvEB=B#1`?gvT)Ww(7S=R+6F$CCw_myaIe1)x0(*cgxoP`}Qttv4AINF^` z*yz`IPjghUpNC;NH=h1@Spxxn8KorBi7;_+cuz>bGcZUlkM#Bq6h zaQ23~H+t0ln;`rD5MQbZc})6duJ$F73c~GYaB9%4Mrk#E8hNizp)0TbwT%YwI|4^*l1O`=bE4;p-+U&F z7R-k?7}E6H#bowP-0SI%F8jhoT%BMjSC&nCuXuE~CBHJ%aLRgkA-e3)hYEC-m>oi# zwM`;{brVGIVgc+&<07H3=lq20GasKI2?+wX#@G-KoT*Xssk#=Kz@NLD#k*KA)6$3k zgd{S5Q9Lxqq8DMFEk#WjLQkkoBz90_FNNG{da)$NPEuG_SuizTM`1TsFB`H%!@6`x zsbFE;PN}t@SkZ6g?n&ul@*Tj}CSDtI`ZzQkwVhQNaCJRz570Gif^N=aE9LPj&@cM9 zfLlu{5?o(K;8`r>gn#>fB71NkM+^7vm9Rj%<{I&Gs!#Sfp3s1=L4D6=TgilN_&X z9IZdudhO(j?tM$LHT6^kbA6TVy!idPai8$C9NtIEKcyw9A`@UP17dFjfaBRm4cm+W z&2G&uC#hQ;pYPY_sAie@mnHROD8%rgw%AN{7DhyiO9`-VRMLk%*Hqt9Zzk+eMF^Fk z+1Gq*?s1FWtaL?ZOGDg6#QL?At8Fd2b=1;R91xokI%yVLED&4I8UhwO%0E!N&i(Dv zMbPOMn_0PDju$2_2Z2~e4}|R<1+?n zN}y^r_kITjzc#3R6LWiq;>jCgq<7hy${~;P6yAZ?$wziR3|X<946(xX)DuWLY4#%a zwTHF>vL(w`9tye-d%LX=q)crgZi^11Pyv5%Hn!2!XSu)kuHE>G*ZoF=tSPEvymc~S zopkg>$UyPewEcEeRaO^cEX6x~1PA)#No5i5TdZWKXkh`%A_Y?7cixftT&KfcgaU<{ zE@gMb->D+dZ7tey?M>&r(<;`gZ_1Fign;3?yW;KPyLqvZQZdyG_yKP<>GE=kiaMZ; zeUa8eu8&i2!fl+IDU#xM>N+(gYZbhh#`gxDnj)ThjC{d1?@GapdL6EF23x8}p@x5G ztT|&S0o;=G6g7{OOT(A+w6ME;{`^JgfkKVGpPKlAxm%_3bxP%=qx*@{PYGZC6ULS; AYybcN literal 16049 zcmeIZcTkjR+b7yaP!TX8f`I4%k`<5~6ck5LKynZe5y?u90*&vWO^Aat0G3 zAW3qToO90m>)BJ^cm6r2cB{@-ZSDEGYIx^mn(pVh@9VyaKsb2q z@5{;r!cI-nKjb^{oAbM=eDOc~tp3)rB@n0#NdN5kAeCTBAe!Vm^3#7aD~G1>buY_F?didM;msc}Ud-dG1BMl+<8tv(#XgkRbWo zEP)HzzZ;YCrt>^~PG?a3+Sn2fsF5f&xJNX2YOqlf<#DiQUcy*%SnONTaB>`fcr`9a zYqU!j*E4mQdMDwX?Ej)4(&Xue<&<6etk+-v>3lNXQ>w4K^7G}H$U>`trH%)s_EViA zTwK38I>dy9oob^b^(?lH~QP?yZ52><>}lD^1&QxcFn3O+S%@#YwYao z@}WH392_=%&v}fO1hllY0@)O&+Oy47RaNmu?Hr4?H2u;W;euL|5rKj8Q-#wx<}Ez9 zu$C4fQPBd$XvrK=^Tp{N{S(o@eqB#uNYyJAb(m=NXApbpO z+O2fg)_HUbf?mD4!%1f+sv9loh6_@+k@X$UNW>o`C`8&cKTjPpxRht!k~%YEmGrG8 z_d!p%&;v8EXi@vbYk{olVu}&M^);CjU4<>T&z+S>VJ%NoOOlq6k>^oQYYAYI>h4!B zw-Dsj%J^Pen>O&OzrQ~-GgH1)HmZvKQfs0br_sKqM74&To|jA|gF?1L*X=ba_R3gT zOkj6@-ODU%zJC4suLu#_Ur{HCIo-51cg+8q6n2`qt*RQ-RC^?a?t&TVo9}f09tfj8 z&B0OG*YK_Pgl@Icn+%R;U%!6c+FaK!u&WqrAB@)T1uulBua_t}a9CAzIp%Kb}+^0fvT#T{_nXt^2<3Tbvzh zN-DG)RnFLK($H6v8Z0g@ZZdct5a2j*ZTcsv8rxq*Mn*tc#hU%*)C`5^ioH^6~^~r%i)*H(7 zM-CqrH?jBe@oB6L`uzFxU{$Doo|VD;P&Kzsj_Rp#3X$wW(=cl*oE#Ri#l`*HP2viga(%xslx zdIu2^k#=mvwe^aj!9n}2jn%o@5wobH#EOcFO4>cUci$?oyJopPky+c=yFM(n{ZU|P ztV!PT*Uz6yVpQ~k*Dbdvb9;h*bQL-tpqFDU$7xEsUNBv<-Y6Sb(TGi7WcgKHy%^NA zTI;bDr?5%-oTY_@1xk-qEaCk^QS7w7+hS9HfRuZSuH)*;N@J2n8d`$wa1FXbM!U!Q z(qygpJgW8j#fy(hOFcH%7S|WYm%mX-X>Q28fB!ylusTvKH!shrIav!^Yu1@JYni}t zzccT={a7P<&|WgK^_7*&SFRkS6Zo5f(^6vWE!X3j)^tOU^^P9x-1`hPG(*F~$B!Hd z3l4Koe_W12aTs|JM=;6rXU-eac7?OL3+W3#l;kjG(8)ex#`mF z`{PaNf8HLKzxigzHg4$sjqv6IdvkkDJ&(;rQ;+&7CFj0pZ1`=C!=(27q=R3GP5eX= zP5i?o;TdUR8e;qj2c0uvQBn8J(@{n9v$HqXJ?5*0)C*H|aup`yHk0`~s`<;h9D7n6 zUW?kBts2{1P~89Z=|OsqT|q%X?<`9nu4afjp#7@RH5opzwzh7s>2Y6AXhiw(NNJBsNH`oQH*_%tCN@aPT9y zqSR(qPNqZd$|r+w$&xqGkQ*gg0uB51v$l0nf@73FMn+6@rc>ndM8`BfIZU>9<=jiU z&e{+cAZfN(dUMmbVXGsl-n8mVV04>8u6Ar+o(x7TXN^6zV1arpmMR{B)huXfgY2 zgHHT)UZUY8%{2qZQ{>r&p^|GOXT*$JZ92pYt$H7~$C@=Ij){FIwco(Ubs?xaJ%&Q- z{vQ}S^TV}C+`L6Ik8|d;&089;;c#RYTwJd(U=|W`>?v{EMMkN*=IZQ>a;ouEPtYrN zseCupRY>Y27>a)MLaEB}a)l0)vVL^&_h(zvQKj~)1_lO6>M51Kesz|5cwkgDE@9Q# zBR$q9g|crZG!!p3>)`GsaJ<&1OVj)!a5~gS(>CjFKF!6lA7Q<&~KXiH*El?(XjBQ0h@X$A;sUlq!FP@uMBS4hze7Ssc^OHe>f|O488S($GlJ zzF<@tR5(>2Z@Rp=7|DnK!>;1v>ubqf6e08S_3M>3<7msajKR(2o;2lnpY{@)K{>}_ zO(Qz1`E98T`?-N@*}AUJt z^2Oaa>3+EJl`B`;H_whOC4J*BcvDW+i?w-k!TkO6H+pGOE(;&pESmN9o2Bnkaorjq z)r5UmJeBmMR50~v0fB{3efQazrt@LfOG-*A--U4NpcScXcmR5|ryF{0zRA`Ph`@mV?nlNbrg6baX@NXPE< zH9q!R%Xfn9KUdcr_{x`}TG8@0Iaq8)I%t&EK&yuqH=nq+IGz+q#UOh3d^P~dTjJ-> z7cHYZhQit`)HC(TW2eMzop7!u#H#KZ8A;51-Zl2*(h)WVi@KP9s86%8U7a+vc8&-Q z4PC28L$)7ow#5u>%QQA$whXyemR3V5#_@|=8}o{TGw)pLW2yT#R_Ax^rTAG}o16Ip z)yP40`plW>!fDBD332g_>=r%OxeB)EhjZ8LuQvSfqYownK4?$tmG<7TYwrjB&$$+D z%5ygUl5T67w~Q@~$M986*5lp9g$fBO|E`~IIgmqJP2%S2a5TD)iNO7ioExU>TwEI% zPwpGDSF;1^O|mj~i&gR;MZ0X83Mw3qa&0VcH~httKUHQ^`AF>jbxt*9XAZ}eC!gZP zA3Xm(v%IXq1au&xK459;b#uMdoDle$N4#R&8kmgWfXVUk*0?6(rkHt)Jh{O++QUbV1eXgv=;m7GO}rniWpsWKV{WXUgl5}APn|ob z)b*-aPfz#Nm)qxPDS&4q@!m%}b{#%^I8pWE?-Dmxd+w9!HL*&|)f|ln>DF(p-4QYR z%%Jo>I3rO!SZqnU^=6HbtZCzin=)<>7e;Pg<;*U>%V(PQB4?iayB2>)Ae*jI8V3(g zl&Jlf&VynjzAz%Sq@<+n(69QblXaBQ4z_aS*7HL*7Ohu%vhBy4)%wkTJU@|Ex>Z1Z z2l%imgxhs0e^@S`S}4_jNjVm@flDXndRs8QFzy(qI!5^5(9nM7Mkk(YI*K@46H<{m z+LM&j!An`i6B8D`9aF9PC1s63p6$G{)`OMD#8e&t4J?;#>lRAM#kPzGAFnbPJh{KT zguQU#-z|?p16IS9ud&LD^w7q?eDUIw^ZdQRS&S9%gycw3!ygp(J->bM?J3%7&4UM+ z0qB}i0IZWj=AQBmhNVY{^OE!P^JBQ?x^KD+)}oKazkhE=wTYuB>O1I&O8iP;Ptm7FnD3p)-y1`I{RX zuL1)*vdu$-g0k*b93B*`qfGi4tCatr_Z(cvk(;=)n-<0P`6`p!J8``{t6sF~Y$gWX zLI*V_u?dXjGblQdAQBQ&>h8*IvJVy|7@%{Qc#btJhfr^|nhlC$~4JJ%Vdl!6GqOJ8qwA z{HQVvL&G}qZ6&^ z{pjV1>M4mEtDv@_34+X*uTVazjOSHfB`eygUO9HSQ!QWZ*vyX+5KqvNV42s>&d!)* zD+>*Z^0Err+HcA#9>pgVi@kAqQ5H`sb%rxVz|qT7T}`b{tAn8pzkkd9cq(1IT{YWZ zPIXc^CdXsB%WCc~kFY0LGQH<=UI5u-@uV}v zf4c)&kH>bg!*DHVC>4`rvMz&8W9`f5&nYI|%z$XEd)$^;{(S+K-Y`|IH7T|3f9k@f zRyG{%k;=%BzufIQssGtg=luEeW6rH(ZDjj1+ll~YvPdt1MRDI(Szd~Osgf7=r0Evk zOaJ^TtH;OUB)=1ik_Kp`bndNWS;qX&<6mI=C1dpKKo^-x;L zT4HjGOCkVDoW94VnzO|@+AOv&1tzj=A6^HlL`u8L5COp-0)l;H`5-jh*lokY%6hNN z=NORWNim1yc9UWMm?hrm5wvbmY)&ffs0;lbA7(!}$O|$xAJkOeJu1b+qmX}ktY>>G z*X6cyTFW-tx`X;<*9=z^lMx)3jLgh{lOk_rlj|aOr85nv?cUPUgz)8XG*KaMI`Z_S?tu`pJ9;^V*z46@yIUlS^of5VS zCE?ecn1i#j)M%k}87V{Pq6-mYw|Pg_d7+#C?L9}6n`c#9?qGm%Q0A+xPB(^yeV zJ}1v6{ja$C)>s)bG5L|YSkEQLgYr{6IWymnC~6i*%4vDd%=CV1_b9?V_syijX4s84 zbH`^kRaIG7#+aKrY;Wg8(SN|D{9U}n z6rrcwMsyBhXH3hnn)lZaFe*wcs>aFs5xY)h#X-PnNz-?%gp_flo~b#)pT7 zhRhTNfQcr7yRy72xJMRUlB9Mw#9a*l?Md=Tl+rvyR7!h$NcyCxoe3)OUSZ)^4vVv@ zJZ|ZgB7Z13$K`?t#ws~`>EqDjp}^#1ZrlF({114Ba$57*Bs3~ClWP(&N;~*N$h)iZf@xJ(e7)bi{mY!Huk^n*<$X4>o7VG zy!`a(+=BX*9H3tD{I9zQ~JAYDq$ zdh~ZZC<1#ZVQqa~$gJ@L5Icx9&tSk|i_W}suxp_Ft*tG5Qk2kxsEWI2e4%R%C(%Bcg&Ag}QUjeXnt5`Pj!cn8mbgkq6!tBiX9P+9xWd}W9W%a4g2Mosj4D?66 zy8hvoZo=?{#&d#+iRt9YiScpz6DQgV9Um+e3}A#Mso2FG7UG zF|?Yx!>LQnqhIo{2Ev|`4kw2k6Xx0+8 zwNW*dy7SJ}z+3;m=~+`pUg2)|9GHo;PR#XPEEmbGKX>i9NXwUTc|cb|pG${GAbdRZUqAlOUxO2!x{r=& zt!i=ld-P6moVw#lUr@N4ocXf*^@u|GM>8ERpSxH-tF@lqP59gI)PMc>|Hm3s|C!pE zJhMFKd+`3q6bIpt$K14^t>ZrGD^kr?S4`5c{BJui-o#oIA2b@*hb{Mhi$GBQl(9$0 z%4)`P{dM&afQ6_w6@hRp(c;qU;9#TDZ=($fUI*z(qBrw*+ggcXC)k;)1;Pu-K_KL* zwn0I+g9q~L2wTmY3sradx`3xivJntzgz^boLd>m8dBAK2-=0Q_*s}ih*Ih^qGEXV$ zN9}47DF~1D|G7;KvTFb{^5e&k(%uPCE@Kc8p&L7z!S+=p@{z?>+n-1hDRBZT!B$h-SAGKqW2C}ho==UX}h?HvXc{LOpH2C!>CZbPXjaI zE?*d{LWD`_HdIaq-h%`}i|tH^DL`5)G-%89BSgX@xm1fwc@}Ma$D4K#9_a*elLH@4 zzZE4AtPZ$8-A6ce;W739^&@+(+q`iH#GWu<7i;VErjMnYOX19q*0XjHIQ|avwE9Zi z7eBp0Vz(9x^YgwwJ{cFP0IO~MgetX<5eWY5w$wG@LcIL^nL&{$dksKx%b%YxG!FqI z+95eOVlJ&pZX+1SK#DG7wmuU}3*_w_Z0P-12E$u?;RA?C4&)9PiA zH=x5v9k}qv0uGD;;@R3z-^Y4@N7v}G5(ugN1E(I2#Cm}e4tE;uB>WMbpxZ*q|4ayVClHQWGk|#X;4fQx>Qc2+KrjwM5m~#l`H`E>L|uzbHXI9#$nIJn{{8 zZW$ptl-7Nhi}jco8B0KhleZPgXW=B8ZSN+;@NwEw(@{Ky;R=-h@zbYI&=sbO=KWKc zRCf|$=4@x~hN1eVCOIfd2n0qAQWl`AFc;bx#DTx%{C^){K^lGW<1J}S?H&td1HDr`yFYO4q)-EdR$`Bkw0+-S%n(`9DtDaN z|HF?Ht{~;iCYEQ9VTFZRcgFVL^cRf0~G}T4V#56rPI5;KE!SL@96Ab)+p&Q$Q zk&!8xNg(%Asr3~cUA&FE2y&HGRpF4M3+%@!nIvz;%LSuk5f$jeMzxIEnMDr_3|ug8 z4vKKZ8IW*UIJ;>>q=xQ=$bdTMz5@qryUo=0?`9^bI;^g);+I{p1vE7^(f#gs7v($8 z4?*zthiC$O+$`6y+<(-r0RD*9uc_f-jrW7(%sY4P#P0WwEhcjPB0Q>`gzA4t8amAx zAt4P@sN;&HkcDX1KfB0+Lf*bT&BPQ|o<4ZXpGZ!6_kxStojZ5z?6Pvs3kax^$69>e z$BYBQN;JVK770DW?0;zIMWbA!DjMGq5a0(TtFr$dHV$r-_A%+BG&Jwuz1x8Q4Sj8P zcDC4c*&RKmk=`=&p2*=lzSIQqAL#9C%hTIG&jd6ks*OYNLrc1Wrpn5$LxizB<*_v% z4LaQNQN znADx(<5P}&x4ZYx7f)zDNfE3rkWpZ!!dAZ?E;v~&)WbDsbJT$++S|v+W==bwUh3O! zLewyV2DK8)okBei=OIxnPqe9!-&9h%Ef@~+o~^Na3;T|3^n3Q~=A8_Is*0K#N@#o( z6j;xDWy!uBK>UAR`XjXwbIB7us4f3bt%aZ$kqGH&6O{wEBVNm&cswV(LE`)nF<>u*aB01bV6cTCfd)rPw_rSDZQ9z}uzj3o&pP!!IX?6&EN+3l z+9t@5C>l8x4iqj)#AH}Of;jmdGoagRBbHVZ0_$|+CKi#eC z>Th!I9zKL0ayZf&qjhz4sCNkL`Op}RwEYhgmwZ5QvF|-uKLeU zW{iR1R8WdSPPh}bkY3KH5}hR%%yDe~-NiB}9M>$n3e*y2>#s897oPqsfm8OV@!ua5 zQ#^!=EKN}Qp#Bf0uMzU*sfmPS+%@C;~!)d&b=!K?)u z615w7v3bJQ#^zpaR2PmJn&zIpd-v|%4I9NCX)G)jUh2lryuFna*+v^b22y{$%jX8= z7AK!-|Ngb1@CTKRHw*;Bv7{0vbukDX>_r9O1Fl|Op6qbMY=d#`?^gk-h*dFaW2HX; zc9OWTu<+TlXL)$0dcByU&KZ0~XpCDFZn1VkgZ)J7%?@GM!tq;ZN%8Rl35lZT-g%Ny zP0fbxJHmSQz$)@3ZBTcyd$7E_APvLX{t7I~K)*lc*RMyz=ji-!YjbmR8H?_WA~ts~ zUHYfV`8dxlS~@y2^B*W>SeeI;AJ_SHjFB;QDSvxw9Y6@ZA|dD9`}ZLq!`mz*Q95X{ z7Qrx)^E|exS3sRNp1wnWN)lz*{n?v+gkzK=nn5=CocNn>0J`=k>nOaX2I5lzhX0JX3* zAzKVPg`b`xmZL*IEhCE$4b?z82uIqqz680a$>+dtT&v9VhYlS&c1$f}6IiyTCTX+L z-_LJxdAY?QhmM$2aKi5gOiS~QGiS~KO-H_ZrJQ?T*U}YBX=7`fZPZ%%4zrqU?_RTE zB-|{1zq^)subPYJA0b)_c#SuQ3IO9}Wq-8jd!$UBbDkS`PI^&X$eq|7oB4Dh2WAt4 zM>!#0hWaaiXOT1iUw>U*KO|!K<2l6CH`Vt7E3$xai?=+;icq@A?r-S*NLh=?=gXb8 zwQzcZD6xT`S}Q3iDNEcp3)YHQq)5g9X66V9cq4EjX*Z%YTIdFsrJWKz_?EkS37@OG z`xb=mY!&0`H}Se|I$>G&yF@2%L4D7&9}nSU=jEM7M4(Aw6K+RVRcD5gufrI?qsjT9 zoT$cpnX&Qlbrd+Gn8Pm<0Y)kJhcM*ZKgPz!8o8$tj4tC&9s&fn*Iu3Umn;KZ&thoQ zH3Q9Q&M7Z1*ExAvAndwsfnEL5>Oi1k<42n4b}Fe2D+L9GiaEIkZg%!-lhh|pgoTDC zM4AcEg(F7b;O*zvq>vqa4WnGGV{>z}>8_gQ<;XH-AurFme3=4-&L)fC=EB!$a`^e{ z7njJNM@Oui&x(H|MbI|q^M|7{N6y{-`GWS~V#GJp-n9-(L?Ym>w$nr^ECcqN>p-tH zNqUYo%M)@lcRAR#5 z5-@B0`Bny=Z2&3Q_+xW@*?gOX+~t-`|3&>)4h}hU!wA_WH!J1d@4_MM$x%(}0#;C0 zQi|CUfl&iPpVG%~zXtTU&|5-AM_K>d${uuq&OQCjIq+Tz)=2 zX!q>7^jTt5ytneKp!lOHz3TF3lt`51X`nG?*Sh5->AtaoNM8LG7Z$2;@(yNa>Wwb| zW*|X@m~NPjKr>JU@CmG^1k zScv%L9OPYjwP3OZOB+SQvbD2S=_hqdt2o@Kpykq-{Xsj=HaDY`y&Ewi$hpDr*hB^Eo7VL2CJGn z?snvty^;3{I(2!^8S>uq`}gnXa(JN)tQzx5sEd*R-Y-kzqtfE@zxbCP6j&zZC_8i@ zR@5{v$5ph{ZcZcBew#CJs5bh6u}FJly0kaAtk&~{rXsGv8@akd?{+hD(3ayXRoo&=_&O2`q|dBf(=3&++v1w5-+vlfgjOj%;~`iUf`iL0X}8jQa3l zK8O#b6jFTA<-0)4IeP~lc&vw)ao?ul)k~K6r>wj@A*l3}ff_bAW<%KgXw>(f9uEZe zFlDqe?p7dF_z;)_BLD#8g6Z#fNaB9;qRO40cdC_Kw}3GOFKi8F_y+PC)s>aVk)*rH*n$R#x z!*i<@`CO0f^&UhyimZC2ot##7A@G2tE=PwgM4LAb$49WW*+Mq!KU=n5*#AH6>8wbB;B{J267GJxky{4*P0H|q77Zmt zyN?Ame$>iza@0^|r@irHiYGSXCua@Rz~D0Oes0H5C9Q#TN2Q^!HQVb14+~xA*yrpy zQyI*O>3HMDjZMf5NXLi0dNntelonNN#Tu{ZQz)NwG?nIVK_RiS?^m@7=_7?-xixmN zsM4(So!D={!FSA(%f|7T!YN&966VKjz*OtbGF5?jjzLbsQZzKIMAFi=9Wd_HJw=F- zt~g92;d^;``5QO7KrKPH6x|?80`G$JQ!7J7hHB z>JEZqju=0ALqmg#ib_kemhId?1=3J{C-{c|50@4f?HzTYf(=trd?m$zfHb?iyRkLx z-=7_+kRm){aQtIWRFqsDK-|1MfGIj8L>7f=@4ecMu5bo&Q`qOEhWE8b#zN zI4WwZoXI20tZ6KId&3xx?0>JTH{s#qQ)2`|@XyE-#Ke)2kwa%>ExHO8QIr#PvEM+_ z;KBw52BHMt1P1n#-a6&zMHZU~B|`2rqqx&2a8S&;B;BZ<`f)pU`$R2NfWHgVRmmr`5ot`0o+M(I>;vO0f=XSZ5%mrq)XR(-F~F5H?vkUNx!tD@PKvc zfA_OLVq#43e6NPaiim)!rsl}xHJX+5SppZBn0f1XJ@S)k4+`CjPKgDOJXzV<`=CvZLkagn+OITBI1I> z4f-!bLx-oQr>8hL_B@p?Q~EIVJoaCEcz)%EHi1y-`5)%VjgV6t0KnKt^TrRo)6>zf zUkke~Sp-(tb>xFnibP%rkXX{((>QV3|KJnqKJf1T@_>MUk@ADOm@hqBOSymwg$3H7 zHn-1iY-}W#u!wK^_0AODfgFml1GD@-W;UW#LcsY5ifd?$D^pUHfwC~VE!3l70z_lv z)kKJ>Jnh*v4IKsupiB2kei#cf#oD~Qyv&#J0ZsIm57M6de3!2+`aHlQc`w}m_3g!x z`nWqBj-p;(eV7Ud=>?BUBNK&X$H(tyK7IN$57H9ngT*2ZWp3i&>6-_+W+%LRr>eQB zFfdct=O@&yB-(=0jEPuTb___e*t%b~Om)f*H(PNR0nr!K(g_V0kOcrssywy_z3?LP zxKEDh&qCT7?C)>DQzMSYmGvCmsp}pdJ+&X(<@~pt}g?;52ar&jefvnz9%?;qwXsV6^s=)YMi; zkR3ldu8md0Xbk?`3S|DQj4Xlr%4(TA06M7Dj3t?y+_{i@*Jg zNQ>N3&TQ%SW*YTrLBVFV!Gc%cWDe2Oa}ry#OapUfAtbpJOENR}=Fm4Y8Uwnv`;P3B zri!ts{1qjk)8Pb38XFHB5fO1xhyQ&-!U5(2$LXmxI!^CzGO-T_ZbXT8|!<=e- zAD3X|bXJZOp1yeTA|6VSSeUQrjinW_c}Lv`ZK_cay!SHsAw0D3)=alDJ@#is1-uPB zx&ksz6Zl5J^fXb}X23g%!yynT?g1t>6m2&=gfR8|RMEU*hzP>W)NesU+JAs%qq^`g zPo{Bg`x~Uc4W+#??UOar@8Hj{zVskrjy-P1ORYN8!s184=V+wG=YF1{nS}g?Xk|KE zx95-E*iTTw^dHV%39MN7LdN7YBJu1bqYowkq7v9N_HA})ZyY8lXDZ~e6N1aasK<<} zm(yB8AMV<{8;+>lw!_>}(x5)hrTOXhm&X->Y=wn1!+Ga*@OeAm4e;v?Ap~2g_k~O#@sqxCu#l16x7Tyb$6+ArgM@e}MT&F~sN# z<{|Rt4u{I0z9kt<1_qEjI>F*|Ho;^dWvMXcy}Kn`%fLv)R-o5Qd)L(|`CgN&vh=L0 zsv2)ll#)Oc7D!fEMFmW}B}E6hoU3P*DU6tHd@4qcIVKy_ z?pvB!=0V11vv80Q-Focl3HPRd;WVeLh}Y?J=RVVVcp-_ z8(TMOSIHiSDv+@5BmQ>62qq=JLKSZnI#k;mePf@RIi>1o*uGYqWgA=TNhK)^Cj?UF z!4rJ%FsmVAPc$X9K>Y!Lgp_CV=ktzG)d@aIsw-FmkUZ)>P)?N06$o(H^o)!QWZ#0r z!^OZ>J3DV3Z<;tg=&WIaRO}SK7eJjwN>t*C^V2&>;9R?QjfDDUzERcUd5_8VY}6G9 zb^taTaxxElOEBWvq$kOm5}WYZLFQ~AIdp;+PC$~#hmkX5Z0p`U7coLfCGGhoW@6;* zYW(%K;*SyBmQ8_*k|L1Eu`;IgP*he%;sW+FLwX(Du+gpPjm5JW>Qg*YkTZgUjt&}r zZE10YQwTSb^ed<(x;h1!!Na<-ivTKPb_FD}X7rdkt(VtV3&GNjxhgC-z%A*a6f88L zvzX&l5#n%=KY>>+M|n^)6H80C(c@67-RR(uOmOX>2cS}rNWO19|L_-9{-|`PeT%NN zH)I^mEKY99qN~9w@rr22#6FG?Lz&oy(V%NIY*iQpkahLR(_xNisE#WSdT5*!w)z7} z#%<;c8LCP5roj_yi?bLJPFP|*F9u)Eq(eqVCb(nVsZVl#u86a!xEMu~iK7n?j*jYt z>+kLDt^8tNE8)%+fK(Gm4UxLCtTZtqA_75N7-|#>TvwpH5x4kUj9%;Kj!_ z;m2zGT9wF|gRWsx(@dh;rM+WfP7Sw=-Jzs^?^3E|Mrm$bCB zBX8t%YkD28KuUsnIyXPhO$T6zYnRwedPOm{aSC@7LwyJHvHi#P#;}xZTslOxO3O2H zAVeAzpZX)n-p|;)f3-0JJpH(5ikLu@w4zoAwdv zc8W9j_7t*nlOWHnJg`_&%czv-Q2LlZzVpZaxNbpHJcJ}y1-=wSGie$4T-MNx^co}e zpAg*Rer5o4l+(3%7Jhz}XT(dMd(}ong`a(su}1M@$)NGE$cLN_^&1`-IBQ%9fi!)< z{(EpV<^sC0*If69y0^ODdShP;Tfe1#3t~rVGup7Fx9}X@e&#oVmSfLywJydBSY=-8e+8LWcvkS;a0>PF=HV} zWVHIHuML#|g}6=^w;&}6lLF!q8w*P@dUj=(lSHVY40LPIkYQLGPa)Lo-i?dDht)MI zIHtuiFr##~=S2xbSD%!YCnxFmV{pMCLPXdT(*nh225MlQR*Ytmy`Q%y>?FO<+qZ9_ zR^>pZJ9R1s{Y_DP_B-i0tln&mEHPGc`+EV!2DAjipyO~f*Dmmu{~P-KPaORJ^l#f_ aI}Ze2v9<2)!!zH6YgZI5r%K;`{NDgqBXKAI diff --git a/vignettes/Figures/GST_ERA5_Climatology-1.png b/vignettes/Figures/GST_ERA5_Climatology-1.png index e5c5890f6c04015a960e0ef5236046e2da096967..3d88c59d86ae1f986e1df6e9ea640744c0a9a583 100644 GIT binary patch literal 4549 zcmeI0dr%Wu7KfAYCI-|2R6v+f)K#Lc&){QV9Ayw02#SQ}nJ^jy0)ZGXNaUf6A}Zix zAPQ(4Ek#KnEeJtEB!c(?1VI`h5H=tn1PB5lkPx!TxNg;M&DQL0)&Aj@Rp-{}+o$fi z=brxR*Ik|J>EVJhwls#pU?|t!yY|6g2tYdwbu@QU%R)vp&dT%0{mvSHezk7hkBFft zv)QXFXP;nadoHTgZ`5kFS4I6kGH6QHRX)+C(d9R+v58z{IQX@rc)J*068$Ui9@9FI&zykqOY!b2czL`lfk- zr8KwpAq$-PLQg%-=RI>GDf4Z(r@SFNa{Lsp_u5ks@^j&Gf-f&+w|EUiQIrcyR#lYz zs(c(IYIvX=>=bEJ;F$Ho;fd}u)05NFYq`RXqH>30=l#q@?TsoVR~?&FqG(0Zgdr7y z{CJPUd&rNOTMcRZPXk2RBwi(z;-?yh~t7Gh)~2f3smxv5r%Pa3nx_0A|pz;)v!1CaTU*f0)?IkX7_s?(IGBU}9Kn_E10(q_N*4&^0eSkV{}6(+F-LJJy?2h5ZuP;XI| z7|vuK0 zVS(S;IHeDQ{la+Z*vQz#Z@oJp0#-D8Q?77e%-o??WSBbb&nU$_=Jn3f&37Naj|KkFuR&CR0UiHxjg((f!o z;1WizW*Gw04@rJY2)+H+LsOG7zXZOt-&T!er&aq}IPv2}2Q@;;pTil1Yi8w0H!`Q6c=4frv*h@HYtimBJE zG(5*V@a^9ohctyr@bWBEAcU0*#&2|a0HC5&%%Rbzq5f*DM`;%oJNFYUX znnl4XoF2PcQ+h5qmD8AUgmw0ERrl@D9b|8cAE1;+eJts-dX=!EfnCzuRW~Cq9i0#; z?!(X7{R{J0_|KnjA+i+ASByIUv#V$aikEB*GC(WB`FA8KEQzk^l}fu7N%b4zrVni~ zsTtZC60jRc4}n_{X{TB$T@5VwIC*;fKq2p4qL(4twiyNWPGSjr_w*=PLYE4&Cb!kw zY~kk~K}{-&;`QKG!t2)ZrHWXp9(qs6%odz_9{8Sxs@zc)-TEP?aiX`>siGT;X*ANY za7Fx^237A<*6X`QVyB!QRn13*`*Ja^{Ogqe-S+!=ze0tQxkRM9=b)t+R#=02f#0gM)`J44U6 z*x^i1X%IQ_SgdMVyb}RYE|YE=u}7f9*c9&`YZJO|*o;|`WA{Q6r8W9`(FkRZ3xDU; z=h^)Eh%obKQEyDxv#Rn4+U*`7J-f;;P!}Rw*Y4=t&@4uUoIkMTz1YnLJlX@8AfVPB zVAB6S93pAF6~R5-7~oOR%GEpRm^S{@<(`F;IuMdFhnH4(6pv&~-)1g;1`0QTQ_Uzk z#f0}Q@sKka--SI-eJgpv#bUR!RL>pG@UO??(^;XpPdsj2j>nW`*X$j7Ksf?4zzH4Z zT+&7Vf!QUOsKy!5+3Wk5;M0RG#OeM>@5r0kcRgi{yZFla;YI`%XRtCUCJ3ku;%1^G zf#%>V6UkwTWc$A0PH(uxN)R`YYHy0mGX}bJAw~r8vE_caL@7{2)asuju_KYS%JU^9 zdTc3-C7`qAvZ=yRp&)-eP^`Q(W35@8KS^cFy{BI&?*+Hayih8uqD8-zVjJXJGTH_e z@Pi50j&`mpVH{O4@F9=DJ@E?HlAt^_% z^JHkGIL<&5#>~)5axuQevY>X38LoYY$AUVg4a+LwY23KpI3`yWc&J-$*~F;I#YpMM zKK@)ok$$~JT^DExshIe{b=)Bu%mvw3^)k*X8oZ(SuBeq|Y~MRC-D0~Hdiumcjse@J z6+822IOOpY9asO+5dKXtx?$#8>3LZT*n~lAwh65yoz7JE1CvGo1591A1*LgXOCTl-xE&$6+k&rg#Z8m literal 14335 zcmeHuXHb+|yJZ_`B{fQrOzTmS7?6yBv;s#^$&z!<0+Izh(g=sB0xFV0a+aKxC^=^V z$(bfL(4=|#d_U&isrfPY$5%BqbE&c|rTcx~z4sH=v)1ar6`skEUu3w5Kp@B;|M^G> zfjF&B{DV9V|8w^&Wgz@@;l-aCjtB&$0rAhNG>KFT1cD9m_>rWFYxL@vo3_f%anlBl z49QW-cG{9_ErqRY+DXpF{_$D5dLI5NaW0YNidc9oEuLE@KjxZ=O-V`7 zu$>8EEWH*O&xUM^o?uPw5OYyKYfQUW9qUa#u_b0EJ~7!=IiF>uKrID#|8ZOmhHrkVX&wCnGn>BivYk)q7FxVWgOsJOU^ z=}?K|Uyhwed()w1Wo3leYce4>r%0{tT**+)G;N=hm6z0b7aqR7R)NDW_BM5PcGlG; zJ&h8$CLJ_X<>68tgB!1^(Esr!KAz3a&JOPPmYngepC4VHhTY81_e+}ZKY#vg=NBFx zZqb|Kv^vs1I9TE^+hQ|X%zV$Z?eEL%EekKGrGz~R+pq{mL0j#7!-g;XR?dq(Cf$ir zySRzlYyK^F_4FpLdVP)-_tcDP?d;6uC@3v0%~H=#j8E-oZr;G-2X^D`8c9pWuzpUD zjEt0`x5HpC>gwu}q<627O-@eEcgA&!8aX&Pn46oU&lTE^5!xc}X`WDBlct`%uB4i+ zS;WzhWQ?rk{k=X}ch2()IkO0#n3&Fl@U2@pZd-Hv&LRH(95Wh*hKA8GG5xXoH<}1L z%b9Aqu`c=2N%`+W+5MP95;Gmy z_t9b-+89`*wLsL?>R}zF1oiPFsSCBesq%Emn+*Jx_4V}&W^L{5M@@QW(Y&=qE(fj$X(M{*Eg@(pP3TBb*|R;R3S~>tTn5t^^YkA&h^F zs7na5=zuZrY|P84`oFuAWMrhI#9jz})2MW{M;|O$4(7zz9W=3eXW0yK1~{w?<v5hHllw5w?ot%<#o`j^SsmY4x zufP6+)3+JO(y+8#`s)md*ZwSBkr*eZ#rp3bO(D#gD(N3azL~avIYUB`7Rs%Xb_W7_ zyvoDF%}ob_e?HDzH{Z~gFkWUqE&b?G{fFyvSkz_qXDfrban-Li3QR3Viy*MfhrcBY zq+@(9QVNSuH;z9JB2mxN{|n!_G?YIL8<4A0frou^b91v;C81za5M7q25OrR0g;l{B zp*B)h8xzYIZ{k7$RY^(g|GhA32HwFquC+h3)3 z9p|28-@S7ukBppMP*9MK?Lo}a+FG?`e+HcP%5Xs{B+Q8R#>U3=gHI9n2s{`YtGU0n zM^!)F()srJ%ZCp=#Wq^mbr5`8x6s_&neaJFlBA6qvwKgX1b8OQn8aU|ju?zrx@B&L zMMY`3w%@MaOT^z?TU&!|_iY%Mul79H=3c7xB`tak;jVcA$6=5^Bj$lOfBd}2vOhXH z`W30`)ZgrdzSa}fRqK|D0Z5Dt9TQVl^<6I2jPQ5w;)}eu+66~E=1z`rCw+}Sd`PT< z)pE4EMdYJ}6s;s&*W*WAw-*!@UspDFC(F?}DV5lc6-pNjGf`82Efy6PHZe91kC?O` zD_4yovU>t{j%IdLQP$`|FX6jKp!t(ZQ}>^(!|x<^D`HNR+MJ-8ezJSb~Ae z;oe4G-W^ufxBwdNV(a0}2sPa@&jaW2 z`6E7-9v*%q&C|5Vyc;tiEFz-0eE5TeH7&S7mO@@$-l->?Q+a!pFwJz1dC~s+WaWA- z>CzuiML&4j-qNj9*E)tu1$Dq=<7+}ff>w!bzjtxQQh%n|h9v#v%UeIMh0bX0L%F{x zzAbUEa?i$R2-BPLR9Q)>F!ufX_ak44Np9XtG9-K;D8iZ)9IpxR;lgR907QqEukvtjpT3viNK7O$*$1miqNPcly=z zJRzXCvX2&1;|5G8imcSe>5YtxT#i=P#wzx2MY9#sz3J-aw;t*mB>wC+(CPJ+q<;Ns zj*EmdmQv)scaM}{+|7#rEM#w3E&p|*Bur4aaQB6_cJzQbZ)72J5ILj3&4q%xQ+`P? zgD7h1?eAZG+vmHX;)FCmKN$suF00(Cl!+WJe<@T5{XNqI{Azc1 zH{mi976s)KPPW1YH=xUneiS8OQ#f0BxY??C08y|uQDY|%1x+*8=304K*;u)g+-jDD zKR+Z(l%U;>8#io+@+3v&8d_WB4%Yig5>Sb%na?L)ZM8#vl{j2~NJ&YVedNdL#qsK^ z)P1X$8&eI0vTe!I7n8L=YqFuXLUsXq=%qN|H}ColpP`j6hgh(|3y!-!R1C*r&-(m` zFW%eV*Dww$ZsNt=C`B1Ux>MdKFV(4V);xi-Pctr@d(W(+w7gvNer|5A9aQwISFa`} zCT@;hxBcs%?R--1I3I%l%ZiVoGe$I(Bj8v`FOc~&VT&C$AqvME$buaiwkPJm$!6|%i+1n z$pistm@N_9nZZz6y1Yx5Z=c`m^gd1!u*_BRqhQ`{INXXm=@YT)Orxv?__Q4QyCY6Q zFKYYv07oa@<40MG>C4g4^6vIc@jf}$WL;IafO5Dgkg?5fFl$wdz2Hk(An9{n)9k3< zi_6>lq_XuT+Wmc&WtGS|rl+Fn zhG0O~Ls=>kr~T958QPLeUtQRUlpn@_ zc`z5MK!JvahLm=^^Z9qEM1#7wBhvuQc%+~Q6k7jmZdPQ~u5wppH2w2W|Kf&g*oEHI z(C0lJF``A5j*u`84tR*3Vq-Hi*88sOsc~LCrhT+If&eCu#=9YrEJAl=%xtnAhuye) z_n&B$^02hba28OG5pfzRvC9=_5qc3nFn@rn8SG4~ah}R9883(MX^#^8bWdZhH{(Ogqbj*bEYHhuOy>Pj& zPZ$axG|>c!b!C45X6B(g1}SzWpTCNDA6Me{CQgoBst0>6pbPCTSn@SCG}sJ(GdVdv zf;}+YJ~=#AWTUS6)KHT0BRuMqE@>%k%z=-w#%u z81LwR=gzH66b}gsiiU<*>|JCxQN1J`1@Y|6+_1MXT~JWa@12;)0ncaCpP?$*uyCSb zY0$tNf~p-HbO9h$VA@^|F$LY$9x%7W@t)B{wI@N+Qp~^#qr#f}T87E9cU&4G%O|=S@J4C0YYn9~Cs=>B+Oa}{M zQGS%Hx@8Wt@HBy?C{YR-Z%%b61#lYaEb5j6S;Mf+hlhu}yu9#M3TCdU(_1&RCs!F( zsY7e8v$JPXLLb>$%FG3@_lcG{NIHqYOIuPqb&;IBKW;?%5#XR6ik2_!a}dFuU-*}y zwbNnh8yluRwXXJkBm%@ zNn2cA&h$GcY=9K>uR4 zB?8KV)d8iCkI$#udO4jJR2u?lJUu=8D?TxczfzZYTw`x!uW6+C3))P@=hbri=|(`LY2F=Q_**UcHGKmE<)Dqp$B10V{wXIXCo9{t_Jfw5USn?{ z`vxzs!;d%Tq?7K7i+e$9vLr_Rj?4o9_bEK>hVn(e;+}-Py}dM?MK zBRwc0@m?)yUWXeptM-FAI)PdbVfrc*d#9+VNH}oJQP0PCFkQLAfi)j1-=TARwb{%b za*qj(b>83l$fH%r9E$OWiN^dOw{KEiHAy?dN z7AS(_)x0=f?Kx^V&MO(`yi{$jI(`sHJ2O&bweU$35H*7H~1)yL0FBZWkk&$2MnM zi#$^L(iD^6U;yS8EWqE)J5R+e`_hW61~Y;IxX0Zy3n?ktEw&jgiW%>8--%u{|AuqLxt-Irjb7nvKP|6@Tphe%-Dt>|l7GNk_s|277zypY$ zJqTvi68m83q+@LbZhI#u<~#bY-N~%s{&BE%zy$NXl zZeU2rfWV&k-ftgBG%^OhpPijJfFJi*> zdv4Ad@Cfl@-g3gLB(=XeR@_$42e3^ru4*AEDb++J)=TtZ$1un&fjcfJMBQ-U(>#BUpstM_ux+<~Cr-H5rqKK5$qTBoJV{bQ5!~D`mOu(uNe>hC_Hx8R73L^f*U)< z4{qWvVIDqAeG-{?lzyc0&Zn0(zn6lrv>UjDb4wXalp^K#!=eQ3#t(M}^?XtC5=YxI zte#&bsI!SB=~S1i25(0vyaDf$o9O z-i8Bto~=ow1O{`)0GJi&J>_z&yBqn0TP|g9qPX(huBwT3J|(RK0NF z0`NAJWMtdx>uKuwhR~~ErGnN&?{+`=K=ka)gvq;mc&Gv01t41Pe2dV{eJStgLBn>RjZiy%`ZQ2}b4yE_xw=*8hi}bGbhQAo0#Ix?QF8)d!Ks`= z?48HQ#}IMQ<~&yNn+Ur&Rw^ngMn24p>*xPU;f|U1IJ>QQ~PCcH>O-hDv(Hf-T^2INc2=k>QKem`1?kI zC~l`q0{xh0Mp1R%d?GbIoR zf#;R_na{IF&Kz(AeE9G|smC3G$V;C(X8>f(B=gktG{}Ud7QHvn^#Bj#bm`y|ik3}C zM@L7P5$kAqG_6Mp(*ZYn;8!%h89%n*VL~9dIb+!FzuJ58FXHlJRFtUWTw9V%C=vat zd?Z7>R;95UG}i_C6|e%U=l1(yYZ#=OBu);u0Ch&lnjjEE-yfcv1S*0kQtoe>$jf)a zJ%T}z(!Ue_ocQ|(7kt*?_b@O6Q9_L&V-#2c1#Nq0ho`?5R^V$$k}zzo3!uI)UAecX zXK66^WY{bYXzNynh*JptGYz5|bAW;YM0rm7()INA>UkgSz|}syLA>V8cGbcHcvZ5a z?M;%Q1YLuQO40RXe{23zB_9Hjm5VKTG75qgC}b={acpN1LZwsZCV@fBRv|$koE0nC zn1mg^Ml69Ad~1*X#(xrnS@60^*NGYd4C+8TzDi}e@0#}|ESUQ=;%DZNEdd_xQ<^n}+kRe7c&N%$EAn&$WMujy^o- z%x}oPhh(;1};({q$vbtKU0rlxa1VuAQ(6Z{Q!CfJa~!1p3etjAgzFk^@F5+`m; z>8SuRvlVF(h+@Us0%;iW{Kf#J`{(C|D36LG)s3*FN&_9konv;NHjX&?b=PL2^wJjpfAzs^r*E(TA+7o;6`#X%> z)xhNV=`p~kRBEGawE&Pu3fk!cFDM^-UjrCoC5;=9ObQ~BX-hE1!xPEb|Aj!PGnS~I zLHrpEQT2bpOZ)KnIdxe%IZ=0kaHaEvis6S~zy(tU5a1)g$V9BHtN_IXAN}JI>h$ZRdkn!)>R_r* zsLqG!9D{T^^9*T!eCURL6n5h&i-Yi`DL4_K@+yyA&BCuKDLGmt&yXASm*vxVVC1@t z0dc_3*Y^l!c<@@l89aPT7J0|ujdRj!;!PQhHPz_{k@g@Rfi8guiUeAKy}f-P-EG_c zj0lm(V^_8F^nVOwYXLo?koqhJII$;R_|j!US%!y)rSw9$u3bxtZ)MkYo23~g8!#QZ zdiFK%G`t;D92=k?p$idBBDuO^HXj(UMvXz>PRMuvvH%6Mwzd|(HYN%Le944Yg@3Ce zjl(`RE>4d#v}K%FlQ}$~!8L}m*4U1fL-tWH2`M1$PmVpM6t#79cGS)uZ#1zIiH*Lr z_Y7fD8qYx2NKH+xsPJ%iFSltlbb(nm{4w1vZFA7-6ciNDbcdV)Q;Um{A3r+7wm>hS zGZDUY9!)%vgdpz<3l1&Cl*mc++9-6Bd#%{y{-x5)w5)AkNLqEF6FV2Gk>AHn#7>!(|+;?=M5} zQDiG6%YuET42}{yUlCaa=q+C#hhb55Z^k#Y|w?VdsuF)qB>v0e2(!cW(9wpv=t}|{T-$*8kd}0I^$#Le=rAy;p z2df}S=#;-~Zf#xemSK&#V}JpM;h3o#bX`aiyP-U^xOg=z287PrRohCS;RO^i@gqrZ zo3?)Bftb9ta~G6$VwS^$|Jw&JBJ@YF+~nrA0?!JFsN$~c`e46NQu^TM=NB3(4;$-_ zU!iAVS%YlFG5qzdC7vUo$_g=K$Qub*sSp-2-4r?q+$V%MwBPN`&6bh^04gA+XxUXc zL3+NSRZo_UNLNlJ_755^l|0S<2W3*I(*hAOF(3ls0I^&^-xm{8R#v8w0<+V2k=3V~ zni{G3tgNj0SPxt1%~Bc;0KFhg;B9g>=JDFoSJ3*(aJye1&_kAW#EL}$*8B1WSg%~r zfkEK7Dk!Kn(Q7S0$t0BL&&h!Wg+d>!T%a{&EAT7C=1U=m`mTlEhfg^G90QX@k(6RM zsN_JG9YFyEEw|sj1JbTBh@RjU6CHh??8fTHb_9aoLi^D#C1eUA_p7t07J^~&tQoYq73ZexoQ5<&wT?y*#vLFsf!E)O%k-)K3 zP&6Ue_aUo_K0>DH)p*4?n!Qdm8syLyRRw>QYUTjcad_53X(>feNN!`zyAyo}_8_H~ zmAhJ7xhH)5L12Mf*nu%dE~Oohi3#}64<3Q8$f@6RzF1^uhAJ6E^9baIN}v-nUw3)?Zk$;uHo#D8%}1u_Oy zz9Z0Fkmy&hUVR7)dwN3|EC)~rX;7$me3|QpA(8&q_%$|m`O+nLCDk;A+rg5HB$oTq zd%;vkd@vVyuz@ExdO?FNhadurQy&BoR0ufLzK$3wOcvB|VBSaKR!2)tj&>(j6*<|? zt=&8`^d&5;7n&G2aI_WtK$JgDDEs;U-c~d_luhp>Hxn+ zGA}(i|Ia_yL>X9F?Q&%i^eF7>y6!lkYgqrlzyf9TYic2l^Dl&mdO5(yzVu(ew9V#E zPh^9u0f1u9@isKR3m5VYJs<4X&R%|9r%0U)D<(wwgXJIr&g~TS#@-(WN7lg> zv}rUN&B@70J4P)PDdAmxoHB~>UtfQr6^;z2BVJ7fOkp5JrP^(5ZZbft0Ne#a#{2N_ zm&b?ufGB&W{B8pF-6_#Jv;F|q9Pi-hNW`s>X>^{nz>R|c@ji&i&$%yh_`!(^ahRFS z2QvyTb-v-$hW-trjnu`{4UnH9tz%=JAWngLu)VRt`Be)*HuM+osrm~?w;4`zTm=AZ z^1$7l08v3Rz1uo75BGQ+%Kqw z7l-k;exQxVTk~Bm;6KG!5u7_W1SDfXf#3s73o$ubk?40F_p~G|EDY8_O;5kS)j2v^ zXhB6gzFP3HN&1Z zb{rRZR1uPtl$4SZuu56gG8cOB%{o8?D68YJ3(&kPT&0bX{)}Kz~-?Uba?L zYcoqro8Rd#)YhQjLhE*C69U*&Xf9#h1q;F@dc%_}0@9R{TyW!XF=+7i&d#M_e60p3 zfR)amKG1Lp)f^KXsi*Ke3fs}L^G>fXh z78&7RSNnQHsA5H&4x8Cex^pL{ea?%`uIc8-A6ru$`|@CDw6NYrfeH<@2}^%9A?3$Z zLsB_uJeSF?++h_3Z!wLGbNO2 zyibm!`Iky_w9CE$V1o=g#*ZGajg9*G?p(aEs8O_}H>ilhdZYhmZ1lWQXs!9oSKw0h z_K2_paW*Yd%X>+4HS&-+y>kQSeliJc+GJO%r&ib@|$ZY6dTwtNgRF-*ILbfb5o+D!`p&^3?y z4(Y)JD|b$p^;)yTGhtJLgCE4e<2{?XdXe(~{O4T3XB18WXGXTg99 zd(sb&22%A|5|YshlxQFX3fuuS9b+73>*5Ak3KT`emwClCl9ee47&n@2}S>*{<4(Za&R`ghhv zkmz5(eu2@nL2hz()@i2Os{kni0rM;s3yBuGauY9{crcMaTCDgl4$x zNX5kiM|=BpmGtkdT<g&Wc0bue0k=5df2i@^2y3<$P)qx+6WBVc<@3+{tCRGfXtZWVEDQ+NFe*zb<9?Oh z0}ud{%yZDfKsf9K`Uq;MwTABEw?=*N*4h1(2S1r?kuxLb!gVO?tuCL*1~9@}to1(Q z{9x||uai8~Yj7A}qNe5phYyrXt&eKuS$BuN70Plb1q24dk}Lq|RV&+#mG^&rd>M`H zHYYFzyp;8sv$0XOv`mA;*`JrkX8X9)Iec!&-G(Zig{*+TmmZcdyOsnB# zprtiEuw?xZab7ESfMiw@_oZaqUGC^G3tAxnqkiSAqoX5OkoG-lT?ehzZZ|(rf zgjj`H0OSAWc*BQ;k`}X#n~>n=S5*w(-rfcSCA$6{`k}SfO5L|5ebCCa5-`4Sj6J!d zZv!?j&6)^Af#YKl#=sb1$Ht7=h+CNy#jmm`WvO(NVIPr1EBZGVoNm!9d{kb1|0`+= zrh;Ode9G1gAD)MqSZzrm%RUZp9((v~9X07yx%W3WrvvE$vx%k=3`Fpa0hseaq9tGU zVxvFeQL}KNmea+Gr2`ED_V?5`{eW~G;H*4gn5P;`OuMxj%Gs5RN z9p`<_i8TiTF`J9$99&>n^ZE>7=WoD+>2!4|U%$fsh);;a4&94<0{r2Co}@NdwZM=t zR^zQ#GcF{QNr9hg2nITMkB6NloG6~v7^Jj9Kz?JvaSs!)lCWGgJ z6n%3|D52V?@3D!mDv4I(^9!OR`7ulqUfR^_1kdh%Ga&)UKeQL9QF!=D8E&C`f zWEPrrvVg1zmmi6>)KswGc%G!{bHm^t z9}9LQ-MTUh0g;1z`#ep7XcLARYiDPN22%-uA0|eDoB|bfqdXI<2#$NA1Z(M|;aOm` zp2dkDK_`G>1bA!&a5cmvv>O}TlB~wxBpyUY01H_1n@Q^}z3S+9?@-{ofqDZ&Yz;U~ ziaE#eZKhk$T{2ZO1)P>tJO&M&8W^&ymwhTKDqu8v_6)`j4*|Pz_~>t_2Y`JX+)}4L zkQWDKUjljkfMbEN3(O_`pORsO1^a?x$rNDlz7uUIkigHbD&ijIH|l%uP5KEt&K(kG zg~p*Fb?6}IdVsgtcTvlnQ_?*EAbe4{%B>KajBl4-auy6Ixx ztUho*z9{bJS*~dTHaY&oU0_T1`GEqU9F>t(|IvphiFouC(qgBK0U#3aGcz+_FS&?@ zZ(A7G@yhw}kSu@BJX;}s;`c*8O{bz5l?a9_f^$;$9(?D96b*f4MLCiN&Sz=#27Ke> zrR>W;U}htLl_3sH`vCrjD`+#hvwwW7*_nj6$M>hj>e5QP_{rwEn>Q2L$v8nwpv6hVmaG zyJ6Nl2sdHA&S(u|?1cMrHhc*M(D1@2ZmeP#Jba{RA_<)xuv%}->j|b@5b1@4hQ^E3 zb?iytUhoAahhLX&QRS1oXpuEmvJ*;(orOIwV{G#xa4=^#pynK;{ z>!x0{wwU(}_!po$&|+RfBQ)k6t{n2)S@&sgZvGokR!~r-*HQThFVvfV{Lz35zZQe3 zFC$;XecPOoEaRovdfqV1q$weTA5}G)>nMwVlD@5jf39ZAk@)fTYm zQf4xey}j}DOQB`Itk`1P=&0z88;$s6@k&2dYYn~YL;PPtA$@`IE&zHF(i>{X27H@B zz-9!#Pz6JeHLgciulfA)(o#8S7L?+9@$di;b5(9zreL)c2OS6U4!kVGS*}sTz-yoq zp;`fvN-KLuJ$--#CLSKG;#Y8D;P7hu`4b%AZ)$2zz%I|i$jEr*iuu1PgjVtM3&82( mb50=;6$bxh6}0Gt#Ff3DukMuX7JQ=*@mT8Fqa2L>oBsjjkGin{ diff --git a/vignettes/Figures/HarvestR_Bias_2013-1.png b/vignettes/Figures/HarvestR_Bias_2013-1.png index 14673e899c4a053ceefd343b0480cf2aa475f85b..831f792cd80deef21ec9af3f7d572d6edcd77e06 100644 GIT binary patch literal 4149 zcmeH~c~sL^7RTvgS*)@svC}G1Dz%nG#tH_MWeQ?cG%1zkhk=Bj3y6pj2wOnnk`y$p zX<-lyOKKU7zz+yzH7q$Mrf3nPruCenXTBnXV+(DX0HP;o5dR@&&8(WYLjvJbbpY)$!>^( z{BlJ(;=b?Raeg#72}d57xqg13w|!}8>0p^=k4a&9dQVuQnVB{Cvb}cGhZ|$+wC>&Y zNlLLm@%r^kFhA=yPW0h z1$J35EkN51C`Y;j+H=QB?MRA=EvdT`qq5|{v4OO!!x^nt<3Exg?UKp`yx zv9tBbU0rnLTQ$9`K~3|jj2Eu>EtB(l@z&-yx4SIPJTLs_vZSs><331bN{IKTG@Z+P zytp_lfKA6#lJSHr?5WF&;%D2qX$j|s+9y^TP6OsOo;#(pw>E+6BA!lZN}YE&NRN?L z!O67^qzXhz9Fj=m>5mF%vjY@tmU^NGZD^8-q-!NZ`s@p9eB>)}nG}Df4^kC};50;g zWNs~N55-n-LS?~tfUN6-dy_ox#TaCR4~q61#vVpgZD95D3Z|!* zR9WuOfqsx+XSxLrBPnRWZ2?3NO)t)r;*Zk`^rP=pT<{}fqm9P_Y`Y9jK_Y8bs8X+O zayg!!6DsT(zZ(xIG~3|0(gP^z?GmrDBRjLYw&K|tMI-Uk8zFg2L;KpJ38#zAS?h{3 z@_t-gR=KU<3LfAL4vS^hVbwfNN7QW zQ}1YwU^n@!h)stFsj8JY(tYElLTC4aj>T1SH#sOzndlHwi^c~)G%JiaWw0G$jpG() zpM3&!Y+HA-_XVmQ^s1T}vGVyd)N5oa`VxD`#0j-zR;Q=CJT14-{K1wN&s|joAz@>Z zmNbpAqK8qhfW%jcZ^yvm$Q zyScjZ6F|$4-ti{br79V*p$Au|-|(|}HSsDW|I^2CNiH3em-Ku5ivTM5t8fk};m0 z`v6%Q@+E!tr!fABp&tnkW%wzI^LV@axxS9x#s@~EcS=&U6BL-C4!FkCuQ$m}6MsKW zsz#8u1|j)*6U{x$p6;d9h-h!4H@p$$t*lkFEahI|>2oDZL3&O(UChywd{_0KK{>We z`EX?wJh;Zp^d2QInx>h`p0rPJt zFl%(naDZUrKpJ_pp+NuW3?mvM;asdt z#Fv{Q;MAZX$;pP#?m9{Dp+OBhM$1w(B6OC_Zcj(*(u;k->L+ci`ZgyNvEHz(zm6|) zxt8{HvD0}e>5YFq-R~_7ejO|>g67q+Ffej~b=U>BaPWtPYVheI10_LKred(TLee958?r!Om?1L;E+~_^^;dbSZJHD03g}aOFVEgULzw)Yhwp@A= z<4boZ$ob@*&0qxhKF(5Q^$p5u;{eMh++vTxJV|fAX_Pgd4IH`b^ceP`l zoVT=jS`oZhabK_){4iuav{XInL)V@W&2?)V%0<+QeSpFXQpB~EU}FGQIbHjPkUw*= zVha=;ES%c_w#q_+fkKlzQ8>q~Y~YztsRq<$e&5sR1aWL&GsThC$|0^0xe9jov2R0< zoPm%w@bL+gceGeXUI!OUvESd?K_ER=BlfGRV%YE|j$E1o@Dm zoOhy%dzjf*J+vUH5%D9eV>L(}$vT!A4l_-v)TDEb0|8asqs+d1s!wJMuMf@$@2}JA z^B4}z$#K`k*N)5w0ZCpALeTaG-LW6K+BSSFlRRcj90^A2LR(o{J)bm9RMzL+=>Gx|&M3+xlbAh~vRT;TWY{OOqB8*lw!s&G!1^c2)UCp8pApa=@nm literal 8941 zcmeHscT^K^w=PyBD2POY2uM`|5b4!8hbkx-}P&qz69-3cQit7Yk zy-M}Pc1<1PyGJdxwsT&7WEJA!;Ry-~+S=N(w6qiz6~*CjbaZq}OG`>hN^Wj$B_$;Y z1fr#-B{DK{e}6wKD+`auCnY6u+ZA8FW9Y(gja4i3&UyMoX1-Qqy)%f!Cp0uXf^cO; z1K)|&G~!2W{uNYIIgefRE`@wZ@Vb3Ui%YTEf44@vSVAGUvj%Zznz!DO_S9L$%m0J> zHl`3gM7aInFxb-80y!G1X>l2vM5{pT5Un+iw{0N11wGL$wFzm4GO|4~9GJgBXE-(H z$R_o=!Y1-t11Xsjr?Q{mX8t=Wb#6CRcl*h<6#Zb!jW6PHcEa$ZbHE0uqbuR#rIjqKpj95`O z&?f&OA(-g(7yy4H<$@JZ3QHZ^{t%Qi1=j>*`DUM4 z_{{4{Cm0KQ9JFn`1bmqC!u>Sr3o40U(|-0*FhA-%kCD;{*mrJkOG58s)}VS_XWdl2 zzI5*tm*C#!0RW|6Kv%#1RyVo0{Qv`h6_%**J0$Y z*W^4Uk7DxCsq^b2WUYJs;Kwz#5_W}Q*D`ium09rUMf)uGUy7n7ty(`n z%V%OWm`GVQ&oYir0puAHgC-)bESlVwqWysu>)O>9=#Ek?x|Mk^+E-2Hx1lT?a7U%D z#_FcV^u72CV9cQs7#O6CDD-n_o)q84i%atit$qh`MH&w34?Vc<7t&}-nuj&@R7=YB z^cv$9pr31$ZgDPul&TI0>iVh&)C34KJ_Sk7;&c(`Yp;^mqGjTlvv@9c3jzJvO+(|g z_xZp)Q3+AWW(PSgn>C^{;NlU>L9tDl=sg(TC9hAy=CuIlm3!dTT^qr>#7gk{o%vMQ zl!T+uJ;SU?5oDUcl`U_14JWU(;t?b`9P<_R-c?`h?qMC#PRBNN{m$J^VgeK8!At{cW=yJc^C=HvLfx8 z_Uw`&;n92G0?<^=Tj()wvu)HzO&097O1nu#rThnurm;FEb(}Yl>1m4kPYWBv5z(me z3i6y#sEN~U_mJ@|>Z#EtbU3(``N7fic)UoY zIH1#yEjL*_*5yWgWB_BjYmiOsZ>1aqjyr7XSAXV%<8Dq+JVtOUa=LGqqx`2`Dd27S z*xFjjbh2qKduMcufG9SZb1?dq6zXkgsF90UsQ4w-gox- za^5QxS{7PXoDFvzR(lrs$+Syhs=D@V;iD4-g!ZERW3tM{1Dq2(#-Dxo?FhszD4Q8r z-h3I~jdXNIqnr^ zh~z}ZJa>Sm%XgMGO<8f_vwv8+EyI+(7HXo>xB3`Ow zuAK^5f6ivFL}(3lL(Pcjy zV0Nd&tGTQDD}6mg=281neb%{sff^2jvFxIT7<#23hsQ(y9zW9G^=`aVYv@VAMpl0V z-r*d~?Yh1QbtDC`efzWrLD{n#Flx;oQ{*dtFnIw90WV9e7`+HzQ2KVo#Xo-*TzI|e zE;SbhJg=Dax{6s&B~t-({x}TLzs8ewl?i zR)my?Z} zp%?-r#&ZObee|x3#r=t~7A<$7j@A8o$hJu>fR0SvBcoB#dCthwDyP~Zs5Pe6Y@wz{|Lxq`P&Q~XN&q&I7{G7UTo*lKz%c}Gr9H6VH8Aey3&NiyS-Ut|B_39gLbH+z$;HTB;4i2|u ztPOc*zM!P_rCrr1xWx{BJ|)pF;98I9?^cwZU~XjD#QMWBsM$#_J4jXJR%X@pygC(G zeLpD>rwl9{nj&^X%xFW%wLf_PwQ;Lnx6ia%6~ESOP>|?WWjm1KH`cNg$F-D|^iJxA zhqvm^ooI)rP8pKX^HqWJBVa~o&em-Ox^dGKQ0ZaS&tL#^jkzYi){7gdQ`6^!{|+fd zIQU!Q=!Ivabxn$vddUx4`aYQSPWnw_La|W@iVL;KB>cYCY-afpAL!2Fc7uF@t3^oR znOi7IqhJ@2OgS@51hNrg^uvO_)E$=7*Sm*^<=-WuYN-<2-0|EZ^Qo`O04_12=^3ab zRez1%(Ei|mZTdVakNrEY(cmHS!`Soez2@D+j@Mf9NuE}H`gK7mQL-Pbb@M~SH^wXq z>$I&LzoS<@w|ft(C5H2BOnBsdJ0@B(==}l$CRt{9nTe@??7=p2mgZw(k+RT&dH#}m zWqtQls)iB7DjiGS1%Z|o8DBtGxV~6$481-rYNDZj1Ag9XsOsBH3IjpaO7s&pbV?yG z_B(#QP&Ol3`TE0djJclu7(J2_44GTIRG47L@$M)icW~!{#$vIDkw7)MEhXUEGy}D< zvAt0fltq_I(%}jLgz7T$zVAl}NUznvUb1Ro#IGp+?Z zncrtjcF5qCEo(9l#z&WmFb3LCu+2@Si9F&y6qQz5h7&GS%zEwxH%0DZLR~JccV!Ga zf!zpW0g9M^?2r+^Ye30#6txOa|r<3A?ki($B@ z4~5z^s_&|Eqkst5zYqUe48oxRFjkk89Rt<-7iyUT*qFb*e_#}#-al~w|H1X|0;)sh zAB?m9&i?muDqR0%=>CPV-hbwVl%w)Mop?gWfAe(0_rKYM0;;u9L|>veXN3S(H%phQ z=P>F9;HPfjc!Bu;zLQFn-ibC&LQ^l4xlw;}oOIBYzYI_lQR!6wOXx|y{|^^zqyM5o z#Y6os5PBz&DW70<o$5?f+2f`({=~{Yl_>7KE>C-`HO@OJ<4A zCl%785KC*C3fzIZ0_VVTQrYc6-fDv9!0d&aY3sof1u-vyxz;ilWVfJTm{pJ!~SYqvKEMSPfoPGA9+h4 z{wPmWg7Ehur#yYMUWXh_4LJR(e9dA-AU@GxDM^be5vNXozCwl$cG%Mgdvpjt>9su@ zl6DpTbHC`tqIrULXVAG?`0zVQ>lc8jVwgux@^ei}5YCZVNP6LbOM%9e4+DJ;jD^NP z5f@Gd0tPrm9g2VuVGvF0GDd2Th2oF6z|IvkcQ+$FBpTQ@yNF~IU&)FGo)*!X-WJ39 z1t<-LJg)?rLlR($KBvkwt)PGxpuF`N4D?qQxDU>~J_D@L)9^VZqQy;fl7!~QO;q9S zWtm?&;Nnl&i~sU5u2L^S)mT#X%ca!Dr3EmoXo>QEl}6EwJ}7&|jzy7+(oBEjCxCaL8~uZ0;KP zEa#X}3p%3=`9dHoVc#%Y%BCK@7zh2OIJsFt_LJ)OThQ9w0Yx3@lu&R zg?8WOOnN_Q29S#4+^>df0$$LL@EnOYgLSZ+<_I24imgu+r=}0<=J$*1mvwARtZTO9 z#s-LkhpOAx-1A+6e%^cEnp$ufKINdCcj^t|v;9N>Pv?H+6*|I+qdT{}aN=3Y^=}}8 zxzV^});F4nZ!^B;$>ztaJzPtTld9W5OZZGg)t0fP_*8EG$28TaS1lE<8@8a&ZauAC z@39a+?OyD$l6qw<98K`fER<&w!6VQ9dW1>}M@N$47?n3S*c?F-20l?skhbXJ-Q32P zX^5>T06)*9EAKv_Jh5{-xcObgc5T!WxGiPEG(@{-u(3!?0(^E=Zx@-IKffdNk&15g zypB$ZV;DMQYoJ{e<3g3hyZbpDwg8TLPF(vzoiQ*d|9V|qUO zR55;057`t^pr?{x^uoWA`k%!A{p(jJogqHy>!x*fPmAF+1%KK%?&5GSf5h-~S+M9U z$0I#Y@?+Oi)ZfzPzxI(JNs?y4@iRUXr+x3BdSJ18RzkVIq^K4I73-D-?0vWy_?Si~ z*IlUjkBond@bf(Vx8}#|9!Y^eM!*<4r&N(%tBPeFg4+ zYiP@_-kQffTxRLfA9V8v5Q98Vut9Yld!t|x56zUZQ!f6dvrX>(yJmO^j z!A0p3PbOeQK$DaKzqX#=X~n)LNxB zKqo7!z;f-EJ{1q_hJK;u8OZ3^lGD6AV9ToF+ zQ{+e1&^mK5TL>R2PitC+*I`Qj{mZ`r-gPW9OotJi>ds@Rg)--^&l0d9g6Ikg|1!aX z7X^m`gi-5p%I<)fJr}V1oelf2U&?brE}J}{9;`i_8_b8I0)n_HuL1bSxU+0bW$dpJ z4(+hrgd#eVlTS1->=9`T7jz8R#bF*38wk>NKOp z0<^`oj5N3AJ_Pa(13NpvYfb>^97QzghgGvNN8ZeQk8jSp%CLHx{3|oL)@Od&4;FRG z<{rMi!LJGkb&M;>=~V5Pfd4M+%S{PxMN)*PjqigNg=#6~i4v$CqT$vXsKJ(lKCTS7 z$Y7P*9h;xOEg(6{!ccZLVg4;;EY%qCC<11>f1`63K#08{K#E2Eol04!-=-&j4N+!T09}Dq^90qm#+LJS-q_ zOfk3*fiYpsL!k*j3OwJhkbhm10aw1~!E|l02$!xla|goZd@@plq%UGCiu~^)??HQQ zi=*=#E3RUGf8sXi1?DRs$S_U*ENf}@x+#WubXyj}vRo25?pWg{<)ycP_}aj)u}Dsb z)pO?OH2xDMbe^jquQj1J+3W}BaI^^L+^J5FNd)fT3s&|tTq-s+@-P$L?}pgU%7^3S zg;%2vjq4}g)MF=8sBp9R*w>|1OfamLO05=>j%KAQvrFQ_ZKNM10$DzL82qSvACpgx zxcJ$x!~dP#x^>a5*J+4x@8va{8$14aCEzM^(&4%(Tcx$%0&}O;S&i_YZ+V~9n{k*! z3eZs_-b)c6Hn2D-vU)xOr_OhYBYydskh6Vn&LFd%+m2Pz%7tQTgt9WJ4_QA37S&|? z_~ZB62w8_;XtDuJLs{#k>;s?S6QYEI2n^J#jOfS-S*kl&Gch@z3(Bjcb{0tmU$ei&LZe`9fQ>2FeHP-i-STckR^DBUw@jZl!i6 zMH&&q%wcBn<7f{zpmFm?LusQmQ<+yKW5jaem%w#=nGs)<3SYE}av|QU9k;-74gWee zOH)B}C2Cw0g!gCUY;7AG8%;^VmiMaI)TO#M_pLAFua=N{$}cmC)Ju=QahlN30F;bf z4@YDDuUtIC1Qx-|^1Sm94D11(@1@Jcy*%`&O1W!a3gf`KOKavh{2t)F-)Z_IfG5^o zJN(7%+^DfVZ=q?;joX}0DbSYN0AN5WlHs3!MCjr ztHj;MMqP$m437usOU8tV>p%B8cZhe>K{ZoR-qJ_()+{}>q3XPwIHL1L|4nQ8!(8$g zX1Wy<*WVJZ+VzY=UZySRR?h3)iS?azw)V$tj;Y#35>j0#o{c*CGfbp?wZ#up-=$%n z>1N}{U=%#kYPD8qZ)3lvzRLHwITug5Mb6XLQ>rjCX$p|2G+Nke3mIB1V=eiKxN9`- z4T*8lD81v;g{n0(y_Y{G*UE9@yI4l915{ucdQ+n+#BACLZi>`Zb=WIy|Y%O&Cc!5KZ%k=>Ai zt17IM?6q*?5dyzqeKNzvHmrTD{?9ytSHx#ep1h~MS>JXMxr5VuazsmCE?V}$MbR0H zP%m>1q1;Qg0UW9MXZP{e4BbJ!vxX}Fk?*Rpy(-nsy^WHlXv8TZg&E-OpM_ac8LR^P zRIf#?j9G>kz6Lywjbng(-Fquzd?2yXZY!Cmwpbzj@*yJC*pwUBXm+!i=h$;Z`;yq3 z^%dZ9MaQe1Q;+w?@AG}Y`FxO?0-}1!d=^rL7#($@jEP-<7E{o|h*e-6-2Qqe5art} z3CV%D)HvTJ`XKMeq~nx|7PD@APY5;X;BXTEWp=;ob%w;$gGFI=hC4>_eJRm0Hl?cI zR{kY`oKj(99rq$@IJNK*^#X5UfU9-CcR-5h0$bDIH1hRSqn-M=Vt10RPbp%Ftg@;* zAz(O>t-;2XDlH#Nr@`_r0#WFhcA5Z)cvB~N66O<;+#hD(IDCPV!zZ%ZcC~iP0iAqe!d0}DOQDu8{}<|rg2?~? diff --git a/vignettes/Figures/SU35_ERA5_Y2016-1.png b/vignettes/Figures/SU35_ERA5_Y2016-1.png index a48880d44bd0fc1e3f2afb4e0db40cf6dd59fd23..f7cc1186da16a724f139e48068f1034d0b3874ad 100644 GIT binary patch literal 4229 zcmeHL4KS4Z8g~+RkrqXTwd7O^am)8dlCq+M5? z;zicC?d%>Tw8z(C*+p16%lc|9%kJK{d#8IlGiUCd+svIgGq;)Ff1Y>V|MT&Gp5OC- z-kJBdr#ntrQBzSyMn?It%fVwZGHZa33nh!Zxm|UZj|g?oBgYRR@&~j!$9Vh7IoH+V z`;zf~sZ{z0S2Gu6Lm|S&FG@xR4SrnT{M8{pR7OTcP6Hr^Gr>Z0#=;-_rqvUK+hEzgihtPJ-cVBq-QBl01fVIppq=rJtk zqED93UKS2nPi0b0l!N7kc7=2}gRfVcgr>~K@+bj7st@PxT*0ak)0p>}0 z53U^1Zw8Io`V=(w{O|%dyxw&13bky$T6?f>A7smsObXEHn5-kiddlJM98nyJEii(- z^)4oP3r++n6*@eR-&qdT>1*1e!tkjx!9yiOfdv*I@sy>1^&SY9=8rvAS?53)83`T3 zbo3R1?2Fn(q|HoG(*-vFO{sq*X=EzM0@s@5)^=u3Emnn@^wPSHK9jB+i!)m^gQk-k zM+MX^Om5F4g^Kqbxv*>iN%)mC*Ns<0v`WZ5^#Yc7vw5A)UC!*3567aketsRF2*;@~ z%c`YTP=M6VsZpn|iQ8TB_Pq2>cW?vcR5-WacrdfskQ5It_)NsFyziaccBXtXzI9+n zLr^{Xm%ZJ123J8XE%eV=9|uYNo>8S&qGCrN&6kgj81RVIV$*xe0;nJLC&Z@Ev~d5O zS5BG)2Z${fQhR-+o>zis-srOnsb>UMW?iBL$7wJ-r( zDzEDwcLZ9wlA{2Q(Pcbyt7$#WKWCm_VCo-AoKOIXfe;g|#lNJ@+S_ zGaCe~SQCxc)BQ_KH(#Q@wSOcw93XVkZvgp=6-}m4558pqPGvkfj09Gou^Np1L|H<0 zoy3Z%iR7G4zVa{lln7pCrEhBhm9?AO zUfIZ3w6N*kh!AMe@U6XK*dzl_m53G>nODZyHsXD~!V8t<>zGp}&Ny(|VgSpS1)M&% zMi=aZuA7$c2nVCCl6a;NJ6AqH(~M&Omy6^I)_G}FckyXd*cP&R9I>yr3^R5%w!TBK zost$D(<(eU!2OT{JDarQ7<&(lIgW@>O545w95fF*e8U2gTXNFMSXo)S^9y|Z-I-?k7Yrx6sGn&`o4}*JC_5%d|_s+Us z)xTEeYZH9E9{V z3pBy@mOyWP$oluAyh$mnUl)@7bhcUm74(>sZH3VM0@fkAP1_xKUsd6` z%ym3RAF|-bK=0ZR0A2o%?Qt3*T^%Gw`1b79V0J+$-VMb1M|eq_C-<3K6J3b(8);Yg z(fsS5;TdKLh*2rL^kVi960wmcGAY{8yBnGHAEPSqoPiR=|KE$q63_@YVafQfij16g zDYpfU1lXjM%qR`|L_tMzqClYb+HJ%M@j6Zut-gN>>mYO#Z(`=WMDg_S-qUwLv9CI4 zk5~lmHIjI|KQriEk$kh!ZDa#ta*A#fL`S|dpAz|9arYnljYS5(A-T|L-=4#H03>7D z0fpZNO-@zARpnRkAzksRI?T?yH)AAsoQM~g6OD@bhJDZCAG}`Z?+!Pg>mbtX zf3du6M^01=Ry8KeRiwcp%Sm!#&LpSQgiW**qZ7%3-m0YNTB$2=udjhxV={N_7S?Zl z21;qD{IYZz@Mq(IrR=8FeL2NtnGbNN~kj!1|v zhd^;I_|cr@a9n)?%xPLC$bt1K3j#$NL2H7iP8L|a?KMR4!k?7*sxSwvg45z8-)-T+ zBC5m5IuwmC#`!rfdpcO|r6`@}IU2D&)wtCncYvS$9Y8smLVscPQaiCC;60U0irlqc zpo$61aSoORF8&liUx>D6yz#x z0#%v0a06Qdkq=-=7*D)Lv7knkc?67X+-gJw>YBG2#R99xT>ud>F_PgApd4vF)zE9B zZeLSumU2IP%)_J1mR9phQe5?Kg`~~)vleDn&I+&Dd0k34NM&!VsZ9&at}ZdmZolJ{ zA$C4J#+OXZw-Ey)@!LSLu+?wkPu6%m*48$K`-hyu<`*ma(29;nyq+EY z=X`#e5a405#gXIRo4Dslv)Mf{cyW%Rhom}m5w4N0#yPoWBnw-%lXkYP<4t*RJXjvo zu4?+5xU}f`nF~)>J3mx+ZNN7+D+^OJYaUw|NiNIICVocA=k)yZ`JMDWKA4ON-OlK=n! literal 8124 zcmeHJbyQqSlb=8m@&*eq1PvB!26u-rxVziKCAbC;34=p$g1fs14}*Jv;O_3hZHM=E z|J-wS_d9!5&Ud@-y?uXm>vUE9x~n=^QCM(3|IMd^ zhAfU&g%4bQ4u|$ao0@iHKS%iOpY40+oJ&O+QQ3qCy8O{Tbyl&BlRE;mr0{B%T)$Tj zyfzw!IGrb+HP=C<_>SwY@9!wxcKYqxYN*oA8#do;y3uhT zDM&6T6GZt^en2MoM*5}*g+}y ziD9K^ET(#-#$2%bmS_wlvT|jjQJ@%2hxQD5MU4yOv;yu}w+93*z}yHUrp~!kw~II$ z=xufcC1880Tx})r%Gr;op7G7bzp@lFO*9l=!?_A0g>?1K-)}4#T%QOIh$=`xJGe^*{BCY%n|Gm&HcQ8ZBgHF@)a320F?g%tJ%KVU zX+aX5U6?{51MSj-&p(TgWS zd1DG0y`Fex)6!T8b|DQDB*lHRD##>VT)>RahrusucNY`LprD)^l@j$edtH}ZPUx$Z zBEQBd+jUREh+QJr-uW5Om2(QBJ9+AoHu3vV)(R|@mddM5UZ?EYQ^Ite{?Hi>wyo}$c0@F-T4Q(Zzxf_=B$1?I>oRhmMQ1Rpoy*VwI zRl&9Gz(U`9gyI$%kt|8%a~>mibXohV*oDlaoaW0n^M7rIp!dRtMY%k{IyLuhx=h+N|-bY({Z?efmN9$(FqwG#yJ{v={Fq*X zxEgmPxjufABjL0K$;tHF<)Zok`k5I!A9CJ4;q3Q;(IzDybzqhC)wQNye&H6i6h-9O z2~)2%*Spq@hitm3734MLV&QfdccuBtxRo{3S=`(U za~8gj`JK1jfSI@>j1IYpww%(pjw+4l7IasDJx~^_e1yi)6bvcBPGw;|RQ^E;KH)%} zxr9FgqxdIaqU{V{~E^R(dwicV`aO$Th_Tee*}PG)9h%HZ59 ze~7JeBoERAx(| zgYwZBt;yEM#7~&0Uok>75#V z#|d+xC-J2d=S6qHQ(}^fj~Z~UHu(cXMblu%M^(E7;_2Ql8)Md}{#WWj<6sBM2 zE~u>Z2?l#u<^s=#;#-dcfL)mvQvTu5p=42`8FAdAS~$h&j?Tqt^^>ze|2x|zF9Wk zYAXB5HQ0ESvQ|OsRV^nB1-P8&0$(mXowM_Lj)2xbK z2UE9f_CJc_?)HyyDtO}S+}Py7Grqo4E=j+pHlV%c-sh$?t>jfpY`bR7d@X66AJ&BC z2Sa; zJk6DsF!`WO9v1&xOebdMYz0}%(5NwFLe5m8EXdvSVHTJuG#0C`ODC{E8(yC3@O#(9 zlZDIML!4RaIQckhE?J9fdAnCTJ~O&i^3S`|X8RIq@#N;!bNoEWsxo7__|jxOYKh_P zEd)gDk_+$XKisZyzS(JbQ}Wd=j~0cGC1G>2K~;$FW;3S7d&%9#+2dp-2~%s8?)7bY zMzVK`haTbhuM~+uKgO~3JW?DcnFuk?nX4({2CR~CEtgdNBa6$3u5p6oVdJCY53Ln= zf#!Km`K-A=!@muy;iKGKrxLu2J-$@a^z0fh7QhuD_%cw=B<1NL+UTf4s5hK@z(m>~ zPfa(GSopC?JyL7i#d5xyN)Hp2A z$j0U}6lTgt#)+ttXezFuSYV7sEQ_Vj(9!h%RH>M@YP8mcex2q8$y zDe-6RC7F50Bt7GLrweSBL8j|ze-{~5|#4kn6%e>v+BZW z{O**8hsrQ!F`CahbiKE{@TZHp4#nx`)G8_r2xa)ppCVmtI0B7%HZR>D9u;n8FoxFf z^C2j5`T`?v#@8c?@jX&|mn$t}7#hBB?ru2RW4u5cu^S@uk^K}~Ne&i7E+0d+zV-Cr z_RlhYnDMp9m41aNrv&@q@vn4@d0|uK&;F64EdX$JulguM0LbVjy|#&nqNhz>9loURtDAi;sCobm5eZ z1WBD99!TT3u_Upyv9vjgS&CVa&|pLZQXv}ne;)ijBMm|{gk6f*Fl<;f!pdJsyp}K} z$xK=h45a+e*MB+$Ngsh?nFy{yA<)00h@f1F7AQsz%X-3|gowx@gtR~~=m}Fs2>(?f z@gLCrCuRTT<@!&`{?Bdo|K*gaJ`8&te2<{bi9~F8@~7w`wm)JFMgU5P@n1{zNeD(H ziYMVy7I+dq<%GWhM5_1;_Je_QdZ9vxy;oy;AyNMdIFukkgrgZG>n8F&Uqjd!GlG|ETuI4i8{Q%U!$3EeH2)5f z1vH*+S@U(J0fy6nhm>*b`5zoMM~{LZ4nrxw?*AnBJ@@8~>1Ex^#PaEskAf;o0;R~o z%}`(q;3~`ff}`s)x7fJoK!F29Z*KxT8!3PH;@Io)ATdzSBmjhzpJ(rdW*N72zS;Kv z`dJ$T%+4-RQr6*_d0qt>>_;Ei%PHqIHxDcgghZ2HG3*$E%FO`-NRqz?KGUU!k>`iL zN=b$?MMNY21rcYTj{HVGh{xJ_9Htdo<}&mpx38Owf-ajVQ5)@=tahFIO2nca6A|T_ zog21>4FmFPr0KBmB+2dbltudy*3dvof^4M7?X!F$si|N;XgG$HP+A63CF3HY%kH)H z6q8$LL=JVdByWHFb%x?g0R3oc&y4qqT}#d;V-C;1d=ZQ%#3G0NaI#UNqi79l2~rh_ zsn*M9ZsXZ*u+~w2#SeZP$iDO$3w&GuS@I2a-;l6E9$$zi2Qq(GaG1@YN72@9168(1B%)H!mU8UZGGr-~O*`0O3Wvm^O3#+aMw)S=+_Q|X*RSu| zg#i(93^>2QLSf1zbu_N1&ON~oyK z{6-D=98`1rg_dqPnLW6{#!h|Q@o+*IgnMi=Hn(Z!#YPwt4PCzVpF_tf+!vzYLqtx~ zRkwB$oM(9}HZujA`$EgUtf)^ZTYlEcNM8ie@#R}0MVKELq9HfD;!;D1Cl@AJBNPNh z#!#bA+|z#}a=#TQcNtFF{hPU~oU%&Wl$(^5=#7Hp2eHn!o=PwTD`B2kH1S!F zbV^Xr-eb+^FCh?%e4|jufp9E=y))Wdw|v z(~}k9|L_^!i(bLg>kWy0lC-EOr6M)}{9KY8p!_Nl3dng)_OvjM4MqbRG5WGW;$r&w zE+pUjQCg)`=Eyw+=cNo)zuL7_oANbleYIO3P>||L7j{QVSEmQZoKnLYV#2F-vMmG3 zt2TPBR#KCYUI@O0R%2*2$`~?uwth9_^je9BI9;(&XNme505gN;a+rHdo$teq%GfL; zkqq{6v>WL7AIf$h9o=$r(@I|BO3#mD9sAYQ@+#-@?Tb#Vlkf~la{nm)HM4`lLzwep zst8^wV0FV=66^*J(-<1uEIlcvwqzmU#z?B;%H{y1Ri!)h)`5vXw3*CZhTbymo5`}9 zR*_yMv6xN#b}`}v*OaLouo9KeRjt{F88n6gT7QxaZMm_!>lRYErot=HA>Io1Dft<~ zKri*m^z-B<&sz|u4T-|JNpqpZ?Q;}_2}~}i#T%*HoQSh|^-!2t-45`=0KJ1d;wAW4 zYv-UhZzi{*chCoJUxJFGm1RD)1UPPX6(0TQ|PN#w*Y z-+MR9845fu?YO=q{b9&3<~TDJTYrW>=zPV^Y?ZHFne*OHVZct@Jo}y+l!&aigEw3|eq2tos^kw}07tj@JwKl=**&b-}@=|UPOw6UO zdU6;D__&DAJ7-PT!vfpj%#NCKd$)F;Ci>))Gg|&GL(%&1VXoztZ9{UQruytYZvr5V z%VsjJWR6Q|`d~P(l9YQtImoC%Y9)EWrXA(jaz{Bq&9!aH$7c~1Zfti!H$6GAW_646 zNkKh;RNy4b!L6;{qfXZINDh!bW*f7~`N4cl@6MK*b8$0*QsMpc){^N?X6tnSZ7xg$ z8QbI>Cwcc}v}2dPDx*2rf{LF;af6K}w1Iw3-XanyP&KgfZCZ_MK9r7?hN625^8&*o z?b9pbY^mr#9p~(eFPmnAIIsO;+)22RQ;Ip*CH+*wWfngoQP@i>u=+>xuK2P2m=S;? zq`KrV**A!+{Ijz9H8&Rwm;AXrHs4x_!VV77zip>&wayiodIxHTDzUz4dd;0d%;U~! zKE$`+bV}hJ#RJD@M5)N^2R(eeWEG}_x_GWfOC#ZK*Pdlh<~HuZlAu>31EP_o7e5E$na=#3u=Mf=W*os5&Gu5{<}$!* zQ%Uj!B*cs<4B+(ya+od?KvJeFW1s*$Yi>Yoj3Q ziY}0lN%!yA>1yOy5tol%#5Pe&(as+=*c+II)%1o1h3YVv?}^Idez^HFOPnk~IA6a8y##7FG8}OyO?c>$Sli)r4 zWI1K2q=eVKN7A<;@v3oK?5suW`XTQl$1i+?R^xB}Kg+NSm#eiyTR$sBL4B{2kHx8! z4^dESPK!@+ogZ3aQ?AcPIIC7EsKCy88`xF->X0|~An}~AfKkVU0tLhGQ@kzB%ALBt zRh%Rt8e+ikUVf}J$hTUil%Vg2UyCN*!sQGqCfV+13>dFB6xhNpIdH)smbf5II*L^n z=Y~KvRbls6O?$@jhGo>SLaeBpn@b=K=U6n{Li5d){vYDG0Xn+tVx8Ch!8f*<{f*3; zSd~C=?9CGl4ltS%!y4n_yj^q9fdZFXQ8$}@wgJ8=g^~0N)Q@}acUn@R&aHoNU7X5H zpKgdNZEFo)y|1(Kj3qn-d#CfOuuz+ILqo6)uoL3(0P#{TY!D4A; zC7kTMIj|3W2Md%I6HURwdQpu0t|_JTqVz%!t*5ei_Xbbel#?FJ|GmpDK&IVFGjS$% zZKm<&;03$;rZ@58aXQ|_LT)6T`!CyMvqf{4&NiaIw&P=<`FHtwhFO*xwI@ YXRnRxGO@drFrU7q#N&!Xl$`Nl@O*MTr6%`dtcejJbR8&@>-Z$84rRK`R(?VsZd*ra6i?T0Wr^~f4lb-c> zSM^W%_@F|eSnFZqrZlL=xdok9QCSDPZ=XDHDnFy5qI1&yptE0M;S6W+#L!cnL%`v( zG%;c9=REhN%#4$|@&l6OOtSggy*VU4zbg`Zd`>d808o?D(;2<#|{URASBP|}LD zV&jP`r}KpVA{ksfC)sTkZJB}+rKOA71zN>Ry+v2KcZ^ z54nRmYz)Vr<%p^5=tOI9C2jsI{)iD%o#NBpRfmn~NhL5l6)WTOg#%Wc+(mV7Y<<-J zyOM0~x^JU!iIf;B1819Ww_bS#=M`Q)lp8!ChD6QALi(VftE&!QD(x+K(rdX ztEbI)f7Shz=meB(>tP|MiDS$a^zsMXQH&U4vA>C-@E-0=N_g~I>(H2)DgqLGvvWGS znRYqCu+D1_uRyatRbG?BC=fQG34%DmT7Hi})DcYUCIowNaX03m6A4?pEcxhlSexv- z>`x)NL@y7JR&qZX$&D+l6#D-p5aF8_7rbR)wHDBYi`H^i!Hijn_0vOK{ z#K`KX5lO;D!JHs&SY%sHniZZvkku){!m07uj6FDZvJYoeBgZelX+r?=i9<1wSy`{c zn!80wJ!VgJM|H9};zxEk>O`+d3gx{S^e&Fu1`6*8T*VCbGUs9M2&>4<6*=Uqh~PY- z9c3YbRu-8$Xa*tW!abddYdo={YEc2kP-~V0HHZ30Km$rC&kX0lUS zJg0{8XLjNY1j9ZD@Cs`jZGj>L*@3k9599(ObMMfbaeoGT=xh|>?!gC>;XjAnx3*S*8qp%(xv1l=gVZr4FG?*E&gO9 zNnXlOd~Y8toh($N&|YLiT1$Qwj+&ISioKvHJ(f|AOV>Rh@2fj=Ftl@+gs=YSF;MOS*Vc;rvc@$ z)J7}rO7g#YDu<3L9#!^e@it`Ecv&Ua_AcZYPFEaH7HF`Cs__xTxM?25zt)^1&0$Y6 zZ$*dog?OBgRXBEzMP&pE1Mj0P~iXepBoua_n|+O{mdKee{o;R5X~w}>1*vNtWhHzq(PleWPqCR1#Sq0ru!t>+R+a!F^L)Q&2D8X;g+CvjWj z9~h8KgbxTUlb^Ln`4|(c6YHOKt9mi^4fl;5qcZfn>+IRqZEEJk1>!j3#UaFw<{y1B zZbsh7M!8-1qB!fT9%Nhh@YnY|C4N8PCiqzptkbm&(?ksk)zM4V)(iPdJThSszB6eA zEPhg6DhS1{+q zG+hy?zX}-i?XmfkUR(Zg!pB|upHo9VLOZ8Svrzx7U}3+%F8#Ut-$ZN*LU|G)+Xs|g z>ABaN$>-{zm8URFno=5qY-_iHCVcX9F9!QX7L=;wP&F`cbNb5ND)R7`AP0mAh)QA$ zr1gQ=Mc?;Y_KQMd?wRA%a`b*`-QvyTK8E9oBn$5iqYv zcf6<6*&y0B8XpPtk1=2^nJb?V&VQ4${9W$3Z`PY5ozd0%~c4kVEGe{^7Z;A286^XPMk{ye;)jw-PG^&p!N5P zj4g!K-2x4IlEGxcXFzNA!oDNW+b@nMnLtf9Tt4mkwhLq-A8*`6CC zp8_*D+kR%Bf^vyW^b6J`UVqhyNI4{k^VyUaRXrNF@m5|XlxZ;Y&2mP`tNugvBFUMh z%`nW+bW3>&v{9;&Rrl(p!W|-j^7VW1-RP@zuWEH!?bOiZol)_6!4p7qs*_Kkg;sc{ z4H$S-h7C?(uDbL2X!Kt<2oz0KX z#W?+2d93zOjLgWPXz$hN>Pt%uefesxDH!?<>N+b-{Je3?`i`1Oox=*(pC&9*`Hl?S zW>ZjS61W5%D(nzXoxQwTqURKKjC7)TLaAwe*V6__)m zr0jzUu)(vN{(Xe$fx1b5ZLJ3k5}$}s>8FhK2)lM5q|mb6dzJ1oeDd4&kmE06gN1U!u1Cu~UW1IY@<}POc86pvrDhDR z7M__P^5I$?FAufBqIT0dnwMj#mhzX2s6~3|ay(e)z#6_ z(Qn_rEdbMKYHC8E(4C!~>FH?;5>V~?iah{;Q(g73yn*-hmdW~;%`yt7ccEkb)_P&b zfkQL*nU)BrKWeWY_BmXyYlVc6gP4~O_is^>5aI{R{g*cgb7lSdW#eOO68y#8ob1wK zg;tvArui0Kypldp+GQK7xD~oVUd)B9bKmmCv(hgm81o0ec%mx<_kMuw4vNpsT7C@d zYS$*sUR~{FT`o-=;4?r@NIpB|3AKx!jA~#w30hu{C>5i{JRJMAS)Q?!%5h4ku6&Z+?2U zNNrwAKTyvDBAzSbYvCRjrYq?-RAf-12EB*N_8@+Fb7+RFQV_IiCAz7-hDY|rh$Sko zgXr#^!oA(QE4a{$z^L&U@@}4{70xY5) z0}pifzH;9uw@~L~)#r_}`|)|$r}ns;`q8CGr4jK+&MJhZ-Bfa~5u~xhRi!f~^8Be- zFryB=OY_)z@whnJ_XQ{;(n50%*ebxs-h#Y5U)r?2eknq6!Jiuw-NBPh;a43zbZJFA z;Yzn77=02{CYtB}kQF7|(Ioi2K=#wSDZKHMJbV6gy?hA*O$EB8KQU7$M_)ZGcb~?< zTf~@unni~j9ZS**ci8)$GL7`xu?+6KN z4nFgD)viQr?gWsnpUt1hmCf^#`>PGS-hbb*YC?qK^?ehI{VW<&Tf3SjGO3LblT98H z3!OBr`~2HeD7{x2CgeZtm7F=DO0nceB=%qf{pYSDk9^?pnpv`YNJZOR{&?o+_V(NN z*tUaSz8N07TRj!F_NGy=bAa6T-pl1~v#A<^*XEyU!;#l<5>gtqtVjOHQuD-C&Qh1> z__4sfqV5dl4+jhb;jB`!v6VWypAhsd?sRlhAQmd1GXwy6;MbY1{V@ z@s3-HV?s9#*XyiKAAd<#REv`!^6&Kzyn(+3EYnRkliU`9QytRpEO0xx($#qan`lA$ z!e0r#>?`T#c!saN=~5V*6?!J;L?#&PMz<3LC+)~L76JwztW>@WTupu_prY2)V`H=?#8OJ=J`oW=38$aY2YigV3a!TZe zk{b_a`mVOFl(rSp7ak$U#Xn`ZEcpH1C6U|u1W~4M6z%BJ%q@S5tn4Pta`wz5~RRa)&xsGOWB%u9ew9e89v5x;M!iPDO2`s&dKEDAB= zuPizIxR%)ts}sn~Jg;c|wEa4TUuC`&-^cFTa@}))q(*M&lIu=-B(+tB&&v^5LqssE zE7nHeHL!FS^c{$>-O2H@!I?WI6pmkswQ>>-JknG*IYm_3ORZG3v%)f8>y5sJB{2$~ zX&X<*j^eLTV1L3Ay zB8QFpXay4s25DBuvTXb$Z48{ZBOlr@miI8RjJe)+3tt!oUFxI1t-1fk9!6-}F1y*& z^v>qFVwab*GMi2A`%&(|w67Mak4DJCocbU9lrDMJZkXA>elb<-MVPp+FWCcqPzS?* zLfx+kuYsh|RtK&52#<1hA(&XWXvIOq7R?(bN+^nku2fAl8=;LN6G)rz#h-o0k0H=L zYU4EwT(zS^>Em2}VmQaJHs1S@3asUUyHa;n%m2Eza#NceGI4JsF$aUN%FChD;9~ zSE(#wh+}h*vQxM9UblQ1QKAMWxK`I0?qvSj8C4rx3fLGDASf(@qSMf)2c4fp$Wdz6 zzD_*@49dnmmhXgfAfn{=64g5l$+m(V-b}p?;)mi)db>bc>$Z6$aNS9NmmEwW9UMmI zNgvovWzF#t|R|=bs$QHqZiwNGbE;{t7E%Yk^Qtd<0>+a{Y zE=o!8d`ur4qNtZ|KIu2Qp>htQ!&v?x{PMzr*kl=5MBdCBkF~=}%&htINWfP?4Mw&P zUWbEy{GeUqrGw_Z$wP6gS8GEz%|Bp#6UEB?XHtt-RUXD=-vlqRTd*kTwJSK++>$39 zBx|#aOPYN7>q)_^iwUyh`7<-;7Lyqg5VJI;3DfP=XRZ#(qI6~_h>_x-zD0R1*tIu{ z%q#aaEc&~WVaTgQf6I|QIl34IkPD8RT~Ir-GGk`S7XJ^KqJ6V00E`@Af@ajko$OQ z4e9TSAD_DHHLoEcUFP#v*K<4b5BH^X&ApLSUT<;*7+(oCc1Tt5{)lLP%;j}z7HqO| zJ6p>2Rg>oaxX1GuR0Lu@W_PQ258{99ze+ix-_+C9!SV6P`gO^N`a`7AW2D6OhvOu8 z?fuf~6`n+Gfw8tW!P(|-eS-#MDZB>DUyIn43zUO}nPKy1CV_uI)M4Dhw=YMi9==&z z06xF0k*#>ke?WCpQix=$Ml!qm#aBL!8^@p&xYhnyDZ9MeCL;)RJ?zZBULpVJEFmg; znlYT-aa)Jodf0LxkXUPL5apyhWbhQ#50kcW-UXG*Z#RaNGECx4h<{$^o=TI#Xi+&^ z?eKqAoTYyedH7?mvqr=Vvfm=;82{|YlFoqX6a1eXQaU=tj&XndGK7s%`9jTj=Ma#qw}zO_>gzfHJ#q0ma{eooKBbiuX4P^seE>WYGKf*bwzU zI+1-Y{Ow*A9wK#Ua3ohQ!a^ z#y_cbFE8ho1L*@ujEh$*ij;rGo`0uX{I9h1-`D_Q5t zw6BjKnhV?zQK|(0#Tu3$icy7pJKyxG_K{5Z(TV9{?%Kx;HjD4ub;5sk`Ih%Rw+s|p zX;&~MnQ46(oXmV)u=rlN02`@t!7(L;J3%vg-^`nN^4s_qDIEF)z}oNba_t+)9mot+ z$g1YAX|-@kXM0Pxb}LxU15GuzwZcLVisBqti7uIAUq$(jh6XQbIDg@P)RR|#xA@_Z z1VK(zg}PDq((f__{#SVczT@6;j#;6<{d3DQhAjR6+J_953yLi8zq2im&o;;r&vs$D zj}A(t{EG8xsmnum>+g_j&(hCVb=J4;oiIgjrFb5uu#n1L2CGyHI^PydTATD3s%qSp zdkQsw>droIfCj?m{0?ZRL+~Fx`*Phq&+2>!NC;q{l?tEJ)Sy9Iw_f`>r}PNPY19?g z9-mKz@r69p3$s6oaHk8b-RZZ=j@5EQ)zY_VP4MO&sSxiRWJ=Ks(6yX{!o7rwwc(|XcrJ2^YAXA-2V`tFx5SsoHCPAEb% zQH5O~cKSJXd~{W5Q8A~fXTT}A%7cyL$lubn`{b0F$V-?FXU~+VHy(V*`?mlpelbQn zY?#5z`I8TW8R|jP~N+V=k}2XiY%LjAdvai;P zG<`Z)S~lr9e_0-}>?JG1b@e@3vqiA9WVWqEW3MOxQu>OW|9PGBRYm)Gbx+BwHdFAf z<)I_k=c(a}^3yFp6sKr5k~LzveO!CAX)J+Qj>LwT#k!TmZacbNQP z0Q{gEGk0a1$aCSd%|in>Du)UD>pl271L{r5horj6KwP8s`NX#&2&V<<3CT`fZ4J@x|L!Ct&cJV`tSI(a&I zasQ-3D?VKwT^^jnsx)deYFJNo8m9v0p3p?#5a6YOW2JgLI3NmiurInQxi~!H6tFLk zIpBZ60#xFFQ^EiF2mIuq!=Zu01B)5fe;fi-IM@G^!v7giw@x9oa8y#lF$l{R9F=Hr z4ARBQuvEgya7rxYa7vEjdER+_j6;D9;uqpKXn&&KxL&Vbv z4A#F7Pfh~@d0A8~tH?OGn9+ZCvSLvn*&i;GhSS6pxF&{Drod}O{u(_l6H4h>NbC65 z7Y{mx9==T#>}p(a^qQ2k?y~_+4)`(;#ET=e(tJu^o&(Ow3pt=vxL;F)J?NG7PSy?y zaW)o8W?*JAY;jS%gy-#{a(`Z7qs0;!xQGe(f}QW@Xf}4s|C?w3X4o#MX`aZBxL|sS zP{cC)wmCu~l_U8!V4jcCZ7~KT%f~KY76aD%z(QTx))sz>2aQuXh!a&*(cboUr%>zE zf%Qd!i-CAszRrl(y*KJSNl%_K=<-CDxzY`hrHYpPeL|mE(a>c?$0t59YyiKHPsG+I zNr&lq$`~cbg8(SWs;uU+Ix6`RJ~C;j4lIn9#GzVR$HTQM8~fzRSy$u;B-DHO&Eg!R zeNyQNPpFN2uIP&ufzY@V8Z}Na^RT!f-lQjvH^bwcc$2aU^;Ts>?)I(6X~0s+RJEI;!R#T8y7tZRT$rWL8VA%bYLd49(bb5CRLs@1ZFXGMWyy zrz;6Hjk=SPYq{)_*vZ)(nGpwXeEAY6JyXvcDVOq`JlubVG{!2I+7^UMRK5Hn4BPf` zHqFLE)>rQg%6Dn_+Lvy=+EgN$f|@cRE)qk?(ho->21T|LDF-LA&naWFS*(8+Ox%-V zv7Hz-5f}V17@lo3Dch5yDp)RZv(0`NR5O}A?pXia$P0YmZiL=Y5Rh5x6})eg{-UkX zJuWw)H3w=^5oLe(Uc`>Fy^D;v%7{axB+_~i90&bUYNaa})cf=poNzdu(IMKaK(eUQ z_DJ95W|RQ)A0r=<@QjeC)WZkmzf?(dFJ&|gX}0zGA}AFeNc9-2n*R|3S)L42>5^@v(k+4N|p-`->kGXcC1IK zb>Q4NP4kM#_ZykPnXxI8*)Fu_#Ehcrg@u{wgGkMV+o3Hhrk1w1jVqF-CQzRhNQN(7>tU&%Fg}38)~S>$lrjN* z{U_B4zB(j_9Ay8VL|aeHD6&3IcD&uU?bHS6QaVEO$j*eVvDF;E?{Ax`naw1Oqq;c!-t_? zGe>3OOg!rj_a;u^W(Kpm4aN^q615to$cM0jhhh`i)lLCn`$<{OS#5lvCT4gB*P$9x zWMJ#S@QpiflUUA34K0*@$}`86HEer`44f*Mu*r))u)1$lJ~9eJl*K~Uc_9d=88mP8 z>5Hp?LB}X2-SsIygw$;L$%#wNnYFRlvr!E3kJJiSn1OG#sRN&Oz1w|*$t)mxyJ+(3 z?xM+jg8kUaHu#xYr~ujLLz74%Gf$cDA2XQfu>5@;zCL_*zqK`?RGk zZS=Q9&zLGF28@a+_hn-c4QrXBa z2;1ow-`27vP_$zA>N9d}RKcm_^?!DnfUx6Z&1ODFv8Rvs2mGWG*vjSW9l6i`w0IQQ z!xSx7@sA{`hAT}lPczhfi#%(b-5a0(KBlRY^cod15Z`TvZ@e`)E1w={T-3?#jc9JG z`TPysY*J}fOd*+gfh<)3e~b^P*mSo!uzNJ?aDCMrDW#Rqh2>P!6}^B;Axerd0Mi+H z|J%7&rcLp9i;J3XNr@mo)DyN{AJSbhr{UPVg6$SK+uU8bCQIsu@;jN{z$6@AM*O0t zEJW>MfhLXot{*H}`VGAlanR`41Yak8HzF&^T7*O<{@VHY^H2DhN!m7yeT#M04?piP zy>EP@gTJwRBM~_;iJc-oQVLI(ss0|C@Ui_^%E= zLLz*m2S^S2R_I3iBj|^x}akE}MEWDB| zze+c_PBRF+?!#vOP!P7<7&Y+T=$6BtzPO4 zeu6zlscEhx1R?x)8>7M$fZP?89O84Dbl5TW@V2|!*fqGzE7LeWUOZI<@_zh;Sl1c> z-;2enmEeKbG;iys9S|!`?C4N5Wzo^*nNtf*(FvmPr;B=SAQ{{YNTat_U-(ltOhNDl zkoRy#Z;f3sHx(aFbLPZ*p|4I=;n22CXbzi7ykLKFjXX9J6_GAniHj+ZrEhrKo{aUdxgsmR1o#;?=*x7mZqq?N|D_MPfy9%eOyS!ov z=^P++aG>!wz+mHZyg;chnDWaoe3A-PSi;dumPYpBEyv{frKpIJ6> z+vM$KfWB9$G!=SI4y;k{KTIv|4LBfHqO&Dr?Ja+QLnq5Yc zgNarB^3!{AiSOtV8OOmqVi6i4a!eHii zBRE2?j3;=iDfjT?-UWWa%+wX(0rtk1YpPv~gc{eS0OxuNo0MuP5C~p7IHSdesQp6R z>Jgr+>XO{JivLW47nh$UEntjL4RQENK$DKGsShB&T$46H7+U=8TfVkpYpbg&-buVg zP`%_4XF|lGNodCOo0e>Xojv>SBK;>f(B&8gMuTpcc9x#q3%r0yw{~%|u9?(xaod+N zGzrfaY_~ENRXofZ4D++{8Kix89!8~}A2}&k1=_7R|H5pA6nH7!os_L}V(p%*546qQ zZ^&|%ZM%dtKY`5?F+Z|Lb?tvVvdW86>WVJoexOrcx_{rdxpy$phjh9n^89z|Jp}L2 zYYb=eAxvHC23(@XOj2zVZ`rr|^`;4oNPfBPb%jSk*|zz1zbZEoZ?zDRt?9|nehmF@ zw!KaB*fP-vl&G2EyFsVH?`igSZu5Ww6P9$cBMJBT6(O(PVnjK8PkSd?kB4p&g2(=F z-tkG5d}*^7dmj*l25d#H#NILar3LnlU;+enUU8W0xnRdPO7C|cbnUUF+DesqoGugC zor$K6Y;XiftJ5pya{G)sOZKZKcp_mZW~d$ zJ$vtOpL_PXcwoPesj-zY0)a5~^WAj_fj|KZZHWQQx%lL`0`4ph>^)3?`}^h=y&LSc z(R=1fuj&Rm^?E&e&lX=;V06+qI1Yg@4_|1=hxo!12*mOszg;^HC*_X!{P;=Na||I| zmB-bj_IE!=Zn?L7iPmPkrhjfU+$^Dnm2``~tU5zB7OyNW@cbB%4~;cUX@&=xKy$ZtX_`UBEi3xuhkRC8 zH`UEplUPI6Yszl!VzqhEqOVr;1pBp#%b-3>d>{%Z$*cz z0$BH4X9JSTr+Zs=yU{N=em&Syf~UW6J#fnkn%5|9M4id{^hD`6y-uL9ZW!G^X*FfW zA7mK-!l6xC21ileD?T>Ds%^-kr$wkd6bT;ZT$Ara28*My>RBo^z6w8;K~bSamkT{S zWzLk#8%vy1jj2N`u^EEX9URKI_qShoQc8x(2(4nWECm6LBJ!VFt?HzCA)(%ny-ldW z&Mo*^#q2eE1(M3N6GqX3yUb}lg>~ui^2KheHXYl1&J{?-Lf^s8{l=a)_;&kLop~W`$oUu~WyIj=T6ce! zv#Otdg78#&({uHp!eVN|sF(mH#&D{ zkp21WS3HNTP`B2#?8vrV_uMtSyim91wI?InJp2{!pcU<|2zXLD}LiY?eGdiomrOxd;5qPH1DGnCohoZ5S{#%S`IlA-%{^k^lPR?uu*rx zq;)B8P1kw7UBDkXa=%5H{W-$4=rFLwPjC+nVXgmj0XO{FzZG;Xqt0}DyUof2{jbub zmky-bg2S!kePNbC9Ttw)Q++4pw9(3&KMhy^&0@;jj|HnIuOhPvoy>-4S%E<&i!_zR zJW(ndNDW-V$3H;xyZeGD2lvctizRD9jYoVoc;v7NGU^GIwz{I)44AIXyP%+#vI#~i zyd>HgnOPU2L7(%FvrS#HPe#)=;&cfHM>qcW)#tA?psQc#8$QRcZ0fkmR>kH%T8)(V zxrh0nAW3Xp)*?QqFU8gfz)EJeuK>NXrc_1R`Y+4U+jZIx`Z5>sgS<@QlV?+nkH=q& zE>4KGSBG%(T4Lh%q5Ug^MD7-%4GeIrW!J6YdYBemQ0L|E7A^%o9s?jJBNQ%rkn z45&6Rn?so}E9R7!b@Xzqw+cyfGF>S)Dnh6(3`)ySN687fmwULCw~J}=#Odh^t!1+J zzNG@U^k?0W@=yj*#_itWaBZ;@iRu$(-jVL7;uM^Lv!f$h3`HxrElc)Cr zQBJ~KU6xbS4hoaXa|xdqto7>Wfe)B2^V-h7HWgb1O!QkmjYBg>lWQbo=Oi@;*PIet zt=Es0R=!fz<2+}y4?4qL>*wb_y5W~s6F{5H*%<&t>HFsk;=2e#=>s!%@_u~J_L=)5 zb;B3^C;HMQI}A%7oPQ>xeVDxXcduOv^aitOIFylP);jne2;oQAzpHd7<+Hy7^bO9D literal 8836 zcmeHscTiLRwr@b1L^=cnQ3%pQCm%zpq;3(o2eIL8m`qWXy9zzrqHGglxlY zefKlR@$SEUrG_fiV4;jKTT_md#Stu&`ob-Cfqio%B=h&jh-PQR6p9M(^uj{&WvDB*_%?bly+lHgo2$YD; z)H9UI7D`*u@XQ#bol)#qkA+>_8-FhNA*=&-RwHYR&eH5%ova+(rC7|B`BuA;|9x3pnXn}SgWnHVqk>E|fkQ~dj9?50!H3q1XHot;de z;zIH*N60ScZ_gvF4FWL>l_J1zS7**ARa6%4pG_JH}%wjBUIOI_I>L2EyhLP+FdzD@kJse5d2JV^{dRl~mo;OKR-Lba8m)v_low~C5w+BLP zo!D)Euk4sFN>|+nk7%g;M)B@`AAWKXtt)*^JI9sV#9PqhV@Bcp&B!CcMcelG-BVb$ zA;r+`ohQM+-;FXYrLlY|c7j2*gaC=FB&E!Ersn| zq3-6w4PgsYXxI;4Aj@VdBL<^DBPP8t*(~Kb$-cCB_h4$>$}z8AR{w*maaVMBb5co8 z$_kw&YvbLt;GCLv)=B8zO=8Y9K$_A$W)`wHIWIfRS2znxfEVz+xbO4d@Nxa9}H7jOMC?6LcI_{~26t7OK zbUS>A5(w*>P-vk~E@u?huAN#iPFu38tm#z(IU&0oF|Y?u*Mdq$U^fCWhRBDlnNb_o z66g~D(Rp|;@`G&PG6hhiHf{Nu6J4Ya>h33`Ub=S~PqWN=9nLwgH3#W5MjBGK|He%D zexRQv=1t9&>t~ax<{u}+v&iZFnLhrcz16S`lvtv%51xKux4Icn3R3E-d+7k?xM7Vi zRk0(~9?p>tIt8J*T>3M8ac zdK{Z+ZET0u>8c+)Id-`pn2U7sOEidhxrc6c?>gS|-|xFTqj$sD&=ne;i7IHpaB(Vo z+zQL>TFmI~s{)34%jM7Lfb?TC`qfOiHKNJZ#T91NM&qZ=aNzubrgBkVy=y#+`=p?x z;ksaimc0KJ{ko$3t2WaaMrOFk^?{-a2zh9u58 zQ-9B0(dw_S;4}}TELsKxuqEF!QAaOP3l_)DHUbX$zZ@-<<5h!%VhZioBo&Q7Ph}Br z2fTLc7lAs1A7^oWZ$ms^NZRMD3~hg(7X@~ZDL$I`)XPY&p(b7hU=8|d_-KFYG0P7W9wsTd(IK;V(74FAFR zOc095;kNNSgqg?(TRmB$3eBC3mei4YUS*{G`%c_&fYRe2C1WRq8{sV(za1Ry3Y|=d z9`o|u4ef!MJhtboc({sRjk!BK{YEAv-a6>+En%kSUZ2Vjw;6Rl)YOzINi)vU=J7S& z7_OfK8ZB*Zu>>$7!8^G>-cm~7YEH4(6L-TPQica^(dAp*&{NnbSr)iSBCvG{csC<6 zGZHB@4}|>0{VqGY3VISLFfHa*_SH2v(LafWAEK6l@v^c?c+`NTNT$7(ogiDuFKHlt zA>Y~_QKb=WUD3D-9BpUSJ{U0{Wuz`R{0z+b72Se)*qgx{8n2A+?KFqq&T*Kyn^&LR z0SnPJdOj6f^5A9H2kB?Vg2$i8K{I-ouJDB*B1q6)oA%xkYTnKhU=l!By5CfBiigMZ z>w9<-1RvhJ3fJ)t$<%D95gjgCVr`Up>uBSrvGFSytuMJw2(oWch`<;wKu*9m@N32g z=wH@1nX)DVzmI%HQJ0bexA-XF(@+##-+EM}P zKv=YT8rP?^dtHVR1wO&cy;kH2zHevR>Yk z!ik5lH3QPC{L8yhKJ*If!4uR1c*dBeu(3%%B_HH0yq>|2~m%{Y7V=+-%4rIb-6V^_LV3Q zGJmvV>~ScVw#wJO7&mY|HbLj^kKjpXoPs(~(k3cucrdkCRI&gZ2quJAi_4cJU8U7GPhBJ=56EysN*%Q}j^UiX$H~n``*E@i zECa$PeC?OB8ihEu=mt-J>>Wx8;Z>s@?V7B)R8t43wttwWhJfN$BRU_?~bIA>XMpme#uk|I=4x`RLj1;g;9JMp!_tN09K$yiwZt z2i&DTWPCo^qc3B_kqgsTlbGz&S%O0O1wCay8DBMKHOSVr7}MMI`OQ31)1&xmP~re@ znZvrWF^Xu<36QZGY;P>mljdRAoNn9RawQ=p;1SBFw)~Gb_YHpnFFp-psXaS5<9e#< z@9o37K6-pD2pMyMi%QK%oH16LC-0X^Q5l?p$u>IR_Si|0*&qNFt)uD9GC#qaYi`Y( zH=}i3E9vhZOU6^zp|6hweBedR_oxlX-AvmAat)bZz^DcPE&k~eh-ATx1gHg>QSS_y z?+8$|8xKu{1?SP8zF(%vp-q>E&hp0L>K%Y zyYY_{|7C~q|D~V*NQ7Ks&(0Ug|3g98KsHw&6!T~>-_hho{rmF&e+`H@LIh_bnEchR zzn0HARQ=UJBL1AOCn6O5rJz>)FN#0de!k-VHr2lq?{8WD=KLq*zc2q%HN-J6)5o{} z*=_#!JNgec@b4{%|EBvgVncV7qdgJ87UjMs8mZIP_TemA{|1fi{nZ$z$*kgQ4W&On zalY{Id5nTb{yC`rCL>Yd|GMf-8+hyCn=8OddSF;LOn6k{ub|Sp{?vbVtfr9%dpcF5a$MhxFT-2kEa6$QS8PlJmde9i&EsubN&|g zg3j}7*J?1$uKuKdM%ROV=nvLX`SVa8l!Z@$o*2ZATQ~!7ZayFX{m$rBd6V;zt^Owa zM~YKni)H{E@cn{p){J(0S}syS+N4Bcu4dn+2K<_C#p4Qfu7F50T?n1G({~5e6-c)( z96*68%8U#O?l-HCr~s|^5zTNazykb$P)Yy80Z2o9+702rgC+MWMghW60HRUM9?|Qs z)Yc7R-%_Im07)?PfUJmy`_^iabvF_T-mnuu=*1CM(oDUz^ALk-?Q`E^7*vAwqb{|H zf$}`|#BBoa1Nz^(ss%@*0QZxkG>z=I+oIlAY8u-UWv-c;B!tXAp(@xc#{ev5Cl4X3 z&z@`tS2mO;)peux&2q#FV;y2#YkZlS7s=6r0k5&fQn9xgUnG7^Y3?#a@`0EBD7-~D_+Ap zlK}>J&GnKm%Oq?Cq|~M{J^Z$(0ob%!t-s$_uirxd;Is0e5J-zQmWs7)z;G_~dr^_= zM8Mm3EQub|k#Ld|<~Ir>8L^rzo@%*((3n-Yhee{@bfhZD2^*o_7My&_Q*{AEs+aX7mhy|N1y24J$?6zBmcDr z2ZMBY!5y1SSM^-Zo$Sl3_>}H3o9aLA_mUbNm@YSJDlkaw6-2o6%#_^Xv7^|u z5)uQ?JdYoGnWm}MPNVX0t&&0Ff`9F^oqZS4j9(lyTPMTSM@Sxk|4cLDHCyt}6;oZb zrtY2hHnOC||8o9?-$9Z9#}9LVK!Jo3n+*NM@MICUC^A3;eYh1B;3o|5h#QaqBtH(R;m3Jp^U8fgHM{YRZc_GTv-4*V;e~F zY637Kg+^VjaOv|#(k;OZCd2UC5AYUMZYeev4%!;Z3OuHt*c6 zfPW-7EURES4NpP zycsU`cSqD+O-~iF)X^llnv0J=5~&M14#;)n9G5fDFNc=c$rvV(2FEXocconQMzB{o zNZBD|_Z~dbLT5#iDrzHF$9nAg)+qlZ$%NfmWNtHCrYFHCa<-+3%Wq={t8Ys|_C zgUFbFAl~7n-_JRD_MvwA*roIm#?5btl`iHZp(Nz~sTTXyDxVtTeb{Rw7b*|j?h}S@ z0GV?E)1TK;=F@#eW6CQs;E+s^neMOX%LK9m3a6B{8elQ@06m zJ_cIPI}D%8jK6w1!go*2iV;87hs9g~w^gsxdH#Bsk7u3BccfGcPnK8>r}BD4?Mn>h zB_yc8MVhHe#jVh{K@o1#%Ht3s)+P+^vgIb?bD$X!ylT82XMqA9Q zUE}!jj1`bKwkf)jJ9n0TP$Bv|=fzpkO#E0>WB?rlk%4?I4!S2IiR@fBf>m!X#GX@F zHDq;3J!XgcoS_V=H<>Cd)reYIj8}Iglt^EoEGNQCh7cnnQ`!+8fcn7{kai*;4q#R6 zVuOxsxj`-QC<{t@qVse+ti%3*NNXFm2ng8DGH=M4$c5i5ZwMCpB@!7J?E(BIe4cv( z>(9n*(mG5eMZ*%53+2);6QUPS*mBjTJF`QP(ju?ul+$x>2J7d&xJN?HiVrIjaynpB zmq3q%i1{A9hj(Rsgz1wL#}Nkt21voXiiqzQT{t^J$&Ath^mfUni6L?(RIkYOs$0)r z0Z9G^M?ZYEe0^gcOxTr_GAp&InR-nZ#J|_ijI4VTm*ZZ>`Y`s}u5A`ft&?D84w;Ef zDw~UlQlH5Up}biA09O?)ZFRi*;q&)77x3f@MqottlMDe(iC1X`sOurXiyW@@3`SlT zS9y197pvGZ?*_AFz`Zs z!V1|TrJ0%%w-4tky3!)Ax!^R_z;mGQbJ~NEAA%F_zb^3^kA$-@#HmH0Iv8=fH{DJj z<#jPDzgaqPYMgTm*pp2z*I(dbbfxlIXm1Bscp{eC^=_L-9o#jT1bf77>a6Pw{T> z0gHuZSVl{ighjmQpw_U;!(uUwt;@@e!H34&_pCE~EmJF8=y(Q~<&5rd-fb&wePDz@ zn|j@@5{VvE*PL6)7(s`fhTZyBi|^^0-L|Zu`}o$ucQ|VKUh4iY825mJJlKA zZt*!~y?6M6Guq%4eDU}vV-lZ-$tu!XA#p~k)*3t`j0csMe6<>a=FvZ_P=UL4#woIZ z1(#qhySB6raY9jH2wmJ#Y#}mnHU7yY^T} zCU6-sO+0$yCs48{eL3EB`YB9&T6iNJhg_Chnp9lp!f^Qe$2#n$t=X`}zeES*jCo#< z{o)+7r!iOyt{y*gJ7$3Pw+QxQ_j6vIz86p#kfJqb`i3zn+8WAkx9Bt=!Jhysae<(l@MuN?{NXu7X$)W{KUso2*#;tgB2uaN*w7g@y{ zuLCT-1^jnrY37#EjP=!D=lCm_5;H^m7e2rYN}FCQfU7t03ZG64b!?JU{eIjS#uZ?)I4hR=eL8ui0vBFh@c#Dz>1}ySWd0G(uPCf>F?U<_KlX--+=j|vv6+Y%!6;GbIo#p?*R9?w$yNWpRKj> z*zVbiJhiY#qtR&Z-n?_pusC*S&~Ys-LvX$i)<+|&BcB87zbmH~qpp8r59IRIVCHV9blcg*xSHMjtTL)aa z8fBH?p7Gm*{Wg%0%D+6!qMXkyUw?O?C#@hRC0U*>i6?@if=QB>a5teMA-@-y)zq|f z8YDb(C!)@?gUN9hVV-QdjY%bxj>P@AMP9#3ow%)w-~VWK6T~YOht`I~Ava|5PTW{T zVQe!-a{JC=QNG}aYTI2>f+X0PSSh>cKpo$Ydr*IB-cGZBsZb1a3Eq+`hh&dAMx5b3 z!;R>&@8yT3eU=dQB`QWvY`*fdrz)~7G~6>9PZot`5~*_5v7%18j_A8Ke78*F*lcR$MKZB0QH=TV!$6=3nL7SJcMX zXVT#4CsXXYzN(en_=so(D~>Fe3lX>cR=S++IPjhCgP}0Sx&+oSEJZ@$+^dFuL{?2i zkqc(X&d|{s0qkh#lxehardS)49Sp{$J3zA08@0XScpIp+w!t)T1RRNFt#u&)0P_+@ z5iJOtX4g4232f{1rQU7K!3uuycvcNPH2f*Q3FWmi5GhDJ%&7MOSFi?|#c7HQzZ z-wCX>auk0(wj{shL;o{4ma=^k(1rh2FH-G&D{J6SAfwPJx=6RJoE!vxA%uv*Yc2Ar9xoMQ`!-! zREMiHO1d@FxA!>lc3E88K6}i^Mf-ug>4u^h_2i`@7d$)o6_W>h6rpZzQXKy0B9OBZ z^J1M2qwmcX->(6gM|*-U>kgW9bMKPCh7Nn$Nq8)mK5Cq?FJ{WS%n~A%gggGV!EmfATl*UfIi>f&uSfN?Tc00~;0%_w7&E?kBmkiLW{KX+LQ%X#ZilfL2I zWhVQbo8|%GebDOvkizM+aG>2APqI@B3vsogtAdzeXGF-*oF^z z!GFSu`qwIM%*B~{bYhTCJuzg!T!d~;&2az0_PRR|kfMiIT7?0rt;5Te)wPmuG&lVL zatFaXz--sh#iFJ@$DvDCFbeBXMe+#*4}x_ob<0&pn|xzyvHI*}69#H9f`VrC}-=w%UjM&``)8 z3BwkQ+WJ`v2~5P+>oM9JyC(wxELdZfi%GFS_oi)`s8rF4N~-Y6(S0K?{6WmCZ^gm) z3DI>BuH(2cR*Wo~`U*nGk5_`21k=E>8h$xDf9qPx>pb}Z9`i&&LF!oF>m=hPTuf8R z30S(-99PCL&>mu>cK;+ik$SnJ&MdETSs-=IyM5JT@!tP~#;5%Oz3{+2+Z!E71*#E$ z7sF|JmD-Ve-eOVIVlO}rs@{`ASjz&@5c58^eFwne>505-HiC;qdjLD;S`?VJgj;!^ zZfEJwaR>U>p~6uhha%jP4?knStMCV8;Eb8qTs()96nPt)ey<-zHy_?K0{Ie~!RW|Hry9_I$^$q))1Ly>a!I`DJ)XNe$Oo76D8piB}*2C^VT@0nAN#} zVe+K6Mgvu+oD;~{L*>Mzsiw=G&RZKaDTHvoV5Wb$`Rv0{gi$@w0?}=*PdCF$ZxbsPW5B Ut3fZX1z6Q*8K6_db4J&c{6w2v(CQX-DjV>zjMBQ&r2PxC$s=|02LJ# zt*VMLjEd?4@~qKZpdc&P>QI#Kil>UP4;2*)!&y7m!S_?10;=n1=tECWPoF$_auo>N z+uJ*KR-?ctq_F}zre76rrbYNzSXj)>&Ew+Yy1TpG+}s))8%s(`czAduB_+vZ^7Qm{ zNJvOVM#fVb;DVKsAg7)v71d3=sVG7lx$CvsA zSql#PglU?FF$P{_^t??+ne!jKBIMPbTphapP@ww77S(4Ygk9;d!DntM4%tSgKb}g! zp{4g3WM*!xW$)(*HJZQeZ$!j9nM@^^Z#RbCU%^#1C_>O(;w<(yF~m&6NH^XR{BJaA zLy_FDPJfbN2FY{0=40SnQTp%(N5avh=jwEGi@VTEwKzhM`THAFzJlA_f+NPE2+^>5 zx~57-qLDDUz~f1mu6&K>L-GY-*BzEMF;lqnVH@7-F$gJ`BxLjw`3e%r$F~t(s-+3ZpUjtK-w zFoW>CNDs813zCu7{2dKn3L8?y-{VzM)sGBOZ{W1Kqvj=u^2VxK^~*Fm7!)79mU%h7 zI0J`opvol-%K6hs!Yh$U$g-wApW9OoQv9K(?&rc99DeDhAdZLK!8t*0N!JQpBGGwf zzo)sfim!U4XBb2whN}5iuETvzw5nDUped*_5t5rh?$J9$UtTVsQ7$Pwx4W-o zHVwS)0Od%;9egiAzABbbx618YfbK6i>Vj5f;<(B8)>N<7anu=Bkn+K}+1lfP1%Zs% z-)~t;K2OzKxp9deCfc}+-5g2B1z(W{tyf#JuG@aS+=H+C4Hc_SR`c`P#T9z2xB%mN zoG=8A+{*9FPHp!Qx%(Z7upjO-e?BUqfsRPs=Dm_VAhMU)6w6u@$?YxhZgUQ9`bEm! z^fHTiQT#?hm~}4X$V}(eBZ38Jbu7PmGeqdISbeeCt0g0Xtg+JA#J=#O_PKsGlMAJ_ z<0D$H2ztO^76<)MuyAc~o^`wf(?wd%H!^-P_oGT{H7fF_YkC)nu>GbXmIrQcaodg3 znjtvd2CccueyuL$pdF%2f1bD7{a->rqZ=8r5vy)g)sCG$Z546>1>||wQeRQjV`B64 z&x6vT)f)t;J(EQO^^0@9i=n+$EQpekx$PSMY?zBE6ujHk8go)$;W0?MyZlbmb*^4c z-!U_XfBaK8#|>K1&w_GT&n0$VpHj8GhCRf_NH{Epr7I}!+u7B%VMm6Moe(@bGGN>?#Wm+ERyL-FmUi60#?|)3D zY^UikTDNFO#UE35F^`$tJ|;yEnK+5qw2VpVaOv3))9Zw@eq5PY&CuaciqA#d|J0|i}XPD;_g*3j;`cyJur|=?D6=Tes3>voQTDROtiwLzZ#f3 zx){$l4{#e;U&ZWPHJxnIx_j(Av$cEEsd5{koaAP91$g~U0vOUqN0QN$u`Elu;QdDF zBc!}PmM8{r3vX`?F|RN0o0JsV*axo74+5hm3N^AFuQy3s9DHeMabpiIL3#;CB_%qM z>DYhmL0V=udI3k**V7d7%u?}F)dZhvVw7oo}Id1qyHMo7S zwe-;jM|;@mD`Yz~)!Y3~X&37HSJkHGIn}S_hq=w8)!J&`iXYK8C6ZH+ZoW5~gQS^Q zPJDy|X{U0Wai8A|EnQbyoRyR!4B_RpFpWcES^cAQ7p~d08MO39v6a|W7*?(6-pR;$ z4=jS{hTLTRJ#A?W$rizgHnOaJ=|}6@$vGoqDKA=E#pCO+eyg(I=SPjkCY#|pmCfa-^eRl>LyE~O)dD8m=~pm1EC%!#XV@@_D};N_ukVMmyDo=hkxFG;@G zhx|l{F;UcztF%cph&JG`gSBq;K#y?=DQ3|KW5JC*(?y$;GO;?%w8L)zhKJLy#8Vg0 z9!{y*C`-BJy2K8R;nA;g?Xn987xTW9YFQlwp5i(hoOrWWlvj1S`{QlGn_eQAmpmPD z>$R>HXvokp;hTkr(&a7-A#Epu{}leD{iFEc9P-m`v6SC&EbX3dRtL<9FN@eeWeXCl zO_@yVA7plV2X<5wwFgPPyyPFv#9S^&`j zlb8-Q_lEPRTg#l>D~}w^(F1{5q18p#53D{X{i=P_Y5cXwNY+&H_SbMs>@L=f5#cfUdVt zIflIx)i+{xzqMe?BjJ)Opz-;6EFR{Uzg^*H;UL%0s~vQriCqqlvSuft*ZK?}3K|6u zHI6p0E!6a|thdal2QKcWO=i1|xV*IKD$W|2I=o`a^j2|6wzfm&bOOa?D75IEbMi%Y z4l)zF4*w4P2aiz{ca9fjRI||W85=HY;O2vt&ej&W=cm7^QKy8<&yjE%cntEdcf`N< z{}27|WP%1BUi)Td~i*FRn%qeaaH>B zMI{|Is+*A7uQ?iE5E7&Yf(Zb?$pRQ1ilM8LOEL0ZD^d()E+oZxsR)2_AsLaNSVaIY z;Q!p(jQhs?P4o^~_y4!h-=~{1o|Mlt#&{+!wZF*l zFXa7`;J=)FH&a^|4^9RCqL#B-_1{6#f9Cjqto|_*g7B{tmpPHyG933j0nApTurE3aeGyumEL^$0762^!0xo#6b;`|7?C2VRp?IvB*gM%ERvPmd! zL053Hq>!*Ppx_(e0upAARFZ;=g3AQw z7*LQ^E2$z9sz_l$YHVd6Sv#*I`yH0`XAr#&xd{@&AhqL(R@Qmes5+L93)*W> zE>AgKlSsXT?C(ykb6YJU?H05|uM;Tnnm&;goV<6B$VwRJwI3+!oLQS%_A7%hN6o41 ztgkb2N*GO@rlg)bcm83?RonEnpd5}xTTTn*Ii)+>p@0p#qsw+mfM?o*$}1&7KrKvK zGe~*+gX6}vqaVN;=Sv4X{EYZ80<4Eto%Y~>v*Rkn054M4txVo|W+}D5$qAr^7^v*k z`g7~m48+uO+*Hmzw^%4{xxdw=Y@5O0YMp)1tpH-*j2rqsDOOu|iZ9)WUY}D)25qW$ zm|#qTo&|;|)`fb~L#cl~7rc-CBCT6hJ@oMMIf&6)jo!p01{j^WDYIc4E|KoMr|8D} zm@mJwLd2{W5EJGisF_>JUgui!Zc@%v)UaZUH37pony0i8b0=qsq%auI*nh}~a_HD8 z=lwQlFv&s5rf4OJuP8^Z8|Bs49a~EYb9Yvsl-jUG2m}&#W%#5LN62(}y%7VM822yJ z)8nnN-+m&wt=+x86`Biu#77E9&6<^8XYd+m(Zui2L0v`WTPTxJXnYvex##R>UUVz< zzJe6#n3A&g$RhEF(h*3HwPg^^!Ey2LJyU;*F17C0W&Bjrc0Y@3A6RQNs3}rF6|8_JBQ^ zf76bXDhXbPv1XBXeD1FON^f!LxCRo~B+-xGwQc7@M&9g7F_#PfjuZ3=V^c3B7}AqFqK`*6rAT^=JI_V#nWWhM%V=T2H}$r*!wQCnoB%dA z^s9d$A3*^jx`A1{rug8`AbUF!I!MyKT$S;r79EcW<~X0X|xsT1=rtTe1L^)dG-(Swf&gU7?&@!)UUmk0LLM{(`$Q&wEG5d$#C z{(Dly4Lx|dyzEHHJ!(MKG`FVVu>RD8OEnnrYw^SC@L&MwpnB!QRkt;A7ud{jI1SK){nM@()RU5br{l^8xigm%zPv9+j&XZw=WC%Okw>L02f-+t6otFf~0tzngZHMgIW zy4kK|nuo)s+V*nB>zxaWmsa;i^(19--j`Sr*k*%qp?2(g964CaeY|7ieXZM=4>MuU zX&oXw45M~0KeVu2pW8>-6;0)foj*Xi=iD`t&%!3E;xk7_apk#`;k^8-)e6mr(_jgo5=)gVdmfg{7WZ~cYJ$tA4~+@e zVm=xFChTV>uU(#r^NA%#&^$`Cx~x3=)u7mp@^vL9N|B&|xAcm-z#H9EJ?jkHA!43L zkfbrqBN=1@Kk(UNVK2SntZHLTg#>k|;@?Emq;{&7h@p9xOjo%LkNstobh^6DVQ`{D z3J*77kf>x(hN%D$g_{d@&s6}bx#OS;h4&^DNOi6T2D#MtQbnp3^BRO|btu@R{)@*6 z$X!8Ll?%*+>`|LzZIg$#?ebC{Fq_6;vq)BzvlrUxb0X2~`#W3|6agznoPR?Jz@nP_ zT_%JQ*^ X3Emm=}rB2?f|(Ovmz5{J`L>$57~@j}~RN6-}!wF8$Nuvsh|+#r~+1 zVv4ip9=iH7(31E0BWJp%j1xOQ2umO0W0nZ|IT45kdE+pzEu%o*;Ma<;{;9`A+j42ZRyc)P)V4EfKSE3@M>^>5=2AgiFlr6;@ zm;)-MPRtgx+77k)#>R;*YSv#3|^1FUK0ItkQ;HrsC~G%m1}3}RKI^nVsm*| z44&gugRzlDKuBi0JtXR?-UxbRKnr%wR%uDzCT)Caipd<$OJOQWF6yoH zM?LfFXrB)2LjAwFQ1^7hs#JSEgGq2-3l1P{!wx4 zmtDOyMg{c=3d~xQYl~HKje75>KB(eGmG9e=5V_h>?3Jeuj!H`?Wof~2 z_Bz00D4;U@y4+iL`S4^HHm-vu{}R-MU*%S%C#l&`q{0Bzy3C_AJ@~*6FIuh=E;J;{ zQewIbzM5!KgdXX9km|Ws_&7ihr6|-ddVP+)(7Mw^IqUkH!hu_@UX3jpuwuI-pO0pO zv=?rlXsQFCu6MW*BHV&eC((9HDM$Vq>U!`J)w!q8A4f`8%Hx1scQN9bqD$ZXnvE;x zn9*zuUPK7PmRPc)2*N7OeGG6Ux*8Cj0doI2D~b=B8y;9T)EWvPy6gapur4^G4-x+G zV>_7iH{}$f-V#=m8596+>74FHy)(G`0uHC9o8Vejv0=#pbGCucI_6qneyi? zI7!-pH5}F|XN1R7yU8rlrGx9K^X6e(uSa%-jq6IG9ToV1kq;{40f(gMcT-`WmWN7A zUE_2{;>sCgSoI1e>5ce2YhS(+U6bI$t!p(KYG4kYTdBt?hH=Rw^2RAso=jj3QSz^& z`#(6XJJ*y*We&v6SF+{9F=ovs``p8B?63fDJAwJzPYe1!JP>E8BCH8dSoAIMZ=jp9 zQ#s+ZF4kRP_4#~AhyAP2EG7o(vI|91A>YTG!v{}9x<4($uTPBLf(7`+%@8Ltqf*k1 zIeLa^J;XT6ylp}P2rU*5W2|t55&YSlYQi`(l-Q&xSSS3|56| KDOV^yeg1C`{4hZP diff --git a/vignettes/Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png b/vignettes/Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png index 6e23ecb46477c1cf1a281daf43ba57325d0148da..3ed93ef0cfa69be229c502b242224ad5ceed68ac 100644 GIT binary patch literal 4738 zcmeHLeN@ut9(S9~wjvn;c8y(ns=ztv`@h)Ia4z*eAXDYx}P zspwrTSw}=nQvqKVl-BBENs=bWRZ3F?Bt;ZNF5d0z+}-=f&h9<;pL;sz^Spk)&-Zzr z@9+D3&iDL^WA{cbw_RgvVPUa+*UpH278dU!mx}d!=9%KwV=8mw7#n?HySe>}|NXW8 zhmR*mm2(D@$u!`;CCWT&leIGeYheKbmdZOnAQ)-p70$aNwjIc=R7y*826r?@d>)Z3NpBn4c}j_RKuux`>7C@yRN1FYeB? z8;BAVmYowkD1yqkob!ue`7H=7yM8xxfK0i=<1T7nnRO$15~8ud1nub93Z;LU-;?mI zNN(@as(+y`GeSYSYm%mEcAwG?KrOgGjOFJRWfmISLjaUG7cN?U_|n=m_|aG_H%LS zR`~1D8hQ~uE_nm<91zL_Hp6sP5OpW%aShxi{q|4v#zAlz_l0Ja^tl*RVZM-lyvRXJ zJK74)vSy0W@?}Z0A*z!KD-Z*h89!L+9_sJxK8%E!;6-Irxs*`yv@+SjF8nlB)# z-HX3`wp&FBABL@bL@@}JW2snva6R4?76@-O^_N5a3}HP1w*&ADTtWu&D?WU z2WiHmAui5h|7$Qns~alNoJ@?wl_MtF+4`JJQeJr+){i-y`a?cwuu|i>rGABr7#GY? zrg%+rIc?ZjQdocfGdkPLyLmZUozYdVgA6TKDE1zC90G2he$`|5fr5k=BzoyoDy;FS zvv>vywyw?RqT>e}#}V$|R-k%kd&Pj1&@ZGR`~sPxK&EEHkyhQTyaFigIYGc(h1BxK zW^1R-+RCc*I6j@NLNNVG*uuhiDhxm;r|+%ko@5<0xM2!|5EYA=isxfy-1MNEoP-bW(sZ)dnq)^q=kIFPq zOaN&{TBO~Nv{vj!2>Y_RkfdPO2^Ad7HfX!Bhr*I=4{KECaXn`?dGy1kw&u2khS9ISWuw2Q3CH^+w3Ecv}yb>O?eI0wJx z8}^I@R{AM2PetGHR{gDKehGrJ0)45h(>2laZ3Ml2EdMnxjIbp%(F+7o<SrVz*!M?d1G z^*)l>eMne>gR}2p>-3OKeExkAAbn86&e9x3hBU78ITY$7rZcVWTw*$;SzFBVW$Gi} zSpwf#lH$%fnr-}y5_TNo3D3`J;~dH(D%2n}(4YJ2Uah^4mD$?Zf!6t4`Wv3|(Kh4~ zG$XQ8-ae8p!_T9auHPH$$rN}`2ldVhXRu}xq$c&Q^N~z1sBKNP=5v5dv?m|kHEZ96 zsedu?v!VY*?O|{C$;CnnIToWEOJ@A1T;o}>E|Neh@g z4cmi}aI~w+@b_<+v+!9pk3%571SMaV4*TZH>Fm*v9#BSWAmau~EzVF}q}|ZW?m@~+ zVJ+bMPg!_HCX$hcl$*xR7<8MrnqsYZlHz#5MDm4EUAxu|A-U^|4|f%(tq~Wq%OY2b zbIPm=E+@jKZdSu*1%|po+IY;^bP`C;b|E&*uv&1*2q~A4J2U!Yb?f=SqPEwF#qrc3``S*8qH(^i`-EBQ z!F25AzPP6AbP}rD@#oKcBJLBOFZGU#IM}B2CaQ$$@BKUlD zL)9qj*t*G7=Co!GHH?)w?RjZrO%?1M>drfDw)sHUAdGxP*F|zRmG2~s84FShl9!IF z8Tah;ovI{GY;?FX5Ch-94=~(fL?FLHXfIhmnq*Wt0@sYs_S?4kE?EBan>z>;FW%er z#V0iKe#1QDz)ARR#G?;a2{#Nsv(Jh;2pH!hcO)1&J~oWtO2K^R#8DU>F_s0rps-R` z?(36va~DPEhjt2U^G@%J_P<#ZGyaUA|LGkW{6Tsp&Q-w#ao!Yfq9Ub!WbM~V zPCseiP{vb}z>phtOJ=(XwD>({Mcj`dbt8LdjmSZ;bwlRIic7-!@5ng8!l7@Q=d{(% z)0L0Yj4!3G3B@wo_ZHn30*uD8Q|Cl7Cog)hzRLwPCmx>!UuI{{`>MZwNx2VGw-BiN zOBOucO_;y)mp82NviHJfV zNbgOgSLrRV!S~zUKX!KJ`*vq`zTMeOp1J4#?z#7rd+s^UbHlYXly8vVCI_+6(X`iQ4>#W$h=gHeE|S^s*C4RC+ChV5!BF9(^EV@Kc}FeU}0gYt*uQR z=^(=ApKuP?y!FGAuC;~T-Cb{QZyXM{yu2(ZD5$QXfkYx@A3d_NvWkj|N=Zo>A0H11 z2~kf7w!oykt}AgF|9AiZfSI2t$ms=)t!0G!z*;U&-4*>5Ca9*-Cs~HHZfVV z^PJv?G|!zW7nNO}l=#Z-pM3Q`8d(r_!i%Mqt}8cGQR0T%BdcOE<`#QQHXBOstP+&* zuMoV^&A!`pY!r#moH7^glNS##T$QOOK3ey>3Ap2;_Buhwd`~*~;%F11=k!e{51V?l zZ89Cqc;wrh4GtXYi>u!3>L#(wNJ~0t2qgHl*t&w>?yYZo;~npwI*sQFH7?9Y_SOjb z$7IR6fTt3lh>P~DapnVKA3^?!^G8cT zWGi4->s!K|Bh_J%*A)<#g5JVyRE=xjX2hVn2X1O`aK=^&S#1|VEJnc zK0;-x)dsSGeRXCwvZ#&+PswYNjIZ?=m_uI({23+jlah?Zu_l=meeMkvdBcV)?L3h{si97Er{V3Wg3rf*bf_O1!ax(d#G;eqgUAYc^n7m}g2p0QH2L`w zKr6Ow=`sBDP%SD*aZ-OKTW6-YKRLlj%WGaab_0W~NJ$Z>?t|N%oFJh5FZ|$gv&+6AH2xU-1#7 z7_*!KA=GaiyYX6lEko&9rgL?S*I##5p;LK{8O!6 zs>#eVe~0tDcI%Q;51Jj}Tl;kR2oc=@Y;Vf1!>nH~xF@uOW#lT|CV3_}!oH2zjhSTn zqs;fF5YS|*KR^bKUgAJ_aE$(dJZ{m@Pba72Yf|`FnW&m-PLG#~>ljQ@8u}S)Z!b8^ z8vNLQ$7PK>y-D~hRehe}>uuEAX>mpN3JY$wN+DF`SB`|4HN@a@TUGHWJA(mgfVtD_ zmbaC4Fu6}qlUFt0o%Y1+NdpluXlR>OgvpfCCFB>EkCSnyB|f)uwXs7MSpdh3Vq2Qx z)`CX)TXDXGqG5bT&$py@-&`k$;IG)(0(ydg^ZiyC^eT?!Yoh6u;vspV%~HJ!D^`S8 zJdGJ9B`S>z-WR>UpWh^(5zZgn=GtZNbHlMLGv?lqH1KNpdo;Kp947 zx)8>wZe#)tahP?|KJmBbU-Oh1+nQX%N(bU!U%EV4VK`X@uEy{=THEXUTO^C5eiYkq zpX7X?r=F&CQWa&qIW;4iQ5bgaWXc`W&fBksu*ETXm%4mcEEv8wfBgL2X)_#Nizz%F zA9a5`t>kPjy5T05Y`zmpIE!u4-xxY7ac{I0ZkW^vvUY7&)e?j_xz1443HrFR9dJZA z?=?izjvBR1GtrZu+|jR4=7Dy~XA9UiNcco$ojMmo7e^cvOT6n>;tW1FN~f`VN?Du| z)=XSQm05cFzN{Ehcaxti33lB}c)J~jwA9R+~4G!OW4vP_~ z)9Ed<*;uF|12!x_<;s$>!EWv&sSg|@!2KKx?RT7m@x&t+7O3ox3f7$5>p1f%WLW#4 zl{x>wcDCBN*py1~7(7mPO}CO$#(q3&^&|^cJ)r0Se4im_mHliuFuURa=W!L9%Yu+J z+`-4)OHoL@?dgyYOs3c{a?1G5;5?6m*$qo(rRT?G=0}ua-a4YYj7A(c>?B&P01Wss z6t<9U?HDom`rJY;<8mg}loIc#BQu+f*@2^hVV)wAAG=hC9D!s9V}8ndQ~tZ-ZN z&F1gA&nFqT^6}8zh#}~mrUfU15yPlci(d1Nx8&e`ew*REy6d6Ac|X#{0-dr6YVv(p zKeq#cNXyBnS(**s=TD9GB3BYRJiqn1&wgH0LPBADZZxYOy)2ZGjw8&558ShP;$!;} zG*wgpqAV_c*RzwJ>403PC>{^8ZxVXCJ{&@TyzknG6SRZ+ zB;ou*QJ7K#x(+h>z#1V3tep`4bk8e|%?|d_Tp~jbiGu3w8DV zu2+^k<#4IJt1Z@RT)23&OMwp`*0MX53Nua#=cmD(pLCS2rmvR8JQ|y$qm3~t1@#}1 zD-6=oH+;)HN^<7H}jmR^s6mWSI}-;dz2b@u1$Y^rG3Y-gQO<$c*k5p2f4T% zv#oPvy68g{xw|_Z6qq*;hc92`(cxY(dh9e+b&HdoX8!Yh%!o3Da!l%%(1&(4p3s|T z?;o!EK+NvuQ z2ln;4wiS4%d*L|3&Xn6y?%L^TlrE!?c*5X!!G`fjY&?h}jx~Bxij(G!hssjp49E7p zG&w8lTno<%FP?bM##)%DuyUhyil1^@>xNTMeE)dDf~$6T19dY;L(}jIKVheYka6on zU$cMouf-?NfoUp>4&|P{JgvdC@1|#DYv(@Qzpwnh^V6BZHxC0j^Yh(x&F)0_azf9Y zUm6z1x7stc#io|WWw&7b0rOd`j#D?3LC*k3QAg0GZIWc8YqD=F56R7^ zl*wsFL()=VvaOW4=kCCXr(8iZ?O4hjP>UOnt(6|BY|JlM6U2G6q?H76D)hlp-%WXl zeD)6=GS(NGb?$$@lQJg#yIz>LY{Smx>;X4(PlZ7~)|WPRkbI{-maQSnNn)pzXY%DY zftP^jn}7X@oxjNcE6`aFzGSA_x%1#@=&ZR84N}iyEp$+*cx@@VmZ-%U_hsfA$HHylOiyw)=Is zQF%hLYKGbuhCImGnvhB4qE(ff#*46FW8@+4useGWLe5QWiI*W=$Fr&BwJCZkuV@h` zX|2I77Ti~LQU*Uqm*dse^BI6XEFj{9Bw{l+98EL+)sm0A-R99>EeMvU)qu(M+Vt%~&nfyGk6eR|bw+8ENvg~E7wXLY#$gD12)1vhxr z(w0xz5{Gn_cDeo&zlIb^s2tn+?u*X%V`x>+weBx=A*ajO5=G9B-0{}*Q2A_Hy;%Z7 zU(u<-%0YsGZtXZ-7V*B;KUWO&h%E)?a*f1>W{_|$D{<`#DOwzYyfYirpb6`Ik@(Zv zyb2ii9(Q$16(|b2+&F@bB?VrxaLaC$e@Sm@q<1wLIFk>$3;MihIKDf}mhC|4!qnqD*Y91%Av}d26-Kq2yA{>skkZ zCP!MbDc4+Ost#4~%{Ij=0X%45M6k#}fD*eT>5rUCQp57X>N4!$KG?j^`7=1~uE6b2 z4-F!Zz5}~t-FmB|C$Ildz4V+$f*R6pVFk@X2#qS;OeUXUnpRAmp<27btbCEMj+E>epZ z53U6Y_caNaUGwe*WJXY>B1j@%1SmDcCJ6-_df)nOUt#~x#*hrLxt!D$*H-(R^fzV- zmqzP0o(7klch>Qg5Va6_xu_FSz*(msgrUCo_&}>OEhZfQ6(byZxAfL0-wrTUT*0|# zW)$Hu6OyA5lx_l~D8~)*3va{db<;oeRUM1{eIGmj z;frYMs_CY8$m!1^N%h8nYZldkEnx|JnyL|1QSZYdwu{g#mZX4MPV}002=xv=O$jPDEuyx^ z^Nx%#`4T58Zf4IAS$_Z;U&DjU%V*bz2)qd*Pk~&v6@k=fMsCcU6HdhCLn830<`qD> zm-DPL0(3*8skElV$D+8YH{C;o6DBQl1Mo?{2dkad+HeCXd)x6jVys}OYW0^h0024$ z#e@`&V1yVgo_boQ&A(h`nm--+Z5jVSWJ{I(EVs5{OQNZHWA*(>SprOqxD>XjUTC~V z=tKAI+v&X?bK4>S01$Qz@BLZ|58pZH^X9bObWA7Oob6~$&2KSLp(U9sjIL}mWg$>B zTmpDnXK$CEfX1>}kQKqeXkOS)0af098~ZV5z$Zzg+NOOs3rSn0&I!xmifXShR`0A0 z-XX^Oeb~vIfZKqVa8ugiA;*%rjcLw|mFivQUXM~L=nDQqVKZJE!{AS^H+2e7u#6jj zA};}qmY$|Om$I^6snX6(V0zh5_;tTG-z4$zGjrS5@(TfEBYQ{?gWku2NJOrXo)Gi<+LD4scsw^;W_eB` zkW+jYWMiEI!h=Dx(QZpaEpRJV&>LrKt{wVZ4Hu4x&Pto+>-5zX~?2~f{74Hd% zdhDQlYr5v$)^stqSSi2$+Sr?|Z{xs>XWoy0^2hKzi{+bU?_Nzb=3`gy zGdsUIQ#s7r&;$yUI?l-1M29PYec^ePBGlRrJ8Fk{+=&Gh&5u6R>wvXgYDyoaMXF3) zbIa*|n}M7E!qfJ;%}v~6SipVBxqVKKY`K-=+iT5Aru*7o&gc%&nnmg%7;O z0q=~Y4Jamq+((=jz=+~iAk{D4MxTHlrEFv>Brfn!uLr)q^>F#*24OP5#t^0Iz9!xLMw{jQl zb~ZsxMd$ZnP>)-fD)CU?TFNr?W6+!4-4ps3aQf~nkH&hctD#hog*4SbCLkqsWQMHr zD|$_icvL>)rjYK{6l2Eiku?7ge5&lmQ#y&hqIv}nQ{4p87bHN;?4UH~H^eITE)ofi zaFq1RNN;z6#!>b=kN7=gY+`dN&~F|G<4OnaJr_cYZN112di@JkEY16Q1N6Yu^2B_K zyDMh)hX$B_tm)LqM&iRbN=`>I+I4*|rKnV8r7CKhhvKx~ub$pKaazDMPuG=`Dh}L* zHK~Wi|C9%1vK#1eQpc4mZ%u-on*t}p+Lnc~%;ALAdery!)%iu=M9WB(uuAtxfrS1< z^30vKqUHb)OSY+zBuL4kmtT>+Gcin|L!WP#aVk2j9(D~wO;$m*L2nSG4;&8PTNRQo z_1FdA z~{1;S5mQtEJ!phci4px+*|EmgJaN0K$s0P)6d*R4;+>E zefql9Uzlw7@PSvM+XIoM?%W+F2dJ!f5+%HW*U2Ps*sMsdJ~0KgDp6-hotudsXd9?aS2hB;$)G32L7MABhIaG2ujXy@ofNiNaaNj* zONKu4g!s&H&~A>Fe0ekx-GL2EiqUIcBf6P0=_s}Wn)AHh)RHf>;?-pyg3wINap%lwiu3_iWS zZw5yzcHB=o!&llv(t;00$=eWJoC_fP00?v#WxrZrh%h%*o4i@N4v~}%okR%vS$Bc` zbbIcd%n3JW(GB -- GitLab From 584fdda3bc88d401f5fb8921a545c2e29c5cf8e3 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 31 Oct 2023 12:09:01 +0100 Subject: [PATCH 67/87] Minor changes in vignette text --- vignettes/AgriculturalIndicators.Rmd | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/vignettes/AgriculturalIndicators.Rmd b/vignettes/AgriculturalIndicators.Rmd index 46f7acd..6345d6c 100644 --- a/vignettes/AgriculturalIndicators.Rmd +++ b/vignettes/AgriculturalIndicators.Rmd @@ -2,6 +2,8 @@ title: "Agricultural Indicators" author: "Earth Sciences department, Barcelona Supercomputing Center (BSC)" date: "`r Sys.Date()`" +revisor: "Eva Rifà" +revision date: "October 2023" output: rmarkdown::html_vignette vignette: > %\VignetteEngine{knitr::knitr} @@ -58,7 +60,7 @@ library(s2dv) To obtain the precipitation forecast and observation, we load the daily precipitation (**prlr** given in `var`) data sets of ECMWF SEAS5 seasonal forecast and ERA5 reanalysis for the four starting dates 20130401-20160401 (provided in `sdates`) with the entire 7-month forecast time, April-October (214 days in total given in parameter `leadtimemax`). -The pathways of SEAS5 and ERA5 are given in the lists with some **whitecards (inside two dollar signs)** used to replace the variable name and iterative items such as year and month. See details of requirements in Section 4 in vignette [Data retrieval and storage](https://cran.r-project.org/package=CSTools/vignettes/Data_Considerations.html) from CSTools package. +The pathways of SEAS5 and ERA5 are given in the lists with some **whitecards (inside two dollar signs)** used to replace the variable name and iterative items such as year and month. See details of requirements in Section 5 in vignette [Data retrieval and storage](https://cran.r-project.org/package=CSTools/vignettes/Data_Considerations.html) from CSTools package. The spatial domain covers part of Douro Valley of Northern Portugal lon=[352.25, 353], lat=[41, 41.75]. These four values are provided in `lonmin`, `lonmax`, `latmin` and `latmax`. @@ -271,7 +273,7 @@ tas_obs <- CST_Start(dataset = ERA5path, retrieve = TRUE) ``` -The output contains observations `tas_dv$obs$data` and forecast `tas_dv$exp$data`, and their dimensions and summaries are like +The output contains observations `tas_obs$data` and forecast `tas_exp$data`, and their dimensions and summaries are like ```r dim(tas_obs$data) -- GitLab From 19ccbb25dc8ec8285978feafdb0a495a8038d27d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 31 Oct 2023 12:13:59 +0100 Subject: [PATCH 68/87] Return to original figures because the results are equal --- vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png | Bin 4847 -> 16049 bytes vignettes/Figures/GST_ERA5_Climatology-1.png | Bin 4549 -> 14335 bytes vignettes/Figures/HarvestR_Bias_2013-1.png | Bin 4149 -> 8941 bytes vignettes/Figures/SU35_ERA5_Y2016-1.png | Bin 4229 -> 8124 bytes .../Figures/SU35_Percentile_SEAS5_Y2016-1.png | Bin 4563 -> 9212 bytes vignettes/Figures/SU35_SEAS5_BC_Y2016-1.png | Bin 4694 -> 8836 bytes vignettes/Figures/SU35_SEAS5_Y2016-1.png | Bin 3440 -> 7520 bytes .../Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png | Bin 4738 -> 8902 bytes 8 files changed, 0 insertions(+), 0 deletions(-) diff --git a/vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png b/vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png index 87158fd6fcf36a307f081621f3d0a567142a6b0b..5d05be945f1dc68da843d2b67436a05a23315cee 100644 GIT binary patch literal 16049 zcmeIZcTkjR+b7yaP!TX8f`I4%k`<5~6ck5LKynZe5y?u90*&vWO^Aat0G3 zAW3qToO90m>)BJ^cm6r2cB{@-ZSDEGYIx^mn(pVh@9VyaKsb2q z@5{;r!cI-nKjb^{oAbM=eDOc~tp3)rB@n0#NdN5kAeCTBAe!Vm^3#7aD~G1>buY_F?didM;msc}Ud-dG1BMl+<8tv(#XgkRbWo zEP)HzzZ;YCrt>^~PG?a3+Sn2fsF5f&xJNX2YOqlf<#DiQUcy*%SnONTaB>`fcr`9a zYqU!j*E4mQdMDwX?Ej)4(&Xue<&<6etk+-v>3lNXQ>w4K^7G}H$U>`trH%)s_EViA zTwK38I>dy9oob^b^(?lH~QP?yZ52><>}lD^1&QxcFn3O+S%@#YwYao z@}WH392_=%&v}fO1hllY0@)O&+Oy47RaNmu?Hr4?H2u;W;euL|5rKj8Q-#wx<}Ez9 zu$C4fQPBd$XvrK=^Tp{N{S(o@eqB#uNYyJAb(m=NXApbpO z+O2fg)_HUbf?mD4!%1f+sv9loh6_@+k@X$UNW>o`C`8&cKTjPpxRht!k~%YEmGrG8 z_d!p%&;v8EXi@vbYk{olVu}&M^);CjU4<>T&z+S>VJ%NoOOlq6k>^oQYYAYI>h4!B zw-Dsj%J^Pen>O&OzrQ~-GgH1)HmZvKQfs0br_sKqM74&To|jA|gF?1L*X=ba_R3gT zOkj6@-ODU%zJC4suLu#_Ur{HCIo-51cg+8q6n2`qt*RQ-RC^?a?t&TVo9}f09tfj8 z&B0OG*YK_Pgl@Icn+%R;U%!6c+FaK!u&WqrAB@)T1uulBua_t}a9CAzIp%Kb}+^0fvT#T{_nXt^2<3Tbvzh zN-DG)RnFLK($H6v8Z0g@ZZdct5a2j*ZTcsv8rxq*Mn*tc#hU%*)C`5^ioH^6~^~r%i)*H(7 zM-CqrH?jBe@oB6L`uzFxU{$Doo|VD;P&Kzsj_Rp#3X$wW(=cl*oE#Ri#l`*HP2viga(%xslx zdIu2^k#=mvwe^aj!9n}2jn%o@5wobH#EOcFO4>cUci$?oyJopPky+c=yFM(n{ZU|P ztV!PT*Uz6yVpQ~k*Dbdvb9;h*bQL-tpqFDU$7xEsUNBv<-Y6Sb(TGi7WcgKHy%^NA zTI;bDr?5%-oTY_@1xk-qEaCk^QS7w7+hS9HfRuZSuH)*;N@J2n8d`$wa1FXbM!U!Q z(qygpJgW8j#fy(hOFcH%7S|WYm%mX-X>Q28fB!ylusTvKH!shrIav!^Yu1@JYni}t zzccT={a7P<&|WgK^_7*&SFRkS6Zo5f(^6vWE!X3j)^tOU^^P9x-1`hPG(*F~$B!Hd z3l4Koe_W12aTs|JM=;6rXU-eac7?OL3+W3#l;kjG(8)ex#`mF z`{PaNf8HLKzxigzHg4$sjqv6IdvkkDJ&(;rQ;+&7CFj0pZ1`=C!=(27q=R3GP5eX= zP5i?o;TdUR8e;qj2c0uvQBn8J(@{n9v$HqXJ?5*0)C*H|aup`yHk0`~s`<;h9D7n6 zUW?kBts2{1P~89Z=|OsqT|q%X?<`9nu4afjp#7@RH5opzwzh7s>2Y6AXhiw(NNJBsNH`oQH*_%tCN@aPT9y zqSR(qPNqZd$|r+w$&xqGkQ*gg0uB51v$l0nf@73FMn+6@rc>ndM8`BfIZU>9<=jiU z&e{+cAZfN(dUMmbVXGsl-n8mVV04>8u6Ar+o(x7TXN^6zV1arpmMR{B)huXfgY2 zgHHT)UZUY8%{2qZQ{>r&p^|GOXT*$JZ92pYt$H7~$C@=Ij){FIwco(Ubs?xaJ%&Q- z{vQ}S^TV}C+`L6Ik8|d;&089;;c#RYTwJd(U=|W`>?v{EMMkN*=IZQ>a;ouEPtYrN zseCupRY>Y27>a)MLaEB}a)l0)vVL^&_h(zvQKj~)1_lO6>M51Kesz|5cwkgDE@9Q# zBR$q9g|crZG!!p3>)`GsaJ<&1OVj)!a5~gS(>CjFKF!6lA7Q<&~KXiH*El?(XjBQ0h@X$A;sUlq!FP@uMBS4hze7Ssc^OHe>f|O488S($GlJ zzF<@tR5(>2Z@Rp=7|DnK!>;1v>ubqf6e08S_3M>3<7msajKR(2o;2lnpY{@)K{>}_ zO(Qz1`E98T`?-N@*}AUJt z^2Oaa>3+EJl`B`;H_whOC4J*BcvDW+i?w-k!TkO6H+pGOE(;&pESmN9o2Bnkaorjq z)r5UmJeBmMR50~v0fB{3efQazrt@LfOG-*A--U4NpcScXcmR5|ryF{0zRA`Ph`@mV?nlNbrg6baX@NXPE< zH9q!R%Xfn9KUdcr_{x`}TG8@0Iaq8)I%t&EK&yuqH=nq+IGz+q#UOh3d^P~dTjJ-> z7cHYZhQit`)HC(TW2eMzop7!u#H#KZ8A;51-Zl2*(h)WVi@KP9s86%8U7a+vc8&-Q z4PC28L$)7ow#5u>%QQA$whXyemR3V5#_@|=8}o{TGw)pLW2yT#R_Ax^rTAG}o16Ip z)yP40`plW>!fDBD332g_>=r%OxeB)EhjZ8LuQvSfqYownK4?$tmG<7TYwrjB&$$+D z%5ygUl5T67w~Q@~$M986*5lp9g$fBO|E`~IIgmqJP2%S2a5TD)iNO7ioExU>TwEI% zPwpGDSF;1^O|mj~i&gR;MZ0X83Mw3qa&0VcH~httKUHQ^`AF>jbxt*9XAZ}eC!gZP zA3Xm(v%IXq1au&xK459;b#uMdoDle$N4#R&8kmgWfXVUk*0?6(rkHt)Jh{O++QUbV1eXgv=;m7GO}rniWpsWKV{WXUgl5}APn|ob z)b*-aPfz#Nm)qxPDS&4q@!m%}b{#%^I8pWE?-Dmxd+w9!HL*&|)f|ln>DF(p-4QYR z%%Jo>I3rO!SZqnU^=6HbtZCzin=)<>7e;Pg<;*U>%V(PQB4?iayB2>)Ae*jI8V3(g zl&Jlf&VynjzAz%Sq@<+n(69QblXaBQ4z_aS*7HL*7Ohu%vhBy4)%wkTJU@|Ex>Z1Z z2l%imgxhs0e^@S`S}4_jNjVm@flDXndRs8QFzy(qI!5^5(9nM7Mkk(YI*K@46H<{m z+LM&j!An`i6B8D`9aF9PC1s63p6$G{)`OMD#8e&t4J?;#>lRAM#kPzGAFnbPJh{KT zguQU#-z|?p16IS9ud&LD^w7q?eDUIw^ZdQRS&S9%gycw3!ygp(J->bM?J3%7&4UM+ z0qB}i0IZWj=AQBmhNVY{^OE!P^JBQ?x^KD+)}oKazkhE=wTYuB>O1I&O8iP;Ptm7FnD3p)-y1`I{RX zuL1)*vdu$-g0k*b93B*`qfGi4tCatr_Z(cvk(;=)n-<0P`6`p!J8``{t6sF~Y$gWX zLI*V_u?dXjGblQdAQBQ&>h8*IvJVy|7@%{Qc#btJhfr^|nhlC$~4JJ%Vdl!6GqOJ8qwA z{HQVvL&G}qZ6&^ z{pjV1>M4mEtDv@_34+X*uTVazjOSHfB`eygUO9HSQ!QWZ*vyX+5KqvNV42s>&d!)* zD+>*Z^0Err+HcA#9>pgVi@kAqQ5H`sb%rxVz|qT7T}`b{tAn8pzkkd9cq(1IT{YWZ zPIXc^CdXsB%WCc~kFY0LGQH<=UI5u-@uV}v zf4c)&kH>bg!*DHVC>4`rvMz&8W9`f5&nYI|%z$XEd)$^;{(S+K-Y`|IH7T|3f9k@f zRyG{%k;=%BzufIQssGtg=luEeW6rH(ZDjj1+ll~YvPdt1MRDI(Szd~Osgf7=r0Evk zOaJ^TtH;OUB)=1ik_Kp`bndNWS;qX&<6mI=C1dpKKo^-x;L zT4HjGOCkVDoW94VnzO|@+AOv&1tzj=A6^HlL`u8L5COp-0)l;H`5-jh*lokY%6hNN z=NORWNim1yc9UWMm?hrm5wvbmY)&ffs0;lbA7(!}$O|$xAJkOeJu1b+qmX}ktY>>G z*X6cyTFW-tx`X;<*9=z^lMx)3jLgh{lOk_rlj|aOr85nv?cUPUgz)8XG*KaMI`Z_S?tu`pJ9;^V*z46@yIUlS^of5VS zCE?ecn1i#j)M%k}87V{Pq6-mYw|Pg_d7+#C?L9}6n`c#9?qGm%Q0A+xPB(^yeV zJ}1v6{ja$C)>s)bG5L|YSkEQLgYr{6IWymnC~6i*%4vDd%=CV1_b9?V_syijX4s84 zbH`^kRaIG7#+aKrY;Wg8(SN|D{9U}n z6rrcwMsyBhXH3hnn)lZaFe*wcs>aFs5xY)h#X-PnNz-?%gp_flo~b#)pT7 zhRhTNfQcr7yRy72xJMRUlB9Mw#9a*l?Md=Tl+rvyR7!h$NcyCxoe3)OUSZ)^4vVv@ zJZ|ZgB7Z13$K`?t#ws~`>EqDjp}^#1ZrlF({114Ba$57*Bs3~ClWP(&N;~*N$h)iZf@xJ(e7)bi{mY!Huk^n*<$X4>o7VG zy!`a(+=BX*9H3tD{I9zQ~JAYDq$ zdh~ZZC<1#ZVQqa~$gJ@L5Icx9&tSk|i_W}suxp_Ft*tG5Qk2kxsEWI2e4%R%C(%Bcg&Ag}QUjeXnt5`Pj!cn8mbgkq6!tBiX9P+9xWd}W9W%a4g2Mosj4D?66 zy8hvoZo=?{#&d#+iRt9YiScpz6DQgV9Um+e3}A#Mso2FG7UG zF|?Yx!>LQnqhIo{2Ev|`4kw2k6Xx0+8 zwNW*dy7SJ}z+3;m=~+`pUg2)|9GHo;PR#XPEEmbGKX>i9NXwUTc|cb|pG${GAbdRZUqAlOUxO2!x{r=& zt!i=ld-P6moVw#lUr@N4ocXf*^@u|GM>8ERpSxH-tF@lqP59gI)PMc>|Hm3s|C!pE zJhMFKd+`3q6bIpt$K14^t>ZrGD^kr?S4`5c{BJui-o#oIA2b@*hb{Mhi$GBQl(9$0 z%4)`P{dM&afQ6_w6@hRp(c;qU;9#TDZ=($fUI*z(qBrw*+ggcXC)k;)1;Pu-K_KL* zwn0I+g9q~L2wTmY3sradx`3xivJntzgz^boLd>m8dBAK2-=0Q_*s}ih*Ih^qGEXV$ zN9}47DF~1D|G7;KvTFb{^5e&k(%uPCE@Kc8p&L7z!S+=p@{z?>+n-1hDRBZT!B$h-SAGKqW2C}ho==UX}h?HvXc{LOpH2C!>CZbPXjaI zE?*d{LWD`_HdIaq-h%`}i|tH^DL`5)G-%89BSgX@xm1fwc@}Ma$D4K#9_a*elLH@4 zzZE4AtPZ$8-A6ce;W739^&@+(+q`iH#GWu<7i;VErjMnYOX19q*0XjHIQ|avwE9Zi z7eBp0Vz(9x^YgwwJ{cFP0IO~MgetX<5eWY5w$wG@LcIL^nL&{$dksKx%b%YxG!FqI z+95eOVlJ&pZX+1SK#DG7wmuU}3*_w_Z0P-12E$u?;RA?C4&)9PiA zH=x5v9k}qv0uGD;;@R3z-^Y4@N7v}G5(ugN1E(I2#Cm}e4tE;uB>WMbpxZ*q|4ayVClHQWGk|#X;4fQx>Qc2+KrjwM5m~#l`H`E>L|uzbHXI9#$nIJn{{8 zZW$ptl-7Nhi}jco8B0KhleZPgXW=B8ZSN+;@NwEw(@{Ky;R=-h@zbYI&=sbO=KWKc zRCf|$=4@x~hN1eVCOIfd2n0qAQWl`AFc;bx#DTx%{C^){K^lGW<1J}S?H&td1HDr`yFYO4q)-EdR$`Bkw0+-S%n(`9DtDaN z|HF?Ht{~;iCYEQ9VTFZRcgFVL^cRf0~G}T4V#56rPI5;KE!SL@96Ab)+p&Q$Q zk&!8xNg(%Asr3~cUA&FE2y&HGRpF4M3+%@!nIvz;%LSuk5f$jeMzxIEnMDr_3|ug8 z4vKKZ8IW*UIJ;>>q=xQ=$bdTMz5@qryUo=0?`9^bI;^g);+I{p1vE7^(f#gs7v($8 z4?*zthiC$O+$`6y+<(-r0RD*9uc_f-jrW7(%sY4P#P0WwEhcjPB0Q>`gzA4t8amAx zAt4P@sN;&HkcDX1KfB0+Lf*bT&BPQ|o<4ZXpGZ!6_kxStojZ5z?6Pvs3kax^$69>e z$BYBQN;JVK770DW?0;zIMWbA!DjMGq5a0(TtFr$dHV$r-_A%+BG&Jwuz1x8Q4Sj8P zcDC4c*&RKmk=`=&p2*=lzSIQqAL#9C%hTIG&jd6ks*OYNLrc1Wrpn5$LxizB<*_v% z4LaQNQN znADx(<5P}&x4ZYx7f)zDNfE3rkWpZ!!dAZ?E;v~&)WbDsbJT$++S|v+W==bwUh3O! zLewyV2DK8)okBei=OIxnPqe9!-&9h%Ef@~+o~^Na3;T|3^n3Q~=A8_Is*0K#N@#o( z6j;xDWy!uBK>UAR`XjXwbIB7us4f3bt%aZ$kqGH&6O{wEBVNm&cswV(LE`)nF<>u*aB01bV6cTCfd)rPw_rSDZQ9z}uzj3o&pP!!IX?6&EN+3l z+9t@5C>l8x4iqj)#AH}Of;jmdGoagRBbHVZ0_$|+CKi#eC z>Th!I9zKL0ayZf&qjhz4sCNkL`Op}RwEYhgmwZ5QvF|-uKLeU zW{iR1R8WdSPPh}bkY3KH5}hR%%yDe~-NiB}9M>$n3e*y2>#s897oPqsfm8OV@!ua5 zQ#^!=EKN}Qp#Bf0uMzU*sfmPS+%@C;~!)d&b=!K?)u z615w7v3bJQ#^zpaR2PmJn&zIpd-v|%4I9NCX)G)jUh2lryuFna*+v^b22y{$%jX8= z7AK!-|Ngb1@CTKRHw*;Bv7{0vbukDX>_r9O1Fl|Op6qbMY=d#`?^gk-h*dFaW2HX; zc9OWTu<+TlXL)$0dcByU&KZ0~XpCDFZn1VkgZ)J7%?@GM!tq;ZN%8Rl35lZT-g%Ny zP0fbxJHmSQz$)@3ZBTcyd$7E_APvLX{t7I~K)*lc*RMyz=ji-!YjbmR8H?_WA~ts~ zUHYfV`8dxlS~@y2^B*W>SeeI;AJ_SHjFB;QDSvxw9Y6@ZA|dD9`}ZLq!`mz*Q95X{ z7Qrx)^E|exS3sRNp1wnWN)lz*{n?v+gkzK=nn5=CocNn>0J`=k>nOaX2I5lzhX0JX3* zAzKVPg`b`xmZL*IEhCE$4b?z82uIqqz680a$>+dtT&v9VhYlS&c1$f}6IiyTCTX+L z-_LJxdAY?QhmM$2aKi5gOiS~QGiS~KO-H_ZrJQ?T*U}YBX=7`fZPZ%%4zrqU?_RTE zB-|{1zq^)subPYJA0b)_c#SuQ3IO9}Wq-8jd!$UBbDkS`PI^&X$eq|7oB4Dh2WAt4 zM>!#0hWaaiXOT1iUw>U*KO|!K<2l6CH`Vt7E3$xai?=+;icq@A?r-S*NLh=?=gXb8 zwQzcZD6xT`S}Q3iDNEcp3)YHQq)5g9X66V9cq4EjX*Z%YTIdFsrJWKz_?EkS37@OG z`xb=mY!&0`H}Se|I$>G&yF@2%L4D7&9}nSU=jEM7M4(Aw6K+RVRcD5gufrI?qsjT9 zoT$cpnX&Qlbrd+Gn8Pm<0Y)kJhcM*ZKgPz!8o8$tj4tC&9s&fn*Iu3Umn;KZ&thoQ zH3Q9Q&M7Z1*ExAvAndwsfnEL5>Oi1k<42n4b}Fe2D+L9GiaEIkZg%!-lhh|pgoTDC zM4AcEg(F7b;O*zvq>vqa4WnGGV{>z}>8_gQ<;XH-AurFme3=4-&L)fC=EB!$a`^e{ z7njJNM@Oui&x(H|MbI|q^M|7{N6y{-`GWS~V#GJp-n9-(L?Ym>w$nr^ECcqN>p-tH zNqUYo%M)@lcRAR#5 z5-@B0`Bny=Z2&3Q_+xW@*?gOX+~t-`|3&>)4h}hU!wA_WH!J1d@4_MM$x%(}0#;C0 zQi|CUfl&iPpVG%~zXtTU&|5-AM_K>d${uuq&OQCjIq+Tz)=2 zX!q>7^jTt5ytneKp!lOHz3TF3lt`51X`nG?*Sh5->AtaoNM8LG7Z$2;@(yNa>Wwb| zW*|X@m~NPjKr>JU@CmG^1k zScv%L9OPYjwP3OZOB+SQvbD2S=_hqdt2o@Kpykq-{Xsj=HaDY`y&Ewi$hpDr*hB^Eo7VL2CJGn z?snvty^;3{I(2!^8S>uq`}gnXa(JN)tQzx5sEd*R-Y-kzqtfE@zxbCP6j&zZC_8i@ zR@5{v$5ph{ZcZcBew#CJs5bh6u}FJly0kaAtk&~{rXsGv8@akd?{+hD(3ayXRoo&=_&O2`q|dBf(=3&++v1w5-+vlfgjOj%;~`iUf`iL0X}8jQa3l zK8O#b6jFTA<-0)4IeP~lc&vw)ao?ul)k~K6r>wj@A*l3}ff_bAW<%KgXw>(f9uEZe zFlDqe?p7dF_z;)_BLD#8g6Z#fNaB9;qRO40cdC_Kw}3GOFKi8F_y+PC)s>aVk)*rH*n$R#x z!*i<@`CO0f^&UhyimZC2ot##7A@G2tE=PwgM4LAb$49WW*+Mq!KU=n5*#AH6>8wbB;B{J267GJxky{4*P0H|q77Zmt zyN?Ame$>iza@0^|r@irHiYGSXCua@Rz~D0Oes0H5C9Q#TN2Q^!HQVb14+~xA*yrpy zQyI*O>3HMDjZMf5NXLi0dNntelonNN#Tu{ZQz)NwG?nIVK_RiS?^m@7=_7?-xixmN zsM4(So!D={!FSA(%f|7T!YN&966VKjz*OtbGF5?jjzLbsQZzKIMAFi=9Wd_HJw=F- zt~g92;d^;``5QO7KrKPH6x|?80`G$JQ!7J7hHB z>JEZqju=0ALqmg#ib_kemhId?1=3J{C-{c|50@4f?HzTYf(=trd?m$zfHb?iyRkLx z-=7_+kRm){aQtIWRFqsDK-|1MfGIj8L>7f=@4ecMu5bo&Q`qOEhWE8b#zN zI4WwZoXI20tZ6KId&3xx?0>JTH{s#qQ)2`|@XyE-#Ke)2kwa%>ExHO8QIr#PvEM+_ z;KBw52BHMt1P1n#-a6&zMHZU~B|`2rqqx&2a8S&;B;BZ<`f)pU`$R2NfWHgVRmmr`5ot`0o+M(I>;vO0f=XSZ5%mrq)XR(-F~F5H?vkUNx!tD@PKvc zfA_OLVq#43e6NPaiim)!rsl}xHJX+5SppZBn0f1XJ@S)k4+`CjPKgDOJXzV<`=CvZLkagn+OITBI1I> z4f-!bLx-oQr>8hL_B@p?Q~EIVJoaCEcz)%EHi1y-`5)%VjgV6t0KnKt^TrRo)6>zf zUkke~Sp-(tb>xFnibP%rkXX{((>QV3|KJnqKJf1T@_>MUk@ADOm@hqBOSymwg$3H7 zHn-1iY-}W#u!wK^_0AODfgFml1GD@-W;UW#LcsY5ifd?$D^pUHfwC~VE!3l70z_lv z)kKJ>Jnh*v4IKsupiB2kei#cf#oD~Qyv&#J0ZsIm57M6de3!2+`aHlQc`w}m_3g!x z`nWqBj-p;(eV7Ud=>?BUBNK&X$H(tyK7IN$57H9ngT*2ZWp3i&>6-_+W+%LRr>eQB zFfdct=O@&yB-(=0jEPuTb___e*t%b~Om)f*H(PNR0nr!K(g_V0kOcrssywy_z3?LP zxKEDh&qCT7?C)>DQzMSYmGvCmsp}pdJ+&X(<@~pt}g?;52ar&jefvnz9%?;qwXsV6^s=)YMi; zkR3ldu8md0Xbk?`3S|DQj4Xlr%4(TA06M7Dj3t?y+_{i@*Jg zNQ>N3&TQ%SW*YTrLBVFV!Gc%cWDe2Oa}ry#OapUfAtbpJOENR}=Fm4Y8Uwnv`;P3B zri!ts{1qjk)8Pb38XFHB5fO1xhyQ&-!U5(2$LXmxI!^CzGO-T_ZbXT8|!<=e- zAD3X|bXJZOp1yeTA|6VSSeUQrjinW_c}Lv`ZK_cay!SHsAw0D3)=alDJ@#is1-uPB zx&ksz6Zl5J^fXb}X23g%!yynT?g1t>6m2&=gfR8|RMEU*hzP>W)NesU+JAs%qq^`g zPo{Bg`x~Uc4W+#??UOar@8Hj{zVskrjy-P1ORYN8!s184=V+wG=YF1{nS}g?Xk|KE zx95-E*iTTw^dHV%39MN7LdN7YBJu1bqYowkq7v9N_HA})ZyY8lXDZ~e6N1aasK<<} zm(yB8AMV<{8;+>lw!_>}(x5)hrTOXhm&X->Y=wn1!+Ga*@OeAm4e;v?Ap~2g_k~O#@sqxCu#l16x7Tyb$6+ArgM@e}MT&F~sN# z<{|Rt4u{I0z9kt<1_qEjI>F*|Ho;^dWvMXcy}Kn`%fLv)R-o5Qd)L(|`CgN&vh=L0 zsv2)ll#)Oc7D!fEMFmW}B}E6hoU3P*DU6tHd@4qcIVKy_ z?pvB!=0V11vv80Q-Focl3HPRd;WVeLh}Y?J=RVVVcp-_ z8(TMOSIHiSDv+@5BmQ>62qq=JLKSZnI#k;mePf@RIi>1o*uGYqWgA=TNhK)^Cj?UF z!4rJ%FsmVAPc$X9K>Y!Lgp_CV=ktzG)d@aIsw-FmkUZ)>P)?N06$o(H^o)!QWZ#0r z!^OZ>J3DV3Z<;tg=&WIaRO}SK7eJjwN>t*C^V2&>;9R?QjfDDUzERcUd5_8VY}6G9 zb^taTaxxElOEBWvq$kOm5}WYZLFQ~AIdp;+PC$~#hmkX5Z0p`U7coLfCGGhoW@6;* zYW(%K;*SyBmQ8_*k|L1Eu`;IgP*he%;sW+FLwX(Du+gpPjm5JW>Qg*YkTZgUjt&}r zZE10YQwTSb^ed<(x;h1!!Na<-ivTKPb_FD}X7rdkt(VtV3&GNjxhgC-z%A*a6f88L zvzX&l5#n%=KY>>+M|n^)6H80C(c@67-RR(uOmOX>2cS}rNWO19|L_-9{-|`PeT%NN zH)I^mEKY99qN~9w@rr22#6FG?Lz&oy(V%NIY*iQpkahLR(_xNisE#WSdT5*!w)z7} z#%<;c8LCP5roj_yi?bLJPFP|*F9u)Eq(eqVCb(nVsZVl#u86a!xEMu~iK7n?j*jYt z>+kLDt^8tNE8)%+fK(Gm4UxLCtTZtqA_75N7-|#>TvwpH5x4kUj9%;Kj!_ z;m2zGT9wF|gRWsx(@dh;rM+WfP7Sw=-Jzs^?^3E|Mrm$bCB zBX8t%YkD28KuUsnIyXPhO$T6zYnRwedPOm{aSC@7LwyJHvHi#P#;}xZTslOxO3O2H zAVeAzpZX)n-p|;)f3-0JJpH(5ikLu@w4zoAwdv zc8W9j_7t*nlOWHnJg`_&%czv-Q2LlZzVpZaxNbpHJcJ}y1-=wSGie$4T-MNx^co}e zpAg*Rer5o4l+(3%7Jhz}XT(dMd(}ong`a(su}1M@$)NGE$cLN_^&1`-IBQ%9fi!)< z{(EpV<^sC0*If69y0^ODdShP;Tfe1#3t~rVGup7Fx9}X@e&#oVmSfLywJydBSY=-8e+8LWcvkS;a0>PF=HV} zWVHIHuML#|g}6=^w;&}6lLF!q8w*P@dUj=(lSHVY40LPIkYQLGPa)Lo-i?dDht)MI zIHtuiFr##~=S2xbSD%!YCnxFmV{pMCLPXdT(*nh225MlQR*Ytmy`Q%y>?FO<+qZ9_ zR^>pZJ9R1s{Y_DP_B-i0tln&mEHPGc`+EV!2DAjipyO~f*Dmmu{~P-KPaORJ^l#f_ aI}Ze2v9<2)!!zH6YgZI5r%K;`{NDgqBXKAI literal 4847 zcmeI0YgALm7JvzeyhMs65rP;+tVIFas!#=zTBM-7DnfDuAwjDUd4nMk2*Dy?MWNLS zl?Z7;K}bptDDPK*0v3!}fE*qP1c{Lg;UR_a2!!0wyY9VRt9P~id%OHGYi9P$-e=C9 znQyN>Uw!WGq^ph8R#8#WJ?VVHQ$LVUsuW@zv;e`~9Z!0f|$Ko0GHD=z{HBjHz}|GzL~;1io)ZIPJ{I|2oNWH!S^A zRYb}r3vDgHVB4P!)IJH-2o$}^C|Y`)tH|k3yco_0=b#Z#J~3MRq^cR22{r^$R~_i) z8KQ{xq3EVuM|%xPr<@;qccXd+|Mhsa7kfhJ*=#b2G~G{-_9L68clP%`Y|wzjnjTG=<54y8SR{IQ`0-$I&5|@Q zZXR)*eYs&f6nn$Hs?;Ukm^F_dJ}m`vn*0Y@id{Q&^R`PqsR~{j99ui}@kqB_(aSZH zsp>&4RN)hE%mAv`^QrSzX?3!|o{@+MKOZ*t(mkLaH z={s2s6r{Xyvwf>5r>=c`(GMKbneU6Y_Pu{66g}8_4=dwSx~TkY`+I`P$tIEo+NtDdp7O&np27^#+cxx?H;a=(zzE43p=yrQ4;=L)Z&O z?RCH;;oJEF91a`o0eF2J-)e7t{Yh&7|9Z*Us3u&OhDNH}$VXrkM* zE7y`-KftYDj7qm9xOp{dK-P>rb=J(2k&3~DO8m7x!J7#%^^E5>$mr=6N@+`N!=UDj zH?XHXM%3ns(hBy)ZybZ|yU3bxk&m-{4idGPd_FjGd0Fn6Zq6nr_}GP%^@a}ku71-NQdjU8Vb064TcU9`U)q zurfV}b|RSe7SLVZ93r}j5=!O~#m^3n26>bcI5Po=MirtJ>=Q<8o*o_ z@rCB9S?DF#Gn*`^GxrKL0h!>Cn?ATu6PWW>;jNec`qB6*pe9h(kEg9h(?aBT=y1?9 ziaB&uo%OvEB=B#1`?gvT)Ww(7S=R+6F$CCw_myaIe1)x0(*cgxoP`}Qttv4AINF^` z*yz`IPjghUpNC;NH=h1@Spxxn8KorBi7;_+cuz>bGcZUlkM#Bq6h zaQ23~H+t0ln;`rD5MQbZc})6duJ$F73c~GYaB9%4Mrk#E8hNizp)0TbwT%YwI|4^*l1O`=bE4;p-+U&F z7R-k?7}E6H#bowP-0SI%F8jhoT%BMjSC&nCuXuE~CBHJ%aLRgkA-e3)hYEC-m>oi# zwM`;{brVGIVgc+&<07H3=lq20GasKI2?+wX#@G-KoT*Xssk#=Kz@NLD#k*KA)6$3k zgd{S5Q9Lxqq8DMFEk#WjLQkkoBz90_FNNG{da)$NPEuG_SuizTM`1TsFB`H%!@6`x zsbFE;PN}t@SkZ6g?n&ul@*Tj}CSDtI`ZzQkwVhQNaCJRz570Gif^N=aE9LPj&@cM9 zfLlu{5?o(K;8`r>gn#>fB71NkM+^7vm9Rj%<{I&Gs!#Sfp3s1=L4D6=TgilN_&X z9IZdudhO(j?tM$LHT6^kbA6TVy!idPai8$C9NtIEKcyw9A`@UP17dFjfaBRm4cm+W z&2G&uC#hQ;pYPY_sAie@mnHROD8%rgw%AN{7DhyiO9`-VRMLk%*Hqt9Zzk+eMF^Fk z+1Gq*?s1FWtaL?ZOGDg6#QL?At8Fd2b=1;R91xokI%yVLED&4I8UhwO%0E!N&i(Dv zMbPOMn_0PDju$2_2Z2~e4}|R<1+?n zN}y^r_kITjzc#3R6LWiq;>jCgq<7hy${~;P6yAZ?$wziR3|X<946(xX)DuWLY4#%a zwTHF>vL(w`9tye-d%LX=q)crgZi^11Pyv5%Hn!2!XSu)kuHE>G*ZoF=tSPEvymc~S zopkg>$UyPewEcEeRaO^cEX6x~1PA)#No5i5TdZWKXkh`%A_Y?7cixftT&KfcgaU<{ zE@gMb->D+dZ7tey?M>&r(<;`gZ_1Fign;3?yW;KPyLqvZQZdyG_yKP<>GE=kiaMZ; zeUa8eu8&i2!fl+IDU#xM>N+(gYZbhh#`gxDnj)ThjC{d1?@GapdL6EF23x8}p@x5G ztT|&S0o;=G6g7{OOT(A+w6ME;{`^JgfkKVGpPKlAxm%_3bxP%=qx*@{PYGZC6ULS; AYybcN diff --git a/vignettes/Figures/GST_ERA5_Climatology-1.png b/vignettes/Figures/GST_ERA5_Climatology-1.png index 3d88c59d86ae1f986e1df6e9ea640744c0a9a583..e5c5890f6c04015a960e0ef5236046e2da096967 100644 GIT binary patch literal 14335 zcmeHuXHb+|yJZ_`B{fQrOzTmS7?6yBv;s#^$&z!<0+Izh(g=sB0xFV0a+aKxC^=^V z$(bfL(4=|#d_U&isrfPY$5%BqbE&c|rTcx~z4sH=v)1ar6`skEUu3w5Kp@B;|M^G> zfjF&B{DV9V|8w^&Wgz@@;l-aCjtB&$0rAhNG>KFT1cD9m_>rWFYxL@vo3_f%anlBl z49QW-cG{9_ErqRY+DXpF{_$D5dLI5NaW0YNidc9oEuLE@KjxZ=O-V`7 zu$>8EEWH*O&xUM^o?uPw5OYyKYfQUW9qUa#u_b0EJ~7!=IiF>uKrID#|8ZOmhHrkVX&wCnGn>BivYk)q7FxVWgOsJOU^ z=}?K|Uyhwed()w1Wo3leYce4>r%0{tT**+)G;N=hm6z0b7aqR7R)NDW_BM5PcGlG; zJ&h8$CLJ_X<>68tgB!1^(Esr!KAz3a&JOPPmYngepC4VHhTY81_e+}ZKY#vg=NBFx zZqb|Kv^vs1I9TE^+hQ|X%zV$Z?eEL%EekKGrGz~R+pq{mL0j#7!-g;XR?dq(Cf$ir zySRzlYyK^F_4FpLdVP)-_tcDP?d;6uC@3v0%~H=#j8E-oZr;G-2X^D`8c9pWuzpUD zjEt0`x5HpC>gwu}q<627O-@eEcgA&!8aX&Pn46oU&lTE^5!xc}X`WDBlct`%uB4i+ zS;WzhWQ?rk{k=X}ch2()IkO0#n3&Fl@U2@pZd-Hv&LRH(95Wh*hKA8GG5xXoH<}1L z%b9Aqu`c=2N%`+W+5MP95;Gmy z_t9b-+89`*wLsL?>R}zF1oiPFsSCBesq%Emn+*Jx_4V}&W^L{5M@@QW(Y&=qE(fj$X(M{*Eg@(pP3TBb*|R;R3S~>tTn5t^^YkA&h^F zs7na5=zuZrY|P84`oFuAWMrhI#9jz})2MW{M;|O$4(7zz9W=3eXW0yK1~{w?<v5hHllw5w?ot%<#o`j^SsmY4x zufP6+)3+JO(y+8#`s)md*ZwSBkr*eZ#rp3bO(D#gD(N3azL~avIYUB`7Rs%Xb_W7_ zyvoDF%}ob_e?HDzH{Z~gFkWUqE&b?G{fFyvSkz_qXDfrban-Li3QR3Viy*MfhrcBY zq+@(9QVNSuH;z9JB2mxN{|n!_G?YIL8<4A0frou^b91v;C81za5M7q25OrR0g;l{B zp*B)h8xzYIZ{k7$RY^(g|GhA32HwFquC+h3)3 z9p|28-@S7ukBppMP*9MK?Lo}a+FG?`e+HcP%5Xs{B+Q8R#>U3=gHI9n2s{`YtGU0n zM^!)F()srJ%ZCp=#Wq^mbr5`8x6s_&neaJFlBA6qvwKgX1b8OQn8aU|ju?zrx@B&L zMMY`3w%@MaOT^z?TU&!|_iY%Mul79H=3c7xB`tak;jVcA$6=5^Bj$lOfBd}2vOhXH z`W30`)ZgrdzSa}fRqK|D0Z5Dt9TQVl^<6I2jPQ5w;)}eu+66~E=1z`rCw+}Sd`PT< z)pE4EMdYJ}6s;s&*W*WAw-*!@UspDFC(F?}DV5lc6-pNjGf`82Efy6PHZe91kC?O` zD_4yovU>t{j%IdLQP$`|FX6jKp!t(ZQ}>^(!|x<^D`HNR+MJ-8ezJSb~Ae z;oe4G-W^ufxBwdNV(a0}2sPa@&jaW2 z`6E7-9v*%q&C|5Vyc;tiEFz-0eE5TeH7&S7mO@@$-l->?Q+a!pFwJz1dC~s+WaWA- z>CzuiML&4j-qNj9*E)tu1$Dq=<7+}ff>w!bzjtxQQh%n|h9v#v%UeIMh0bX0L%F{x zzAbUEa?i$R2-BPLR9Q)>F!ufX_ak44Np9XtG9-K;D8iZ)9IpxR;lgR907QqEukvtjpT3viNK7O$*$1miqNPcly=z zJRzXCvX2&1;|5G8imcSe>5YtxT#i=P#wzx2MY9#sz3J-aw;t*mB>wC+(CPJ+q<;Ns zj*EmdmQv)scaM}{+|7#rEM#w3E&p|*Bur4aaQB6_cJzQbZ)72J5ILj3&4q%xQ+`P? zgD7h1?eAZG+vmHX;)FCmKN$suF00(Cl!+WJe<@T5{XNqI{Azc1 zH{mi976s)KPPW1YH=xUneiS8OQ#f0BxY??C08y|uQDY|%1x+*8=304K*;u)g+-jDD zKR+Z(l%U;>8#io+@+3v&8d_WB4%Yig5>Sb%na?L)ZM8#vl{j2~NJ&YVedNdL#qsK^ z)P1X$8&eI0vTe!I7n8L=YqFuXLUsXq=%qN|H}ColpP`j6hgh(|3y!-!R1C*r&-(m` zFW%eV*Dww$ZsNt=C`B1Ux>MdKFV(4V);xi-Pctr@d(W(+w7gvNer|5A9aQwISFa`} zCT@;hxBcs%?R--1I3I%l%ZiVoGe$I(Bj8v`FOc~&VT&C$AqvME$buaiwkPJm$!6|%i+1n z$pistm@N_9nZZz6y1Yx5Z=c`m^gd1!u*_BRqhQ`{INXXm=@YT)Orxv?__Q4QyCY6Q zFKYYv07oa@<40MG>C4g4^6vIc@jf}$WL;IafO5Dgkg?5fFl$wdz2Hk(An9{n)9k3< zi_6>lq_XuT+Wmc&WtGS|rl+Fn zhG0O~Ls=>kr~T958QPLeUtQRUlpn@_ zc`z5MK!JvahLm=^^Z9qEM1#7wBhvuQc%+~Q6k7jmZdPQ~u5wppH2w2W|Kf&g*oEHI z(C0lJF``A5j*u`84tR*3Vq-Hi*88sOsc~LCrhT+If&eCu#=9YrEJAl=%xtnAhuye) z_n&B$^02hba28OG5pfzRvC9=_5qc3nFn@rn8SG4~ah}R9883(MX^#^8bWdZhH{(Ogqbj*bEYHhuOy>Pj& zPZ$axG|>c!b!C45X6B(g1}SzWpTCNDA6Me{CQgoBst0>6pbPCTSn@SCG}sJ(GdVdv zf;}+YJ~=#AWTUS6)KHT0BRuMqE@>%k%z=-w#%u z81LwR=gzH66b}gsiiU<*>|JCxQN1J`1@Y|6+_1MXT~JWa@12;)0ncaCpP?$*uyCSb zY0$tNf~p-HbO9h$VA@^|F$LY$9x%7W@t)B{wI@N+Qp~^#qr#f}T87E9cU&4G%O|=S@J4C0YYn9~Cs=>B+Oa}{M zQGS%Hx@8Wt@HBy?C{YR-Z%%b61#lYaEb5j6S;Mf+hlhu}yu9#M3TCdU(_1&RCs!F( zsY7e8v$JPXLLb>$%FG3@_lcG{NIHqYOIuPqb&;IBKW;?%5#XR6ik2_!a}dFuU-*}y zwbNnh8yluRwXXJkBm%@ zNn2cA&h$GcY=9K>uR4 zB?8KV)d8iCkI$#udO4jJR2u?lJUu=8D?TxczfzZYTw`x!uW6+C3))P@=hbri=|(`LY2F=Q_**UcHGKmE<)Dqp$B10V{wXIXCo9{t_Jfw5USn?{ z`vxzs!;d%Tq?7K7i+e$9vLr_Rj?4o9_bEK>hVn(e;+}-Py}dM?MK zBRwc0@m?)yUWXeptM-FAI)PdbVfrc*d#9+VNH}oJQP0PCFkQLAfi)j1-=TARwb{%b za*qj(b>83l$fH%r9E$OWiN^dOw{KEiHAy?dN z7AS(_)x0=f?Kx^V&MO(`yi{$jI(`sHJ2O&bweU$35H*7H~1)yL0FBZWkk&$2MnM zi#$^L(iD^6U;yS8EWqE)J5R+e`_hW61~Y;IxX0Zy3n?ktEw&jgiW%>8--%u{|AuqLxt-Irjb7nvKP|6@Tphe%-Dt>|l7GNk_s|277zypY$ zJqTvi68m83q+@LbZhI#u<~#bY-N~%s{&BE%zy$NXl zZeU2rfWV&k-ftgBG%^OhpPijJfFJi*> zdv4Ad@Cfl@-g3gLB(=XeR@_$42e3^ru4*AEDb++J)=TtZ$1un&fjcfJMBQ-U(>#BUpstM_ux+<~Cr-H5rqKK5$qTBoJV{bQ5!~D`mOu(uNe>hC_Hx8R73L^f*U)< z4{qWvVIDqAeG-{?lzyc0&Zn0(zn6lrv>UjDb4wXalp^K#!=eQ3#t(M}^?XtC5=YxI zte#&bsI!SB=~S1i25(0vyaDf$o9O z-i8Bto~=ow1O{`)0GJi&J>_z&yBqn0TP|g9qPX(huBwT3J|(RK0NF z0`NAJWMtdx>uKuwhR~~ErGnN&?{+`=K=ka)gvq;mc&Gv01t41Pe2dV{eJStgLBn>RjZiy%`ZQ2}b4yE_xw=*8hi}bGbhQAo0#Ix?QF8)d!Ks`= z?48HQ#}IMQ<~&yNn+Ur&Rw^ngMn24p>*xPU;f|U1IJ>QQ~PCcH>O-hDv(Hf-T^2INc2=k>QKem`1?kI zC~l`q0{xh0Mp1R%d?GbIoR zf#;R_na{IF&Kz(AeE9G|smC3G$V;C(X8>f(B=gktG{}Ud7QHvn^#Bj#bm`y|ik3}C zM@L7P5$kAqG_6Mp(*ZYn;8!%h89%n*VL~9dIb+!FzuJ58FXHlJRFtUWTw9V%C=vat zd?Z7>R;95UG}i_C6|e%U=l1(yYZ#=OBu);u0Ch&lnjjEE-yfcv1S*0kQtoe>$jf)a zJ%T}z(!Ue_ocQ|(7kt*?_b@O6Q9_L&V-#2c1#Nq0ho`?5R^V$$k}zzo3!uI)UAecX zXK66^WY{bYXzNynh*JptGYz5|bAW;YM0rm7()INA>UkgSz|}syLA>V8cGbcHcvZ5a z?M;%Q1YLuQO40RXe{23zB_9Hjm5VKTG75qgC}b={acpN1LZwsZCV@fBRv|$koE0nC zn1mg^Ml69Ad~1*X#(xrnS@60^*NGYd4C+8TzDi}e@0#}|ESUQ=;%DZNEdd_xQ<^n}+kRe7c&N%$EAn&$WMujy^o- z%x}oPhh(;1};({q$vbtKU0rlxa1VuAQ(6Z{Q!CfJa~!1p3etjAgzFk^@F5+`m; z>8SuRvlVF(h+@Us0%;iW{Kf#J`{(C|D36LG)s3*FN&_9konv;NHjX&?b=PL2^wJjpfAzs^r*E(TA+7o;6`#X%> z)xhNV=`p~kRBEGawE&Pu3fk!cFDM^-UjrCoC5;=9ObQ~BX-hE1!xPEb|Aj!PGnS~I zLHrpEQT2bpOZ)KnIdxe%IZ=0kaHaEvis6S~zy(tU5a1)g$V9BHtN_IXAN}JI>h$ZRdkn!)>R_r* zsLqG!9D{T^^9*T!eCURL6n5h&i-Yi`DL4_K@+yyA&BCuKDLGmt&yXASm*vxVVC1@t z0dc_3*Y^l!c<@@l89aPT7J0|ujdRj!;!PQhHPz_{k@g@Rfi8guiUeAKy}f-P-EG_c zj0lm(V^_8F^nVOwYXLo?koqhJII$;R_|j!US%!y)rSw9$u3bxtZ)MkYo23~g8!#QZ zdiFK%G`t;D92=k?p$idBBDuO^HXj(UMvXz>PRMuvvH%6Mwzd|(HYN%Le944Yg@3Ce zjl(`RE>4d#v}K%FlQ}$~!8L}m*4U1fL-tWH2`M1$PmVpM6t#79cGS)uZ#1zIiH*Lr z_Y7fD8qYx2NKH+xsPJ%iFSltlbb(nm{4w1vZFA7-6ciNDbcdV)Q;Um{A3r+7wm>hS zGZDUY9!)%vgdpz<3l1&Cl*mc++9-6Bd#%{y{-x5)w5)AkNLqEF6FV2Gk>AHn#7>!(|+;?=M5} zQDiG6%YuET42}{yUlCaa=q+C#hhb55Z^k#Y|w?VdsuF)qB>v0e2(!cW(9wpv=t}|{T-$*8kd}0I^$#Le=rAy;p z2df}S=#;-~Zf#xemSK&#V}JpM;h3o#bX`aiyP-U^xOg=z287PrRohCS;RO^i@gqrZ zo3?)Bftb9ta~G6$VwS^$|Jw&JBJ@YF+~nrA0?!JFsN$~c`e46NQu^TM=NB3(4;$-_ zU!iAVS%YlFG5qzdC7vUo$_g=K$Qub*sSp-2-4r?q+$V%MwBPN`&6bh^04gA+XxUXc zL3+NSRZo_UNLNlJ_755^l|0S<2W3*I(*hAOF(3ls0I^&^-xm{8R#v8w0<+V2k=3V~ zni{G3tgNj0SPxt1%~Bc;0KFhg;B9g>=JDFoSJ3*(aJye1&_kAW#EL}$*8B1WSg%~r zfkEK7Dk!Kn(Q7S0$t0BL&&h!Wg+d>!T%a{&EAT7C=1U=m`mTlEhfg^G90QX@k(6RM zsN_JG9YFyEEw|sj1JbTBh@RjU6CHh??8fTHb_9aoLi^D#C1eUA_p7t07J^~&tQoYq73ZexoQ5<&wT?y*#vLFsf!E)O%k-)K3 zP&6Ue_aUo_K0>DH)p*4?n!Qdm8syLyRRw>QYUTjcad_53X(>feNN!`zyAyo}_8_H~ zmAhJ7xhH)5L12Mf*nu%dE~Oohi3#}64<3Q8$f@6RzF1^uhAJ6E^9baIN}v-nUw3)?Zk$;uHo#D8%}1u_Oy zz9Z0Fkmy&hUVR7)dwN3|EC)~rX;7$me3|QpA(8&q_%$|m`O+nLCDk;A+rg5HB$oTq zd%;vkd@vVyuz@ExdO?FNhadurQy&BoR0ufLzK$3wOcvB|VBSaKR!2)tj&>(j6*<|? zt=&8`^d&5;7n&G2aI_WtK$JgDDEs;U-c~d_luhp>Hxn+ zGA}(i|Ia_yL>X9F?Q&%i^eF7>y6!lkYgqrlzyf9TYic2l^Dl&mdO5(yzVu(ew9V#E zPh^9u0f1u9@isKR3m5VYJs<4X&R%|9r%0U)D<(wwgXJIr&g~TS#@-(WN7lg> zv}rUN&B@70J4P)PDdAmxoHB~>UtfQr6^;z2BVJ7fOkp5JrP^(5ZZbft0Ne#a#{2N_ zm&b?ufGB&W{B8pF-6_#Jv;F|q9Pi-hNW`s>X>^{nz>R|c@ji&i&$%yh_`!(^ahRFS z2QvyTb-v-$hW-trjnu`{4UnH9tz%=JAWngLu)VRt`Be)*HuM+osrm~?w;4`zTm=AZ z^1$7l08v3Rz1uo75BGQ+%Kqw z7l-k;exQxVTk~Bm;6KG!5u7_W1SDfXf#3s73o$ubk?40F_p~G|EDY8_O;5kS)j2v^ zXhB6gzFP3HN&1Z zb{rRZR1uPtl$4SZuu56gG8cOB%{o8?D68YJ3(&kPT&0bX{)}Kz~-?Uba?L zYcoqro8Rd#)YhQjLhE*C69U*&Xf9#h1q;F@dc%_}0@9R{TyW!XF=+7i&d#M_e60p3 zfR)amKG1Lp)f^KXsi*Ke3fs}L^G>fXh z78&7RSNnQHsA5H&4x8Cex^pL{ea?%`uIc8-A6ru$`|@CDw6NYrfeH<@2}^%9A?3$Z zLsB_uJeSF?++h_3Z!wLGbNO2 zyibm!`Iky_w9CE$V1o=g#*ZGajg9*G?p(aEs8O_}H>ilhdZYhmZ1lWQXs!9oSKw0h z_K2_paW*Yd%X>+4HS&-+y>kQSeliJc+GJO%r&ib@|$ZY6dTwtNgRF-*ILbfb5o+D!`p&^3?y z4(Y)JD|b$p^;)yTGhtJLgCE4e<2{?XdXe(~{O4T3XB18WXGXTg99 zd(sb&22%A|5|YshlxQFX3fuuS9b+73>*5Ak3KT`emwClCl9ee47&n@2}S>*{<4(Za&R`ghhv zkmz5(eu2@nL2hz()@i2Os{kni0rM;s3yBuGauY9{crcMaTCDgl4$x zNX5kiM|=BpmGtkdT<g&Wc0bue0k=5df2i@^2y3<$P)qx+6WBVc<@3+{tCRGfXtZWVEDQ+NFe*zb<9?Oh z0}ud{%yZDfKsf9K`Uq;MwTABEw?=*N*4h1(2S1r?kuxLb!gVO?tuCL*1~9@}to1(Q z{9x||uai8~Yj7A}qNe5phYyrXt&eKuS$BuN70Plb1q24dk}Lq|RV&+#mG^&rd>M`H zHYYFzyp;8sv$0XOv`mA;*`JrkX8X9)Iec!&-G(Zig{*+TmmZcdyOsnB# zprtiEuw?xZab7ESfMiw@_oZaqUGC^G3tAxnqkiSAqoX5OkoG-lT?ehzZZ|(rf zgjj`H0OSAWc*BQ;k`}X#n~>n=S5*w(-rfcSCA$6{`k}SfO5L|5ebCCa5-`4Sj6J!d zZv!?j&6)^Af#YKl#=sb1$Ht7=h+CNy#jmm`WvO(NVIPr1EBZGVoNm!9d{kb1|0`+= zrh;Ode9G1gAD)MqSZzrm%RUZp9((v~9X07yx%W3WrvvE$vx%k=3`Fpa0hseaq9tGU zVxvFeQL}KNmea+Gr2`ED_V?5`{eW~G;H*4gn5P;`OuMxj%Gs5RN z9p`<_i8TiTF`J9$99&>n^ZE>7=WoD+>2!4|U%$fsh);;a4&94<0{r2Co}@NdwZM=t zR^zQ#GcF{QNr9hg2nITMkB6NloG6~v7^Jj9Kz?JvaSs!)lCWGgJ z6n%3|D52V?@3D!mDv4I(^9!OR`7ulqUfR^_1kdh%Ga&)UKeQL9QF!=D8E&C`f zWEPrrvVg1zmmi6>)KswGc%G!{bHm^t z9}9LQ-MTUh0g;1z`#ep7XcLARYiDPN22%-uA0|eDoB|bfqdXI<2#$NA1Z(M|;aOm` zp2dkDK_`G>1bA!&a5cmvv>O}TlB~wxBpyUY01H_1n@Q^}z3S+9?@-{ofqDZ&Yz;U~ ziaE#eZKhk$T{2ZO1)P>tJO&M&8W^&ymwhTKDqu8v_6)`j4*|Pz_~>t_2Y`JX+)}4L zkQWDKUjljkfMbEN3(O_`pORsO1^a?x$rNDlz7uUIkigHbD&ijIH|l%uP5KEt&K(kG zg~p*Fb?6}IdVsgtcTvlnQ_?*EAbe4{%B>KajBl4-auy6Ixx ztUho*z9{bJS*~dTHaY&oU0_T1`GEqU9F>t(|IvphiFouC(qgBK0U#3aGcz+_FS&?@ zZ(A7G@yhw}kSu@BJX;}s;`c*8O{bz5l?a9_f^$;$9(?D96b*f4MLCiN&Sz=#27Ke> zrR>W;U}htLl_3sH`vCrjD`+#hvwwW7*_nj6$M>hj>e5QP_{rwEn>Q2L$v8nwpv6hVmaG zyJ6Nl2sdHA&S(u|?1cMrHhc*M(D1@2ZmeP#Jba{RA_<)xuv%}->j|b@5b1@4hQ^E3 zb?iytUhoAahhLX&QRS1oXpuEmvJ*;(orOIwV{G#xa4=^#pynK;{ z>!x0{wwU(}_!po$&|+RfBQ)k6t{n2)S@&sgZvGokR!~r-*HQThFVvfV{Lz35zZQe3 zFC$;XecPOoEaRovdfqV1q$weTA5}G)>nMwVlD@5jf39ZAk@)fTYm zQf4xey}j}DOQB`Itk`1P=&0z88;$s6@k&2dYYn~YL;PPtA$@`IE&zHF(i>{X27H@B zz-9!#Pz6JeHLgciulfA)(o#8S7L?+9@$di;b5(9zreL)c2OS6U4!kVGS*}sTz-yoq zp;`fvN-KLuJ$--#CLSKG;#Y8D;P7hu`4b%AZ)$2zz%I|i$jEr*iuu1PgjVtM3&82( mb50=;6$bxh6}0Gt#Ff3DukMuX7JQ=*@mT8Fqa2L>oBsjjkGin{ literal 4549 zcmeI0dr%Wu7KfAYCI-|2R6v+f)K#Lc&){QV9Ayw02#SQ}nJ^jy0)ZGXNaUf6A}Zix zAPQ(4Ek#KnEeJtEB!c(?1VI`h5H=tn1PB5lkPx!TxNg;M&DQL0)&Aj@Rp-{}+o$fi z=brxR*Ik|J>EVJhwls#pU?|t!yY|6g2tYdwbu@QU%R)vp&dT%0{mvSHezk7hkBFft zv)QXFXP;nadoHTgZ`5kFS4I6kGH6QHRX)+C(d9R+v58z{IQX@rc)J*068$Ui9@9FI&zykqOY!b2czL`lfk- zr8KwpAq$-PLQg%-=RI>GDf4Z(r@SFNa{Lsp_u5ks@^j&Gf-f&+w|EUiQIrcyR#lYz zs(c(IYIvX=>=bEJ;F$Ho;fd}u)05NFYq`RXqH>30=l#q@?TsoVR~?&FqG(0Zgdr7y z{CJPUd&rNOTMcRZPXk2RBwi(z;-?yh~t7Gh)~2f3smxv5r%Pa3nx_0A|pz;)v!1CaTU*f0)?IkX7_s?(IGBU}9Kn_E10(q_N*4&^0eSkV{}6(+F-LJJy?2h5ZuP;XI| z7|vuK0 zVS(S;IHeDQ{la+Z*vQz#Z@oJp0#-D8Q?77e%-o??WSBbb&nU$_=Jn3f&37Naj|KkFuR&CR0UiHxjg((f!o z;1WizW*Gw04@rJY2)+H+LsOG7zXZOt-&T!er&aq}IPv2}2Q@;;pTil1Yi8w0H!`Q6c=4frv*h@HYtimBJE zG(5*V@a^9ohctyr@bWBEAcU0*#&2|a0HC5&%%Rbzq5f*DM`;%oJNFYUX znnl4XoF2PcQ+h5qmD8AUgmw0ERrl@D9b|8cAE1;+eJts-dX=!EfnCzuRW~Cq9i0#; z?!(X7{R{J0_|KnjA+i+ASByIUv#V$aikEB*GC(WB`FA8KEQzk^l}fu7N%b4zrVni~ zsTtZC60jRc4}n_{X{TB$T@5VwIC*;fKq2p4qL(4twiyNWPGSjr_w*=PLYE4&Cb!kw zY~kk~K}{-&;`QKG!t2)ZrHWXp9(qs6%odz_9{8Sxs@zc)-TEP?aiX`>siGT;X*ANY za7Fx^237A<*6X`QVyB!QRn13*`*Ja^{Ogqe-S+!=ze0tQxkRM9=b)t+R#=02f#0gM)`J44U6 z*x^i1X%IQ_SgdMVyb}RYE|YE=u}7f9*c9&`YZJO|*o;|`WA{Q6r8W9`(FkRZ3xDU; z=h^)Eh%obKQEyDxv#Rn4+U*`7J-f;;P!}Rw*Y4=t&@4uUoIkMTz1YnLJlX@8AfVPB zVAB6S93pAF6~R5-7~oOR%GEpRm^S{@<(`F;IuMdFhnH4(6pv&~-)1g;1`0QTQ_Uzk z#f0}Q@sKka--SI-eJgpv#bUR!RL>pG@UO??(^;XpPdsj2j>nW`*X$j7Ksf?4zzH4Z zT+&7Vf!QUOsKy!5+3Wk5;M0RG#OeM>@5r0kcRgi{yZFla;YI`%XRtCUCJ3ku;%1^G zf#%>V6UkwTWc$A0PH(uxN)R`YYHy0mGX}bJAw~r8vE_caL@7{2)asuju_KYS%JU^9 zdTc3-C7`qAvZ=yRp&)-eP^`Q(W35@8KS^cFy{BI&?*+Hayih8uqD8-zVjJXJGTH_e z@Pi50j&`mpVH{O4@F9=DJ@E?HlAt^_% z^JHkGIL<&5#>~)5axuQevY>X38LoYY$AUVg4a+LwY23KpI3`yWc&J-$*~F;I#YpMM zKK@)ok$$~JT^DExshIe{b=)Bu%mvw3^)k*X8oZ(SuBeq|Y~MRC-D0~Hdiumcjse@J z6+822IOOpY9asO+5dKXtx?$#8>3LZT*n~lAwh65yoz7JE1CvGo1591A1*LgXOCTl-xE&$6+k&rg#Z8m diff --git a/vignettes/Figures/HarvestR_Bias_2013-1.png b/vignettes/Figures/HarvestR_Bias_2013-1.png index 831f792cd80deef21ec9af3f7d572d6edcd77e06..14673e899c4a053ceefd343b0480cf2aa475f85b 100644 GIT binary patch literal 8941 zcmeHscT^K^w=PyBD2POY2uM`|5b4!8hbkx-}P&qz69-3cQit7Yk zy-M}Pc1<1PyGJdxwsT&7WEJA!;Ry-~+S=N(w6qiz6~*CjbaZq}OG`>hN^Wj$B_$;Y z1fr#-B{DK{e}6wKD+`auCnY6u+ZA8FW9Y(gja4i3&UyMoX1-Qqy)%f!Cp0uXf^cO; z1K)|&G~!2W{uNYIIgefRE`@wZ@Vb3Ui%YTEf44@vSVAGUvj%Zznz!DO_S9L$%m0J> zHl`3gM7aInFxb-80y!G1X>l2vM5{pT5Un+iw{0N11wGL$wFzm4GO|4~9GJgBXE-(H z$R_o=!Y1-t11Xsjr?Q{mX8t=Wb#6CRcl*h<6#Zb!jW6PHcEa$ZbHE0uqbuR#rIjqKpj95`O z&?f&OA(-g(7yy4H<$@JZ3QHZ^{t%Qi1=j>*`DUM4 z_{{4{Cm0KQ9JFn`1bmqC!u>Sr3o40U(|-0*FhA-%kCD;{*mrJkOG58s)}VS_XWdl2 zzI5*tm*C#!0RW|6Kv%#1RyVo0{Qv`h6_%**J0$Y z*W^4Uk7DxCsq^b2WUYJs;Kwz#5_W}Q*D`ium09rUMf)uGUy7n7ty(`n z%V%OWm`GVQ&oYir0puAHgC-)bESlVwqWysu>)O>9=#Ek?x|Mk^+E-2Hx1lT?a7U%D z#_FcV^u72CV9cQs7#O6CDD-n_o)q84i%atit$qh`MH&w34?Vc<7t&}-nuj&@R7=YB z^cv$9pr31$ZgDPul&TI0>iVh&)C34KJ_Sk7;&c(`Yp;^mqGjTlvv@9c3jzJvO+(|g z_xZp)Q3+AWW(PSgn>C^{;NlU>L9tDl=sg(TC9hAy=CuIlm3!dTT^qr>#7gk{o%vMQ zl!T+uJ;SU?5oDUcl`U_14JWU(;t?b`9P<_R-c?`h?qMC#PRBNN{m$J^VgeK8!At{cW=yJc^C=HvLfx8 z_Uw`&;n92G0?<^=Tj()wvu)HzO&097O1nu#rThnurm;FEb(}Yl>1m4kPYWBv5z(me z3i6y#sEN~U_mJ@|>Z#EtbU3(``N7fic)UoY zIH1#yEjL*_*5yWgWB_BjYmiOsZ>1aqjyr7XSAXV%<8Dq+JVtOUa=LGqqx`2`Dd27S z*xFjjbh2qKduMcufG9SZb1?dq6zXkgsF90UsQ4w-gox- za^5QxS{7PXoDFvzR(lrs$+Syhs=D@V;iD4-g!ZERW3tM{1Dq2(#-Dxo?FhszD4Q8r z-h3I~jdXNIqnr^ zh~z}ZJa>Sm%XgMGO<8f_vwv8+EyI+(7HXo>xB3`Ow zuAK^5f6ivFL}(3lL(Pcjy zV0Nd&tGTQDD}6mg=281neb%{sff^2jvFxIT7<#23hsQ(y9zW9G^=`aVYv@VAMpl0V z-r*d~?Yh1QbtDC`efzWrLD{n#Flx;oQ{*dtFnIw90WV9e7`+HzQ2KVo#Xo-*TzI|e zE;SbhJg=Dax{6s&B~t-({x}TLzs8ewl?i zR)my?Z} zp%?-r#&ZObee|x3#r=t~7A<$7j@A8o$hJu>fR0SvBcoB#dCthwDyP~Zs5Pe6Y@wz{|Lxq`P&Q~XN&q&I7{G7UTo*lKz%c}Gr9H6VH8Aey3&NiyS-Ut|B_39gLbH+z$;HTB;4i2|u ztPOc*zM!P_rCrr1xWx{BJ|)pF;98I9?^cwZU~XjD#QMWBsM$#_J4jXJR%X@pygC(G zeLpD>rwl9{nj&^X%xFW%wLf_PwQ;Lnx6ia%6~ESOP>|?WWjm1KH`cNg$F-D|^iJxA zhqvm^ooI)rP8pKX^HqWJBVa~o&em-Ox^dGKQ0ZaS&tL#^jkzYi){7gdQ`6^!{|+fd zIQU!Q=!Ivabxn$vddUx4`aYQSPWnw_La|W@iVL;KB>cYCY-afpAL!2Fc7uF@t3^oR znOi7IqhJ@2OgS@51hNrg^uvO_)E$=7*Sm*^<=-WuYN-<2-0|EZ^Qo`O04_12=^3ab zRez1%(Ei|mZTdVakNrEY(cmHS!`Soez2@D+j@Mf9NuE}H`gK7mQL-Pbb@M~SH^wXq z>$I&LzoS<@w|ft(C5H2BOnBsdJ0@B(==}l$CRt{9nTe@??7=p2mgZw(k+RT&dH#}m zWqtQls)iB7DjiGS1%Z|o8DBtGxV~6$481-rYNDZj1Ag9XsOsBH3IjpaO7s&pbV?yG z_B(#QP&Ol3`TE0djJclu7(J2_44GTIRG47L@$M)icW~!{#$vIDkw7)MEhXUEGy}D< zvAt0fltq_I(%}jLgz7T$zVAl}NUznvUb1Ro#IGp+?Z zncrtjcF5qCEo(9l#z&WmFb3LCu+2@Si9F&y6qQz5h7&GS%zEwxH%0DZLR~JccV!Ga zf!zpW0g9M^?2r+^Ye30#6txOa|r<3A?ki($B@ z4~5z^s_&|Eqkst5zYqUe48oxRFjkk89Rt<-7iyUT*qFb*e_#}#-al~w|H1X|0;)sh zAB?m9&i?muDqR0%=>CPV-hbwVl%w)Mop?gWfAe(0_rKYM0;;u9L|>veXN3S(H%phQ z=P>F9;HPfjc!Bu;zLQFn-ibC&LQ^l4xlw;}oOIBYzYI_lQR!6wOXx|y{|^^zqyM5o z#Y6os5PBz&DW70<o$5?f+2f`({=~{Yl_>7KE>C-`HO@OJ<4A zCl%785KC*C3fzIZ0_VVTQrYc6-fDv9!0d&aY3sof1u-vyxz;ilWVfJTm{pJ!~SYqvKEMSPfoPGA9+h4 z{wPmWg7Ehur#yYMUWXh_4LJR(e9dA-AU@GxDM^be5vNXozCwl$cG%Mgdvpjt>9su@ zl6DpTbHC`tqIrULXVAG?`0zVQ>lc8jVwgux@^ei}5YCZVNP6LbOM%9e4+DJ;jD^NP z5f@Gd0tPrm9g2VuVGvF0GDd2Th2oF6z|IvkcQ+$FBpTQ@yNF~IU&)FGo)*!X-WJ39 z1t<-LJg)?rLlR($KBvkwt)PGxpuF`N4D?qQxDU>~J_D@L)9^VZqQy;fl7!~QO;q9S zWtm?&;Nnl&i~sU5u2L^S)mT#X%ca!Dr3EmoXo>QEl}6EwJ}7&|jzy7+(oBEjCxCaL8~uZ0;KP zEa#X}3p%3=`9dHoVc#%Y%BCK@7zh2OIJsFt_LJ)OThQ9w0Yx3@lu&R zg?8WOOnN_Q29S#4+^>df0$$LL@EnOYgLSZ+<_I24imgu+r=}0<=J$*1mvwARtZTO9 z#s-LkhpOAx-1A+6e%^cEnp$ufKINdCcj^t|v;9N>Pv?H+6*|I+qdT{}aN=3Y^=}}8 zxzV^});F4nZ!^B;$>ztaJzPtTld9W5OZZGg)t0fP_*8EG$28TaS1lE<8@8a&ZauAC z@39a+?OyD$l6qw<98K`fER<&w!6VQ9dW1>}M@N$47?n3S*c?F-20l?skhbXJ-Q32P zX^5>T06)*9EAKv_Jh5{-xcObgc5T!WxGiPEG(@{-u(3!?0(^E=Zx@-IKffdNk&15g zypB$ZV;DMQYoJ{e<3g3hyZbpDwg8TLPF(vzoiQ*d|9V|qUO zR55;057`t^pr?{x^uoWA`k%!A{p(jJogqHy>!x*fPmAF+1%KK%?&5GSf5h-~S+M9U z$0I#Y@?+Oi)ZfzPzxI(JNs?y4@iRUXr+x3BdSJ18RzkVIq^K4I73-D-?0vWy_?Si~ z*IlUjkBond@bf(Vx8}#|9!Y^eM!*<4r&N(%tBPeFg4+ zYiP@_-kQffTxRLfA9V8v5Q98Vut9Yld!t|x56zUZQ!f6dvrX>(yJmO^j z!A0p3PbOeQK$DaKzqX#=X~n)LNxB zKqo7!z;f-EJ{1q_hJK;u8OZ3^lGD6AV9ToF+ zQ{+e1&^mK5TL>R2PitC+*I`Qj{mZ`r-gPW9OotJi>ds@Rg)--^&l0d9g6Ikg|1!aX z7X^m`gi-5p%I<)fJr}V1oelf2U&?brE}J}{9;`i_8_b8I0)n_HuL1bSxU+0bW$dpJ z4(+hrgd#eVlTS1->=9`T7jz8R#bF*38wk>NKOp z0<^`oj5N3AJ_Pa(13NpvYfb>^97QzghgGvNN8ZeQk8jSp%CLHx{3|oL)@Od&4;FRG z<{rMi!LJGkb&M;>=~V5Pfd4M+%S{PxMN)*PjqigNg=#6~i4v$CqT$vXsKJ(lKCTS7 z$Y7P*9h;xOEg(6{!ccZLVg4;;EY%qCC<11>f1`63K#08{K#E2Eol04!-=-&j4N+!T09}Dq^90qm#+LJS-q_ zOfk3*fiYpsL!k*j3OwJhkbhm10aw1~!E|l02$!xla|goZd@@plq%UGCiu~^)??HQQ zi=*=#E3RUGf8sXi1?DRs$S_U*ENf}@x+#WubXyj}vRo25?pWg{<)ycP_}aj)u}Dsb z)pO?OH2xDMbe^jquQj1J+3W}BaI^^L+^J5FNd)fT3s&|tTq-s+@-P$L?}pgU%7^3S zg;%2vjq4}g)MF=8sBp9R*w>|1OfamLO05=>j%KAQvrFQ_ZKNM10$DzL82qSvACpgx zxcJ$x!~dP#x^>a5*J+4x@8va{8$14aCEzM^(&4%(Tcx$%0&}O;S&i_YZ+V~9n{k*! z3eZs_-b)c6Hn2D-vU)xOr_OhYBYydskh6Vn&LFd%+m2Pz%7tQTgt9WJ4_QA37S&|? z_~ZB62w8_;XtDuJLs{#k>;s?S6QYEI2n^J#jOfS-S*kl&Gch@z3(Bjcb{0tmU$ei&LZe`9fQ>2FeHP-i-STckR^DBUw@jZl!i6 zMH&&q%wcBn<7f{zpmFm?LusQmQ<+yKW5jaem%w#=nGs)<3SYE}av|QU9k;-74gWee zOH)B}C2Cw0g!gCUY;7AG8%;^VmiMaI)TO#M_pLAFua=N{$}cmC)Ju=QahlN30F;bf z4@YDDuUtIC1Qx-|^1Sm94D11(@1@Jcy*%`&O1W!a3gf`KOKavh{2t)F-)Z_IfG5^o zJN(7%+^DfVZ=q?;joX}0DbSYN0AN5WlHs3!MCjr ztHj;MMqP$m437usOU8tV>p%B8cZhe>K{ZoR-qJ_()+{}>q3XPwIHL1L|4nQ8!(8$g zX1Wy<*WVJZ+VzY=UZySRR?h3)iS?azw)V$tj;Y#35>j0#o{c*CGfbp?wZ#up-=$%n z>1N}{U=%#kYPD8qZ)3lvzRLHwITug5Mb6XLQ>rjCX$p|2G+Nke3mIB1V=eiKxN9`- z4T*8lD81v;g{n0(y_Y{G*UE9@yI4l915{ucdQ+n+#BACLZi>`Zb=WIy|Y%O&Cc!5KZ%k=>Ai zt17IM?6q*?5dyzqeKNzvHmrTD{?9ytSHx#ep1h~MS>JXMxr5VuazsmCE?V}$MbR0H zP%m>1q1;Qg0UW9MXZP{e4BbJ!vxX}Fk?*Rpy(-nsy^WHlXv8TZg&E-OpM_ac8LR^P zRIf#?j9G>kz6Lywjbng(-Fquzd?2yXZY!Cmwpbzj@*yJC*pwUBXm+!i=h$;Z`;yq3 z^%dZ9MaQe1Q;+w?@AG}Y`FxO?0-}1!d=^rL7#($@jEP-<7E{o|h*e-6-2Qqe5art} z3CV%D)HvTJ`XKMeq~nx|7PD@APY5;X;BXTEWp=;ob%w;$gGFI=hC4>_eJRm0Hl?cI zR{kY`oKj(99rq$@IJNK*^#X5UfU9-CcR-5h0$bDIH1hRSqn-M=Vt10RPbp%Ftg@;* zAz(O>t-;2XDlH#Nr@`_r0#WFhcA5Z)cvB~N66O<;+#hD(IDCPV!zZ%ZcC~iP0iAqe!d0}DOQDu8{}<|rg2?~? literal 4149 zcmeH~c~sL^7RTvgS*)@svC}G1Dz%nG#tH_MWeQ?cG%1zkhk=Bj3y6pj2wOnnk`y$p zX<-lyOKKU7zz+yzH7q$Mrf3nPruCenXTBnXV+(DX0HP;o5dR@&&8(WYLjvJbbpY)$!>^( z{BlJ(;=b?Raeg#72}d57xqg13w|!}8>0p^=k4a&9dQVuQnVB{Cvb}cGhZ|$+wC>&Y zNlLLm@%r^kFhA=yPW0h z1$J35EkN51C`Y;j+H=QB?MRA=EvdT`qq5|{v4OO!!x^nt<3Exg?UKp`yx zv9tBbU0rnLTQ$9`K~3|jj2Eu>EtB(l@z&-yx4SIPJTLs_vZSs><331bN{IKTG@Z+P zytp_lfKA6#lJSHr?5WF&;%D2qX$j|s+9y^TP6OsOo;#(pw>E+6BA!lZN}YE&NRN?L z!O67^qzXhz9Fj=m>5mF%vjY@tmU^NGZD^8-q-!NZ`s@p9eB>)}nG}Df4^kC};50;g zWNs~N55-n-LS?~tfUN6-dy_ox#TaCR4~q61#vVpgZD95D3Z|!* zR9WuOfqsx+XSxLrBPnRWZ2?3NO)t)r;*Zk`^rP=pT<{}fqm9P_Y`Y9jK_Y8bs8X+O zayg!!6DsT(zZ(xIG~3|0(gP^z?GmrDBRjLYw&K|tMI-Uk8zFg2L;KpJ38#zAS?h{3 z@_t-gR=KU<3LfAL4vS^hVbwfNN7QW zQ}1YwU^n@!h)stFsj8JY(tYElLTC4aj>T1SH#sOzndlHwi^c~)G%JiaWw0G$jpG() zpM3&!Y+HA-_XVmQ^s1T}vGVyd)N5oa`VxD`#0j-zR;Q=CJT14-{K1wN&s|joAz@>Z zmNbpAqK8qhfW%jcZ^yvm$Q zyScjZ6F|$4-ti{br79V*p$Au|-|(|}HSsDW|I^2CNiH3em-Ku5ivTM5t8fk};m0 z`v6%Q@+E!tr!fABp&tnkW%wzI^LV@axxS9x#s@~EcS=&U6BL-C4!FkCuQ$m}6MsKW zsz#8u1|j)*6U{x$p6;d9h-h!4H@p$$t*lkFEahI|>2oDZL3&O(UChywd{_0KK{>We z`EX?wJh;Zp^d2QInx>h`p0rPJt zFl%(naDZUrKpJ_pp+NuW3?mvM;asdt z#Fv{Q;MAZX$;pP#?m9{Dp+OBhM$1w(B6OC_Zcj(*(u;k->L+ci`ZgyNvEHz(zm6|) zxt8{HvD0}e>5YFq-R~_7ejO|>g67q+Ffej~b=U>BaPWtPYVheI10_LKred(TLee958?r!Om?1L;E+~_^^;dbSZJHD03g}aOFVEgULzw)Yhwp@A= z<4boZ$ob@*&0qxhKF(5Q^$p5u;{eMh++vTxJV|fAX_Pgd4IH`b^ceP`l zoVT=jS`oZhabK_){4iuav{XInL)V@W&2?)V%0<+QeSpFXQpB~EU}FGQIbHjPkUw*= zVha=;ES%c_w#q_+fkKlzQ8>q~Y~YztsRq<$e&5sR1aWL&GsThC$|0^0xe9jov2R0< zoPm%w@bL+gceGeXUI!OUvESd?K_ER=BlfGRV%YE|j$E1o@Dm zoOhy%dzjf*J+vUH5%D9eV>L(}$vT!A4l_-v)TDEb0|8asqs+d1s!wJMuMf@$@2}JA z^B4}z$#K`k*N)5w0ZCpALeTaG-LW6K+BSSFlRRcj90^A2LR(o{J)bm9RMzL+=>Gx|&M3+xlbAh~vRT;TWY{OOqB8*lw!s&G!1^c2)UCp8pApa=@nm diff --git a/vignettes/Figures/SU35_ERA5_Y2016-1.png b/vignettes/Figures/SU35_ERA5_Y2016-1.png index f7cc1186da16a724f139e48068f1034d0b3874ad..a48880d44bd0fc1e3f2afb4e0db40cf6dd59fd23 100644 GIT binary patch literal 8124 zcmeHJbyQqSlb=8m@&*eq1PvB!26u-rxVziKCAbC;34=p$g1fs14}*Jv;O_3hZHM=E z|J-wS_d9!5&Ud@-y?uXm>vUE9x~n=^QCM(3|IMd^ zhAfU&g%4bQ4u|$ao0@iHKS%iOpY40+oJ&O+QQ3qCy8O{Tbyl&BlRE;mr0{B%T)$Tj zyfzw!IGrb+HP=C<_>SwY@9!wxcKYqxYN*oA8#do;y3uhT zDM&6T6GZt^en2MoM*5}*g+}y ziD9K^ET(#-#$2%bmS_wlvT|jjQJ@%2hxQD5MU4yOv;yu}w+93*z}yHUrp~!kw~II$ z=xufcC1880Tx})r%Gr;op7G7bzp@lFO*9l=!?_A0g>?1K-)}4#T%QOIh$=`xJGe^*{BCY%n|Gm&HcQ8ZBgHF@)a320F?g%tJ%KVU zX+aX5U6?{51MSj-&p(TgWS zd1DG0y`Fex)6!T8b|DQDB*lHRD##>VT)>RahrusucNY`LprD)^l@j$edtH}ZPUx$Z zBEQBd+jUREh+QJr-uW5Om2(QBJ9+AoHu3vV)(R|@mddM5UZ?EYQ^Ite{?Hi>wyo}$c0@F-T4Q(Zzxf_=B$1?I>oRhmMQ1Rpoy*VwI zRl&9Gz(U`9gyI$%kt|8%a~>mibXohV*oDlaoaW0n^M7rIp!dRtMY%k{IyLuhx=h+N|-bY({Z?efmN9$(FqwG#yJ{v={Fq*X zxEgmPxjufABjL0K$;tHF<)Zok`k5I!A9CJ4;q3Q;(IzDybzqhC)wQNye&H6i6h-9O z2~)2%*Spq@hitm3734MLV&QfdccuBtxRo{3S=`(U za~8gj`JK1jfSI@>j1IYpww%(pjw+4l7IasDJx~^_e1yi)6bvcBPGw;|RQ^E;KH)%} zxr9FgqxdIaqU{V{~E^R(dwicV`aO$Th_Tee*}PG)9h%HZ59 ze~7JeBoERAx(| zgYwZBt;yEM#7~&0Uok>75#V z#|d+xC-J2d=S6qHQ(}^fj~Z~UHu(cXMblu%M^(E7;_2Ql8)Md}{#WWj<6sBM2 zE~u>Z2?l#u<^s=#;#-dcfL)mvQvTu5p=42`8FAdAS~$h&j?Tqt^^>ze|2x|zF9Wk zYAXB5HQ0ESvQ|OsRV^nB1-P8&0$(mXowM_Lj)2xbK z2UE9f_CJc_?)HyyDtO}S+}Py7Grqo4E=j+pHlV%c-sh$?t>jfpY`bR7d@X66AJ&BC z2Sa; zJk6DsF!`WO9v1&xOebdMYz0}%(5NwFLe5m8EXdvSVHTJuG#0C`ODC{E8(yC3@O#(9 zlZDIML!4RaIQckhE?J9fdAnCTJ~O&i^3S`|X8RIq@#N;!bNoEWsxo7__|jxOYKh_P zEd)gDk_+$XKisZyzS(JbQ}Wd=j~0cGC1G>2K~;$FW;3S7d&%9#+2dp-2~%s8?)7bY zMzVK`haTbhuM~+uKgO~3JW?DcnFuk?nX4({2CR~CEtgdNBa6$3u5p6oVdJCY53Ln= zf#!Km`K-A=!@muy;iKGKrxLu2J-$@a^z0fh7QhuD_%cw=B<1NL+UTf4s5hK@z(m>~ zPfa(GSopC?JyL7i#d5xyN)Hp2A z$j0U}6lTgt#)+ttXezFuSYV7sEQ_Vj(9!h%RH>M@YP8mcex2q8$y zDe-6RC7F50Bt7GLrweSBL8j|ze-{~5|#4kn6%e>v+BZW z{O**8hsrQ!F`CahbiKE{@TZHp4#nx`)G8_r2xa)ppCVmtI0B7%HZR>D9u;n8FoxFf z^C2j5`T`?v#@8c?@jX&|mn$t}7#hBB?ru2RW4u5cu^S@uk^K}~Ne&i7E+0d+zV-Cr z_RlhYnDMp9m41aNrv&@q@vn4@d0|uK&;F64EdX$JulguM0LbVjy|#&nqNhz>9loURtDAi;sCobm5eZ z1WBD99!TT3u_Upyv9vjgS&CVa&|pLZQXv}ne;)ijBMm|{gk6f*Fl<;f!pdJsyp}K} z$xK=h45a+e*MB+$Ngsh?nFy{yA<)00h@f1F7AQsz%X-3|gowx@gtR~~=m}Fs2>(?f z@gLCrCuRTT<@!&`{?Bdo|K*gaJ`8&te2<{bi9~F8@~7w`wm)JFMgU5P@n1{zNeD(H ziYMVy7I+dq<%GWhM5_1;_Je_QdZ9vxy;oy;AyNMdIFukkgrgZG>n8F&Uqjd!GlG|ETuI4i8{Q%U!$3EeH2)5f z1vH*+S@U(J0fy6nhm>*b`5zoMM~{LZ4nrxw?*AnBJ@@8~>1Ex^#PaEskAf;o0;R~o z%}`(q;3~`ff}`s)x7fJoK!F29Z*KxT8!3PH;@Io)ATdzSBmjhzpJ(rdW*N72zS;Kv z`dJ$T%+4-RQr6*_d0qt>>_;Ei%PHqIHxDcgghZ2HG3*$E%FO`-NRqz?KGUU!k>`iL zN=b$?MMNY21rcYTj{HVGh{xJ_9Htdo<}&mpx38Owf-ajVQ5)@=tahFIO2nca6A|T_ zog21>4FmFPr0KBmB+2dbltudy*3dvof^4M7?X!F$si|N;XgG$HP+A63CF3HY%kH)H z6q8$LL=JVdByWHFb%x?g0R3oc&y4qqT}#d;V-C;1d=ZQ%#3G0NaI#UNqi79l2~rh_ zsn*M9ZsXZ*u+~w2#SeZP$iDO$3w&GuS@I2a-;l6E9$$zi2Qq(GaG1@YN72@9168(1B%)H!mU8UZGGr-~O*`0O3Wvm^O3#+aMw)S=+_Q|X*RSu| zg#i(93^>2QLSf1zbu_N1&ON~oyK z{6-D=98`1rg_dqPnLW6{#!h|Q@o+*IgnMi=Hn(Z!#YPwt4PCzVpF_tf+!vzYLqtx~ zRkwB$oM(9}HZujA`$EgUtf)^ZTYlEcNM8ie@#R}0MVKELq9HfD;!;D1Cl@AJBNPNh z#!#bA+|z#}a=#TQcNtFF{hPU~oU%&Wl$(^5=#7Hp2eHn!o=PwTD`B2kH1S!F zbV^Xr-eb+^FCh?%e4|jufp9E=y))Wdw|v z(~}k9|L_^!i(bLg>kWy0lC-EOr6M)}{9KY8p!_Nl3dng)_OvjM4MqbRG5WGW;$r&w zE+pUjQCg)`=Eyw+=cNo)zuL7_oANbleYIO3P>||L7j{QVSEmQZoKnLYV#2F-vMmG3 zt2TPBR#KCYUI@O0R%2*2$`~?uwth9_^je9BI9;(&XNme505gN;a+rHdo$teq%GfL; zkqq{6v>WL7AIf$h9o=$r(@I|BO3#mD9sAYQ@+#-@?Tb#Vlkf~la{nm)HM4`lLzwep zst8^wV0FV=66^*J(-<1uEIlcvwqzmU#z?B;%H{y1Ri!)h)`5vXw3*CZhTbymo5`}9 zR*_yMv6xN#b}`}v*OaLouo9KeRjt{F88n6gT7QxaZMm_!>lRYErot=HA>Io1Dft<~ zKri*m^z-B<&sz|u4T-|JNpqpZ?Q;}_2}~}i#T%*HoQSh|^-!2t-45`=0KJ1d;wAW4 zYv-UhZzi{*chCoJUxJFGm1RD)1UPPX6(0TQ|PN#w*Y z-+MR9845fu?YO=q{b9&3<~TDJTYrW>=zPV^Y?ZHFne*OHVZct@Jo}y+l!&aigEw3|eq2tos^kw}07tj@JwKl=**&b-}@=|UPOw6UO zdU6;D__&DAJ7-PT!vfpj%#NCKd$)F;Ci>))Gg|&GL(%&1VXoztZ9{UQruytYZvr5V z%VsjJWR6Q|`d~P(l9YQtImoC%Y9)EWrXA(jaz{Bq&9!aH$7c~1Zfti!H$6GAW_646 zNkKh;RNy4b!L6;{qfXZINDh!bW*f7~`N4cl@6MK*b8$0*QsMpc){^N?X6tnSZ7xg$ z8QbI>Cwcc}v}2dPDx*2rf{LF;af6K}w1Iw3-XanyP&KgfZCZ_MK9r7?hN625^8&*o z?b9pbY^mr#9p~(eFPmnAIIsO;+)22RQ;Ip*CH+*wWfngoQP@i>u=+>xuK2P2m=S;? zq`KrV**A!+{Ijz9H8&Rwm;AXrHs4x_!VV77zip>&wayiodIxHTDzUz4dd;0d%;U~! zKE$`+bV}hJ#RJD@M5)N^2R(eeWEG}_x_GWfOC#ZK*Pdlh<~HuZlAu>31EP_o7e5E$na=#3u=Mf=W*os5&Gu5{<}$!* zQ%Uj!B*cs<4B+(ya+od?KvJeFW1s*$Yi>Yoj3Q ziY}0lN%!yA>1yOy5tol%#5Pe&(as+=*c+II)%1o1h3YVv?}^Idez^HFOPnk~IA6a8y##7FG8}OyO?c>$Sli)r4 zWI1K2q=eVKN7A<;@v3oK?5suW`XTQl$1i+?R^xB}Kg+NSm#eiyTR$sBL4B{2kHx8! z4^dESPK!@+ogZ3aQ?AcPIIC7EsKCy88`xF->X0|~An}~AfKkVU0tLhGQ@kzB%ALBt zRh%Rt8e+ikUVf}J$hTUil%Vg2UyCN*!sQGqCfV+13>dFB6xhNpIdH)smbf5II*L^n z=Y~KvRbls6O?$@jhGo>SLaeBpn@b=K=U6n{Li5d){vYDG0Xn+tVx8Ch!8f*<{f*3; zSd~C=?9CGl4ltS%!y4n_yj^q9fdZFXQ8$}@wgJ8=g^~0N)Q@}acUn@R&aHoNU7X5H zpKgdNZEFo)y|1(Kj3qn-d#CfOuuz+ILqo6)uoL3(0P#{TY!D4A; zC7kTMIj|3W2Md%I6HURwdQpu0t|_JTqVz%!t*5ei_Xbbel#?FJ|GmpDK&IVFGjS$% zZKm<&;03$;rZ@58aXQ|_LT)6T`!CyMvqf{4&NiaIw&P=<`FHtwhFO*xwI@ YXRnRxGO@drFrU7q#N z;zicC?d%>Tw8z(C*+p16%lc|9%kJK{d#8IlGiUCd+svIgGq;)Ff1Y>V|MT&Gp5OC- z-kJBdr#ntrQBzSyMn?It%fVwZGHZa33nh!Zxm|UZj|g?oBgYRR@&~j!$9Vh7IoH+V z`;zf~sZ{z0S2Gu6Lm|S&FG@xR4SrnT{M8{pR7OTcP6Hr^Gr>Z0#=;-_rqvUK+hEzgihtPJ-cVBq-QBl01fVIppq=rJtk zqED93UKS2nPi0b0l!N7kc7=2}gRfVcgr>~K@+bj7st@PxT*0ak)0p>}0 z53U^1Zw8Io`V=(w{O|%dyxw&13bky$T6?f>A7smsObXEHn5-kiddlJM98nyJEii(- z^)4oP3r++n6*@eR-&qdT>1*1e!tkjx!9yiOfdv*I@sy>1^&SY9=8rvAS?53)83`T3 zbo3R1?2Fn(q|HoG(*-vFO{sq*X=EzM0@s@5)^=u3Emnn@^wPSHK9jB+i!)m^gQk-k zM+MX^Om5F4g^Kqbxv*>iN%)mC*Ns<0v`WZ5^#Yc7vw5A)UC!*3567aketsRF2*;@~ z%c`YTP=M6VsZpn|iQ8TB_Pq2>cW?vcR5-WacrdfskQ5It_)NsFyziaccBXtXzI9+n zLr^{Xm%ZJ123J8XE%eV=9|uYNo>8S&qGCrN&6kgj81RVIV$*xe0;nJLC&Z@Ev~d5O zS5BG)2Z${fQhR-+o>zis-srOnsb>UMW?iBL$7wJ-r( zDzEDwcLZ9wlA{2Q(Pcbyt7$#WKWCm_VCo-AoKOIXfe;g|#lNJ@+S_ zGaCe~SQCxc)BQ_KH(#Q@wSOcw93XVkZvgp=6-}m4558pqPGvkfj09Gou^Np1L|H<0 zoy3Z%iR7G4zVa{lln7pCrEhBhm9?AO zUfIZ3w6N*kh!AMe@U6XK*dzl_m53G>nODZyHsXD~!V8t<>zGp}&Ny(|VgSpS1)M&% zMi=aZuA7$c2nVCCl6a;NJ6AqH(~M&Omy6^I)_G}FckyXd*cP&R9I>yr3^R5%w!TBK zost$D(<(eU!2OT{JDarQ7<&(lIgW@>O545w95fF*e8U2gTXNFMSXo)S^9y|Z-I-?k7Yrx6sGn&`o4}*JC_5%d|_s+Us z)xTEeYZH9E9{V z3pBy@mOyWP$oluAyh$mnUl)@7bhcUm74(>sZH3VM0@fkAP1_xKUsd6` z%ym3RAF|-bK=0ZR0A2o%?Qt3*T^%Gw`1b79V0J+$-VMb1M|eq_C-<3K6J3b(8);Yg z(fsS5;TdKLh*2rL^kVi960wmcGAY{8yBnGHAEPSqoPiR=|KE$q63_@YVafQfij16g zDYpfU1lXjM%qR`|L_tMzqClYb+HJ%M@j6Zut-gN>>mYO#Z(`=WMDg_S-qUwLv9CI4 zk5~lmHIjI|KQriEk$kh!ZDa#ta*A#fL`S|dpAz|9arYnljYS5(A-T|L-=4#H03>7D z0fpZNO-@zARpnRkAzksRI?T?yH)AAsoQM~g6OD@bhJDZCAG}`Z?+!Pg>mbtX zf3du6M^01=Ry8KeRiwcp%Sm!#&LpSQgiW**qZ7%3-m0YNTB$2=udjhxV={N_7S?Zl z21;qD{IYZz@Mq(IrR=8FeL2NtnGbNN~kj!1|v zhd^;I_|cr@a9n)?%xPLC$bt1K3j#$NL2H7iP8L|a?KMR4!k?7*sxSwvg45z8-)-T+ zBC5m5IuwmC#`!rfdpcO|r6`@}IU2D&)wtCncYvS$9Y8smLVscPQaiCC;60U0irlqc zpo$61aSoORF8&liUx>D6yz#x z0#%v0a06Qdkq=-=7*D)Lv7knkc?67X+-gJw>YBG2#R99xT>ud>F_PgApd4vF)zE9B zZeLSumU2IP%)_J1mR9phQe5?Kg`~~)vleDn&I+&Dd0k34NM&!VsZ9&at}ZdmZolJ{ zA$C4J#+OXZw-Ey)@!LSLu+?wkPu6%m*48$K`-hyu<`*ma(29;nyq+EY z=X`#e5a405#gXIRo4Dslv)Mf{cyW%Rhom}m5w4N0#yPoWBnw-%lXkYP<4t*RJXjvo zu4?+5xU}f`nF~)>J3mx+ZNN7+D+^OJYaUw|NiNIICVocA=k)yZ`JMDWKA4ON-OlK=n! diff --git a/vignettes/Figures/SU35_Percentile_SEAS5_Y2016-1.png b/vignettes/Figures/SU35_Percentile_SEAS5_Y2016-1.png index 603122a0e2eb29ff2dc47ba006161b3370c0030c..4420d1a3c844a4f3dc49f06a026e238adcf12f6a 100644 GIT binary patch literal 9212 zcmeHtcTkgUmv<;q5+F$Lh@gOkCWuHcBE5qUrAi4%7wOW3fYLhx(wkDGNs(?qS}4+_ z6N*T$fzaVgp6A<{@0;Cy|JdD`oq2cX&V65Z&bi7tzwe)z#6_ z(Qn_rEdbMKYHC8E(4C!~>FH?;5>V~?iah{;Q(g73yn*-hmdW~;%`yt7ccEkb)_P&b zfkQL*nU)BrKWeWY_BmXyYlVc6gP4~O_is^>5aI{R{g*cgb7lSdW#eOO68y#8ob1wK zg;tvArui0Kypldp+GQK7xD~oVUd)B9bKmmCv(hgm81o0ec%mx<_kMuw4vNpsT7C@d zYS$*sUR~{FT`o-=;4?r@NIpB|3AKx!jA~#w30hu{C>5i{JRJMAS)Q?!%5h4ku6&Z+?2U zNNrwAKTyvDBAzSbYvCRjrYq?-RAf-12EB*N_8@+Fb7+RFQV_IiCAz7-hDY|rh$Sko zgXr#^!oA(QE4a{$z^L&U@@}4{70xY5) z0}pifzH;9uw@~L~)#r_}`|)|$r}ns;`q8CGr4jK+&MJhZ-Bfa~5u~xhRi!f~^8Be- zFryB=OY_)z@whnJ_XQ{;(n50%*ebxs-h#Y5U)r?2eknq6!Jiuw-NBPh;a43zbZJFA z;Yzn77=02{CYtB}kQF7|(Ioi2K=#wSDZKHMJbV6gy?hA*O$EB8KQU7$M_)ZGcb~?< zTf~@unni~j9ZS**ci8)$GL7`xu?+6KN z4nFgD)viQr?gWsnpUt1hmCf^#`>PGS-hbb*YC?qK^?ehI{VW<&Tf3SjGO3LblT98H z3!OBr`~2HeD7{x2CgeZtm7F=DO0nceB=%qf{pYSDk9^?pnpv`YNJZOR{&?o+_V(NN z*tUaSz8N07TRj!F_NGy=bAa6T-pl1~v#A<^*XEyU!;#l<5>gtqtVjOHQuD-C&Qh1> z__4sfqV5dl4+jhb;jB`!v6VWypAhsd?sRlhAQmd1GXwy6;MbY1{V@ z@s3-HV?s9#*XyiKAAd<#REv`!^6&Kzyn(+3EYnRkliU`9QytRpEO0xx($#qan`lA$ z!e0r#>?`T#c!saN=~5V*6?!J;L?#&PMz<3LC+)~L76JwztW>@WTupu_prY2)V`H=?#8OJ=J`oW=38$aY2YigV3a!TZe zk{b_a`mVOFl(rSp7ak$U#Xn`ZEcpH1C6U|u1W~4M6z%BJ%q@S5tn4Pta`wz5~RRa)&xsGOWB%u9ew9e89v5x;M!iPDO2`s&dKEDAB= zuPizIxR%)ts}sn~Jg;c|wEa4TUuC`&-^cFTa@}))q(*M&lIu=-B(+tB&&v^5LqssE zE7nHeHL!FS^c{$>-O2H@!I?WI6pmkswQ>>-JknG*IYm_3ORZG3v%)f8>y5sJB{2$~ zX&X<*j^eLTV1L3Ay zB8QFpXay4s25DBuvTXb$Z48{ZBOlr@miI8RjJe)+3tt!oUFxI1t-1fk9!6-}F1y*& z^v>qFVwab*GMi2A`%&(|w67Mak4DJCocbU9lrDMJZkXA>elb<-MVPp+FWCcqPzS?* zLfx+kuYsh|RtK&52#<1hA(&XWXvIOq7R?(bN+^nku2fAl8=;LN6G)rz#h-o0k0H=L zYU4EwT(zS^>Em2}VmQaJHs1S@3asUUyHa;n%m2Eza#NceGI4JsF$aUN%FChD;9~ zSE(#wh+}h*vQxM9UblQ1QKAMWxK`I0?qvSj8C4rx3fLGDASf(@qSMf)2c4fp$Wdz6 zzD_*@49dnmmhXgfAfn{=64g5l$+m(V-b}p?;)mi)db>bc>$Z6$aNS9NmmEwW9UMmI zNgvovWzF#t|R|=bs$QHqZiwNGbE;{t7E%Yk^Qtd<0>+a{Y zE=o!8d`ur4qNtZ|KIu2Qp>htQ!&v?x{PMzr*kl=5MBdCBkF~=}%&htINWfP?4Mw&P zUWbEy{GeUqrGw_Z$wP6gS8GEz%|Bp#6UEB?XHtt-RUXD=-vlqRTd*kTwJSK++>$39 zBx|#aOPYN7>q)_^iwUyh`7<-;7Lyqg5VJI;3DfP=XRZ#(qI6~_h>_x-zD0R1*tIu{ z%q#aaEc&~WVaTgQf6I|QIl34IkPD8RT~Ir-GGk`S7XJ^KqJ6V00E`@Af@ajko$OQ z4e9TSAD_DHHLoEcUFP#v*K<4b5BH^X&ApLSUT<;*7+(oCc1Tt5{)lLP%;j}z7HqO| zJ6p>2Rg>oaxX1GuR0Lu@W_PQ258{99ze+ix-_+C9!SV6P`gO^N`a`7AW2D6OhvOu8 z?fuf~6`n+Gfw8tW!P(|-eS-#MDZB>DUyIn43zUO}nPKy1CV_uI)M4Dhw=YMi9==&z z06xF0k*#>ke?WCpQix=$Ml!qm#aBL!8^@p&xYhnyDZ9MeCL;)RJ?zZBULpVJEFmg; znlYT-aa)Jodf0LxkXUPL5apyhWbhQ#50kcW-UXG*Z#RaNGECx4h<{$^o=TI#Xi+&^ z?eKqAoTYyedH7?mvqr=Vvfm=;82{|YlFoqX6a1eXQaU=tj&XndGK7s%`9jTj=Ma#qw}zO_>gzfHJ#q0ma{eooKBbiuX4P^seE>WYGKf*bwzU zI+1-Y{Ow*A9wK#Ua3ohQ!a^ z#y_cbFE8ho1L*@ujEh$*ij;rGo`0uX{I9h1-`D_Q5t zw6BjKnhV?zQK|(0#Tu3$icy7pJKyxG_K{5Z(TV9{?%Kx;HjD4ub;5sk`Ih%Rw+s|p zX;&~MnQ46(oXmV)u=rlN02`@t!7(L;J3%vg-^`nN^4s_qDIEF)z}oNba_t+)9mot+ z$g1YAX|-@kXM0Pxb}LxU15GuzwZcLVisBqti7uIAUq$(jh6XQbIDg@P)RR|#xA@_Z z1VK(zg}PDq((f__{#SVczT@6;j#;6<{d3DQhAjR6+J_953yLi8zq2im&o;;r&vs$D zj}A(t{EG8xsmnum>+g_j&(hCVb=J4;oiIgjrFb5uu#n1L2CGyHI^PydTATD3s%qSp zdkQsw>droIfCj?m{0?ZRL+~Fx`*Phq&+2>!NC;q{l?tEJ)Sy9Iw_f`>r}PNPY19?g z9-mKz@r69p3$s6oaHk8b-RZZ=j@5EQ)zY_VP4MO&sSxiRWJ=Ks(6yX{!o7rwwc(|XcrJ2^YAXA-2V`tFx5SsoHCPAEb% zQH5O~cKSJXd~{W5Q8A~fXTT}A%7cyL$lubn`{b0F$V-?FXU~+VHy(V*`?mlpelbQn zY?#5z`I8TW8R|jP~N+V=k}2XiY%LjAdvai;P zG<`Z)S~lr9e_0-}>?JG1b@e@3vqiA9WVWqEW3MOxQu>OW|9PGBRYm)Gbx+BwHdFAf z<)I_k=c(a}^3yFp6sKr5k~LzveO!CAX)J+Qj>LwT#k!TmZacbNQP z0Q{gEGk0a1$aCSd%|in>Du)UD>pl271L{r5horj6KwP8s`NX#&2&V<<3CT`fZ4J@x|L!Ct&cJV`tSI(a&I zasQ-3D?VKwT^^jnsx)deYFJNo8m9v0p3p?#5a6YOW2JgLI3NmiurInQxi~!H6tFLk zIpBZ60#xFFQ^EiF2mIuq!=Zu01B)5fe;fi-IM@G^!v7giw@x9oa8y#lF$l{R9F=Hr z4ARBQuvEgya7rxYa7vEjdER+_j6;D9;uqpKXn&&KxL&Vbv z4A#F7Pfh~@d0A8~tH?OGn9+ZCvSLvn*&i;GhSS6pxF&{Drod}O{u(_l6H4h>NbC65 z7Y{mx9==T#>}p(a^qQ2k?y~_+4)`(;#ET=e(tJu^o&(Ow3pt=vxL;F)J?NG7PSy?y zaW)o8W?*JAY;jS%gy-#{a(`Z7qs0;!xQGe(f}QW@Xf}4s|C?w3X4o#MX`aZBxL|sS zP{cC)wmCu~l_U8!V4jcCZ7~KT%f~KY76aD%z(QTx))sz>2aQuXh!a&*(cboUr%>zE zf%Qd!i-CAszRrl(y*KJSNl%_K=<-CDxzY`hrHYpPeL|mE(a>c?$0t59YyiKHPsG+I zNr&lq$`~cbg8(SWs;uU+Ix6`RJ~C;j4lIn9#GzVR$HTQM8~fzRSy$u;B-DHO&Eg!R zeNyQNPpFN2uIP&ufzY@V8Z}Na^RT!f-lQjvH^bwcc$2aU^;Ts>?)I(6X~0s+RJEI;!R#T8y7tZRT$rWL8VA%bYLd49(bb5CRLs@1ZFXGMWyy zrz;6Hjk=SPYq{)_*vZ)(nGpwXeEAY6JyXvcDVOq`JlubVG{!2I+7^UMRK5Hn4BPf` zHqFLE)>rQg%6Dn_+Lvy=+EgN$f|@cRE)qk?(ho->21T|LDF-LA&naWFS*(8+Ox%-V zv7Hz-5f}V17@lo3Dch5yDp)RZv(0`NR5O}A?pXia$P0YmZiL=Y5Rh5x6})eg{-UkX zJuWw)H3w=^5oLe(Uc`>Fy^D;v%7{axB+_~i90&bUYNaa})cf=poNzdu(IMKaK(eUQ z_DJ95W|RQ)A0r=<@QjeC)WZkmzf?(dFJ&|gX}0zGA}AFeNc9-2n*R|3S)L42>5^@v(k+4N|p-`->kGXcC1IK zb>Q4NP4kM#_ZykPnXxI8*)Fu_#Ehcrg@u{wgGkMV+o3Hhrk1w1jVqF-CQzRhNQN(7>tU&%Fg}38)~S>$lrjN* z{U_B4zB(j_9Ay8VL|aeHD6&3IcD&uU?bHS6QaVEO$j*eVvDF;E?{Ax`naw1Oqq;c!-t_? zGe>3OOg!rj_a;u^W(Kpm4aN^q615to$cM0jhhh`i)lLCn`$<{OS#5lvCT4gB*P$9x zWMJ#S@QpiflUUA34K0*@$}`86HEer`44f*Mu*r))u)1$lJ~9eJl*K~Uc_9d=88mP8 z>5Hp?LB}X2-SsIygw$;L$%#wNnYFRlvr!E3kJJiSn1OG#sRN&Oz1w|*$t)mxyJ+(3 z?xM+jg8kUaHu#xYr~ujLLz74%Gf$cDA2XQfu>5@;zCL_*zqK`?RGk zZS=Q9&zLGF28@a+_hn-c4QrXBa z2;1ow-`27vP_$zA>N9d}RKcm_^?!DnfUx6Z&1ODFv8Rvs2mGWG*vjSW9l6i`w0IQQ z!xSx7@sA{`hAT}lPczhfi#%(b-5a0(KBlRY^cod15Z`TvZ@e`)E1w={T-3?#jc9JG z`TPysY*J}fOd*+gfh<)3e~b^P*mSo!uzNJ?aDCMrDW#Rqh2>P!6}^B;Axerd0Mi+H z|J%7&rcLp9i;J3XNr@mo)DyN{AJSbhr{UPVg6$SK+uU8bCQIsu@;jN{z$6@AM*O0t zEJW>MfhLXot{*H}`VGAlanR`41Yak8HzF&^T7*O<{@VHY^H2DhN!m7yeT#M04?piP zy>EP@gTJwRBM~_;iJc-oQVLI(ss0|C@Ui_^%E= zLLz*m2S^S2R_I3iBj|^x}akE}MEWDB| zze+c_PBRF+?!#vOP!P7<7&Y+T=$6BtzPO4 zeu6zlscEhx1R?x)8>7M$fZP?89O84Dbl5TW@V2|!*fqGzE7LeWUOZI<@_zh;Sl1c> z-;2enmEeKbG;iys9S|!`?C4N5Wzo^*nNtf*(FvmPr;B=SAQ{{YNTat_U-(ltOhNDl zkoRy#Z;f3sHx(aFbLPZ*p|4I=;n22CXbzi7ykLKFjXX9J6_GAniHj+ZrEhrKo{aUdxgsmR1o#;?=*x7mZqq?N|D_MPfy9%eOyS!ov z=^P++aG>!wz+mHZyg;chnDWaoe3A-PSi;dumPYpBEyv{frKpIJ6> z+vM$KfWB9$G!=SI4y;k{KTIv|4LBfHqO&Dr?Ja+QLnq5Yc zgNarB^3!{AiSOtV8OOmqVi6i4a!eHii zBRE2?j3;=iDfjT?-UWWa%+wX(0rtk1YpPv~gc{eS0OxuNo0MuP5C~p7IHSdesQp6R z>Jgr+>XO{JivLW47nh$UEntjL4RQENK$DKGsShB&T$46H7+U=8TfVkpYpbg&-buVg zP`%_4XF|lGNodCOo0e>Xojv>SBK;>f(B&8gMuTpcc9x#q3%r0yw{~%|u9?(xaod+N zGzrfaY_~ENRXofZ4D++{8Kix89!8~}A2}&k1=_7R|H5pA6nH7!os_L}V(p%*546qQ zZ^&|%ZM%dtKY`5?F+Z|Lb?tvVvdW86>WVJoexOrcx_{rdxpy$phjh9n^89z|Jp}L2 zYYb=eAxvHC23(@XOj2zVZ`rr|^`;4oNPfBPb%jSk*|zz1zbZEoZ?zDRt?9|nehmF@ zw!KaB*fP-vl&G2EyFsVH?`igSZu5Ww6P9$cBMJBT6(O(PVnjK8PkSd?kB4p&g2(=F z-tkG5d}*^7dmj*l25d#H#NILar3LnlU;+enUU8W0xnRdPO7C|cbnUUF+DesqoGugC zor$K6Y;XiftJ5pya{G)sOZKZKcp_mZW~d&!Xl$`Nl@O*MTr6%`dtcejJbR8&@>-Z$84rRK`R(?VsZd*ra6i?T0Wr^~f4lb-c> zSM^W%_@F|eSnFZqrZlL=xdok9QCSDPZ=XDHDnFy5qI1&yptE0M;S6W+#L!cnL%`v( zG%;c9=REhN%#4$|@&l6OOtSggy*VU4zbg`Zd`>d808o?D(;2<#|{URASBP|}LD zV&jP`r}KpVA{ksfC)sTkZJB}+rKOA71zN>Ry+v2KcZ^ z54nRmYz)Vr<%p^5=tOI9C2jsI{)iD%o#NBpRfmn~NhL5l6)WTOg#%Wc+(mV7Y<<-J zyOM0~x^JU!iIf;B1819Ww_bS#=M`Q)lp8!ChD6QALi(VftE&!QD(x+K(rdX ztEbI)f7Shz=meB(>tP|MiDS$a^zsMXQH&U4vA>C-@E-0=N_g~I>(H2)DgqLGvvWGS znRYqCu+D1_uRyatRbG?BC=fQG34%DmT7Hi})DcYUCIowNaX03m6A4?pEcxhlSexv- z>`x)NL@y7JR&qZX$&D+l6#D-p5aF8_7rbR)wHDBYi`H^i!Hijn_0vOK{ z#K`KX5lO;D!JHs&SY%sHniZZvkku){!m07uj6FDZvJYoeBgZelX+r?=i9<1wSy`{c zn!80wJ!VgJM|H9};zxEk>O`+d3gx{S^e&Fu1`6*8T*VCbGUs9M2&>4<6*=Uqh~PY- z9c3YbRu-8$Xa*tW!abddYdo={YEc2kP-~V0HHZ30Km$rC&kX0lUS zJg0{8XLjNY1j9ZD@Cs`jZGj>L*@3k9599(ObMMfbaeoGT=xh|>?!gC>;XjAnx3*S*8qp%(xv1l=gVZr4FG?*E&gO9 zNnXlOd~Y8toh($N&|YLiT1$Qwj+&ISioKvHJ(f|AOV>Rh@2fj=Ftl@+gs=YSF;MOS*Vc;rvc@$ z)J7}rO7g#YDu<3L9#!^e@it`Ecv&Ua_AcZYPFEaH7HF`Cs__xTxM?25zt)^1&0$Y6 zZ$*dog?OBgRXBEzMP&pE1Mj0P~iXepBoua_n|+O{mdKee{o;R5X~w}>1*vNtWhHzq(PleWPqCR1#Sq0ru!t>+R+a!F^L)Q&2D8X;g+CvjWj z9~h8KgbxTUlb^Ln`4|(c6YHOKt9mi^4fl;5qcZfn>+IRqZEEJk1>!j3#UaFw<{y1B zZbsh7M!8-1qB!fT9%Nhh@YnY|C4N8PCiqzptkbm&(?ksk)zM4V)(iPdJThSszB6eA zEPhg6DhS1{+q zG+hy?zX}-i?XmfkUR(Zg!pB|upHo9VLOZ8Svrzx7U}3+%F8#Ut-$ZN*LU|G)+Xs|g z>ABaN$>-{zm8URFno=5qY-_iHCVcX9F9!QX7L=;wP&F`cbNb5ND)R7`AP0mAh)QA$ zr1gQ=Mc?;Y_KQMd?wRA%a`b*`-QvyTK8E9oBn$5iqYv zcf6<6*&y0B8XpPtk1=2^nJb?V&VQ4${9W$3Z`PY5ozd0%~c4kVEGe{^7Z;A286^XPMk{ye;)jw-PG^&p!N5P zj4g!K-2x4IlEGxcXFzNA!oDNW+b@nMnLtf9Tt4mkwhLq-A8*`6CC zp8_*D+kR%Bf^vyW^b6J`UVqhyNI4{k^VyUaRXrNF@m5|XlxZ;Y&2mP`tNugvBFUMh z%`nW+bW3>&v{9;&Rrl(p!W|-j^7VW1-RP@zuWEH!?bOiZol)_6!4p7qs*_Kkg;sc{ z4H$S-h7C?(uDbL2X!Kt<2oz0KX z#W?+2d93zOjLgWPXz$hN>Pt%uefesxDH!?<>N+b-{Je3?`i`1Oox=*(pC&9*`Hl?S zW>ZjS61W5%D(nzXoxQwTqURKKjC7)TLaAwe*V6__)m zr0jzUu)(vN{(Xe$fx1b5ZLJ3k5}$}s>8FhK2)lM5q|mb6dzJ1oeDd4&kmE06gN1U!u1Cu~UW1IY@<}POc86pvrDhDR z7M__P^5I$?FAufBqIT0dnwMj#mhzX2s6~3|ay(%zpq;3(o2eIL8m`qWXy9zzrqHGglxlY zefKlR@$SEUrG_fiV4;jKTT_md#Stu&`ob-Cfqio%B=h&jh-PQR6p9M(^uj{&WvDB*_%?bly+lHgo2$YD; z)H9UI7D`*u@XQ#bol)#qkA+>_8-FhNA*=&-RwHYR&eH5%ova+(rC7|B`BuA;|9x3pnXn}SgWnHVqk>E|fkQ~dj9?50!H3q1XHot;de z;zIH*N60ScZ_gvF4FWL>l_J1zS7**ARa6%4pG_JH}%wjBUIOI_I>L2EyhLP+FdzD@kJse5d2JV^{dRl~mo;OKR-Lba8m)v_low~C5w+BLP zo!D)Euk4sFN>|+nk7%g;M)B@`AAWKXtt)*^JI9sV#9PqhV@Bcp&B!CcMcelG-BVb$ zA;r+`ohQM+-;FXYrLlY|c7j2*gaC=FB&E!Ersn| zq3-6w4PgsYXxI;4Aj@VdBL<^DBPP8t*(~Kb$-cCB_h4$>$}z8AR{w*maaVMBb5co8 z$_kw&YvbLt;GCLv)=B8zO=8Y9K$_A$W)`wHIWIfRS2znxfEVz+xbO4d@Nxa9}H7jOMC?6LcI_{~26t7OK zbUS>A5(w*>P-vk~E@u?huAN#iPFu38tm#z(IU&0oF|Y?u*Mdq$U^fCWhRBDlnNb_o z66g~D(Rp|;@`G&PG6hhiHf{Nu6J4Ya>h33`Ub=S~PqWN=9nLwgH3#W5MjBGK|He%D zexRQv=1t9&>t~ax<{u}+v&iZFnLhrcz16S`lvtv%51xKux4Icn3R3E-d+7k?xM7Vi zRk0(~9?p>tIt8J*T>3M8ac zdK{Z+ZET0u>8c+)Id-`pn2U7sOEidhxrc6c?>gS|-|xFTqj$sD&=ne;i7IHpaB(Vo z+zQL>TFmI~s{)34%jM7Lfb?TC`qfOiHKNJZ#T91NM&qZ=aNzubrgBkVy=y#+`=p?x z;ksaimc0KJ{ko$3t2WaaMrOFk^?{-a2zh9u58 zQ-9B0(dw_S;4}}TELsKxuqEF!QAaOP3l_)DHUbX$zZ@-<<5h!%VhZioBo&Q7Ph}Br z2fTLc7lAs1A7^oWZ$ms^NZRMD3~hg(7X@~ZDL$I`)XPY&p(b7hU=8|d_-KFYG0P7W9wsTd(IK;V(74FAFR zOc095;kNNSgqg?(TRmB$3eBC3mei4YUS*{G`%c_&fYRe2C1WRq8{sV(za1Ry3Y|=d z9`o|u4ef!MJhtboc({sRjk!BK{YEAv-a6>+En%kSUZ2Vjw;6Rl)YOzINi)vU=J7S& z7_OfK8ZB*Zu>>$7!8^G>-cm~7YEH4(6L-TPQica^(dAp*&{NnbSr)iSBCvG{csC<6 zGZHB@4}|>0{VqGY3VISLFfHa*_SH2v(LafWAEK6l@v^c?c+`NTNT$7(ogiDuFKHlt zA>Y~_QKb=WUD3D-9BpUSJ{U0{Wuz`R{0z+b72Se)*qgx{8n2A+?KFqq&T*Kyn^&LR z0SnPJdOj6f^5A9H2kB?Vg2$i8K{I-ouJDB*B1q6)oA%xkYTnKhU=l!By5CfBiigMZ z>w9<-1RvhJ3fJ)t$<%D95gjgCVr`Up>uBSrvGFSytuMJw2(oWch`<;wKu*9m@N32g z=wH@1nX)DVzmI%HQJ0bexA-XF(@+##-+EM}P zKv=YT8rP?^dtHVR1wO&cy;kH2zHevR>Yk z!ik5lH3QPC{L8yhKJ*If!4uR1c*dBeu(3%%B_HH0yq>|2~m%{Y7V=+-%4rIb-6V^_LV3Q zGJmvV>~ScVw#wJO7&mY|HbLj^kKjpXoPs(~(k3cucrdkCRI&gZ2quJAi_4cJU8U7GPhBJ=56EysN*%Q}j^UiX$H~n``*E@i zECa$PeC?OB8ihEu=mt-J>>Wx8;Z>s@?V7B)R8t43wttwWhJfN$BRU_?~bIA>XMpme#uk|I=4x`RLj1;g;9JMp!_tN09K$yiwZt z2i&DTWPCo^qc3B_kqgsTlbGz&S%O0O1wCay8DBMKHOSVr7}MMI`OQ31)1&xmP~re@ znZvrWF^Xu<36QZGY;P>mljdRAoNn9RawQ=p;1SBFw)~Gb_YHpnFFp-psXaS5<9e#< z@9o37K6-pD2pMyMi%QK%oH16LC-0X^Q5l?p$u>IR_Si|0*&qNFt)uD9GC#qaYi`Y( zH=}i3E9vhZOU6^zp|6hweBedR_oxlX-AvmAat)bZz^DcPE&k~eh-ATx1gHg>QSS_y z?+8$|8xKu{1?SP8zF(%vp-q>E&hp0L>K%Y zyYY_{|7C~q|D~V*NQ7Ks&(0Ug|3g98KsHw&6!T~>-_hho{rmF&e+`H@LIh_bnEchR zzn0HARQ=UJBL1AOCn6O5rJz>)FN#0de!k-VHr2lq?{8WD=KLq*zc2q%HN-J6)5o{} z*=_#!JNgec@b4{%|EBvgVncV7qdgJ87UjMs8mZIP_TemA{|1fi{nZ$z$*kgQ4W&On zalY{Id5nTb{yC`rCL>Yd|GMf-8+hyCn=8OddSF;LOn6k{ub|Sp{?vbVtfr9%dpcF5a$MhxFT-2kEa6$QS8PlJmde9i&EsubN&|g zg3j}7*J?1$uKuKdM%ROV=nvLX`SVa8l!Z@$o*2ZATQ~!7ZayFX{m$rBd6V;zt^Owa zM~YKni)H{E@cn{p){J(0S}syS+N4Bcu4dn+2K<_C#p4Qfu7F50T?n1G({~5e6-c)( z96*68%8U#O?l-HCr~s|^5zTNazykb$P)Yy80Z2o9+702rgC+MWMghW60HRUM9?|Qs z)Yc7R-%_Im07)?PfUJmy`_^iabvF_T-mnuu=*1CM(oDUz^ALk-?Q`E^7*vAwqb{|H zf$}`|#BBoa1Nz^(ss%@*0QZxkG>z=I+oIlAY8u-UWv-c;B!tXAp(@xc#{ev5Cl4X3 z&z@`tS2mO;)peux&2q#FV;y2#YkZlS7s=6r0k5&fQn9xgUnG7^Y3?#a@`0EBD7-~D_+Ap zlK}>J&GnKm%Oq?Cq|~M{J^Z$(0ob%!t-s$_uirxd;Is0e5J-zQmWs7)z;G_~dr^_= zM8Mm3EQub|k#Ld|<~Ir>8L^rzo@%*((3n-Yhee{@bfhZD2^*o_7My&_Q*{AEs+aX7mhy|N1y24J$?6zBmcDr z2ZMBY!5y1SSM^-Zo$Sl3_>}H3o9aLA_mUbNm@YSJDlkaw6-2o6%#_^Xv7^|u z5)uQ?JdYoGnWm}MPNVX0t&&0Ff`9F^oqZS4j9(lyTPMTSM@Sxk|4cLDHCyt}6;oZb zrtY2hHnOC||8o9?-$9Z9#}9LVK!Jo3n+*NM@MICUC^A3;eYh1B;3o|5h#QaqBtH(R;m3Jp^U8fgHM{YRZc_GTv-4*V;e~F zY637Kg+^VjaOv|#(k;OZCd2UC5AYUMZYeev4%!;Z3OuHt*c6 zfPW-7EURES4NpP zycsU`cSqD+O-~iF)X^llnv0J=5~&M14#;)n9G5fDFNc=c$rvV(2FEXocconQMzB{o zNZBD|_Z~dbLT5#iDrzHF$9nAg)+qlZ$%NfmWNtHCrYFHCa<-+3%Wq={t8Ys|_C zgUFbFAl~7n-_JRD_MvwA*roIm#?5btl`iHZp(Nz~sTTXyDxVtTeb{Rw7b*|j?h}S@ z0GV?E)1TK;=F@#eW6CQs;E+s^neMOX%LK9m3a6B{8elQ@06m zJ_cIPI}D%8jK6w1!go*2iV;87hs9g~w^gsxdH#Bsk7u3BccfGcPnK8>r}BD4?Mn>h zB_yc8MVhHe#jVh{K@o1#%Ht3s)+P+^vgIb?bD$X!ylT82XMqA9Q zUE}!jj1`bKwkf)jJ9n0TP$Bv|=fzpkO#E0>WB?rlk%4?I4!S2IiR@fBf>m!X#GX@F zHDq;3J!XgcoS_V=H<>Cd)reYIj8}Iglt^EoEGNQCh7cnnQ`!+8fcn7{kai*;4q#R6 zVuOxsxj`-QC<{t@qVse+ti%3*NNXFm2ng8DGH=M4$c5i5ZwMCpB@!7J?E(BIe4cv( z>(9n*(mG5eMZ*%53+2);6QUPS*mBjTJF`QP(ju?ul+$x>2J7d&xJN?HiVrIjaynpB zmq3q%i1{A9hj(Rsgz1wL#}Nkt21voXiiqzQT{t^J$&Ath^mfUni6L?(RIkYOs$0)r z0Z9G^M?ZYEe0^gcOxTr_GAp&InR-nZ#J|_ijI4VTm*ZZ>`Y`s}u5A`ft&?D84w;Ef zDw~UlQlH5Up}biA09O?)ZFRi*;q&)77x3f@MqottlMDe(iC1X`sOurXiyW@@3`SlT zS9y197pvGZ?*_AFz`Zs z!V1|TrJ0%%w-4tky3!)Ax!^R_z;mGQbJ~NEAA%F_zb^3^kA$-@#HmH0Iv8=fH{DJj z<#jPDzgaqPYMgTm*pp2z*I(dbbfxlIXm1Bscp{eC^=_L-9o#jT1bf77>a6Pw{T> z0gHuZSVl{ighjmQpw_U;!(uUwt;@@e!H34&_pCE~EmJF8=y(Q~<&5rd-fb&wePDz@ zn|j@@5{VvE*PL6)7(s`fhTZyBi|^^0-L|Zu`}o$ucQ|VKUh4iY825mJJlKA zZt*!~y?6M6Guq%4eDU}vV-lZ-$tu!XA#p~k)*3t`j0csMe6<>a=FvZ_P=UL4#woIZ z1(#qhySB6raY9jH2wmJ#Y#}mnHU7yY^T} zCU6-sO+0$yCs48{eL3EB`YB9&T6iNJhg_Chnp9lp!f^Qe$2#n$t=X`}zeES*jCo#< z{o)+7r!iOyt{y*gJ7$3Pw+QxQ_j6vIz86p#kfJqb`i3zn+8WAkx9Bt=!Jhysae<(l@MuN?{NXu7X$)W{KUso2*#;tgB2uaN*w7g@y{ zuLCT-1^jnrY37#EjP=!D=lCm_5;H^m7e2rYN}FCQfU7t03ZG64b!?JU{eIjS#uZ$ zJ$vtOpL_PXcwoPesj-zY0)a5~^WAj_fj|KZZHWQQx%lL`0`4ph>^)3?`}^h=y&LSc z(R=1fuj&Rm^?E&e&lX=;V06+qI1Yg@4_|1=hxo!12*mOszg;^HC*_X!{P;=Na||I| zmB-bj_IE!=Zn?L7iPmPkrhjfU+$^Dnm2``~tU5zB7OyNW@cbB%4~;cUX@&=xKy$ZtX_`UBEi3xuhkRC8 zH`UEplUPI6Yszl!VzqhEqOVr;1pBp#%b-3>d>{%Z$*cz z0$BH4X9JSTr+Zs=yU{N=em&Syf~UW6J#fnkn%5|9M4id{^hD`6y-uL9ZW!G^X*FfW zA7mK-!l6xC21ileD?T>Ds%^-kr$wkd6bT;ZT$Ara28*My>RBo^z6w8;K~bSamkT{S zWzLk#8%vy1jj2N`u^EEX9URKI_qShoQc8x(2(4nWECm6LBJ!VFt?HzCA)(%ny-ldW z&Mo*^#q2eE1(M3N6GqX3yUb}lg>~ui^2KheHXYl1&J{?-Lf^s8{l=a)_;&kLop~W`$oUu~WyIj=T6ce! zv#Otdg78#&({uHp!eVN|sF(mH#&D{ zkp21WS3HNTP`B2#?8vrV_uMtSyim91wI?InJp2{!pcU<|2zXLD}LiY?eGdiomrOxd;5qPH1DGnCohoZ5S{#%S`IlA-%{^k^lPR?uu*rx zq;)B8P1kw7UBDkXa=%5H{W-$4=rFLwPjC+nVXgmj0XO{FzZG;Xqt0}DyUof2{jbub zmky-bg2S!kePNbC9Ttw)Q++4pw9(3&KMhy^&0@;jj|HnIuOhPvoy>-4S%E<&i!_zR zJW(ndNDW-V$3H;xyZeGD2lvctizRD9jYoVoc;v7NGU^GIwz{I)44AIXyP%+#vI#~i zyd>HgnOPU2L7(%FvrS#HPe#)=;&cfHM>qcW)#tA?psQc#8$QRcZ0fkmR>kH%T8)(V zxrh0nAW3Xp)*?QqFU8gfz)EJeuK>NXrc_1R`Y+4U+jZIx`Z5>sgS<@QlV?+nkH=q& zE>4KGSBG%(T4Lh%q5Ug^MD7-%4GeIrW!J6YdYBemQ0L|E7A^%o9s?jJBNQ%rkn z45&6Rn?so}E9R7!b@Xzqw+cyfGF>S)Dnh6(3`)ySN687fmwULCw~J}=#Odh^t!1+J zzNG@U^k?0W@=yj*#_itWaBZ;@iRu$(-jVL7;uM^Lv!f$h3`HxrElc)Cr zQBJ~KU6xbS4hoaXa|xdqto7>Wfe)B2^V-h7HWgb1O!QkmjYBg>lWQbo=Oi@;*PIet zt=Es0R=!fz<2+}y4?4qL>*wb_y5W~s6F{5H*%<&t>HFsk;=2e#=>s!%@_u~J_L=)5 zb;B3^C;HMQI}A%7oPQ>xeVDxXcduOv^aitOIFylP);jne2;oQAzpHd7<+Hy7^bO9D diff --git a/vignettes/Figures/SU35_SEAS5_Y2016-1.png b/vignettes/Figures/SU35_SEAS5_Y2016-1.png index 3328e2999cf221b20fa61da6cee7027ecd81a39a..ab4035e66e8a8c762dda6d45a1d08c0a4694550b 100644 GIT binary patch literal 7520 zcmeHJcT`i~md1i&B2o<1LXj4FQ4A{ZqeST?w9uvZPUuZBfPkQ(gen4|3rI--L-9u- zDoF1g#85+(j>3fZX1z6Q*8K6_db4J&c{6w2v(CQX-DjV>zjMBQ&r2PxC$s=|02LJ# zt*VMLjEd?4@~qKZpdc&P>QI#Kil>UP4;2*)!&y7m!S_?10;=n1=tECWPoF$_auo>N z+uJ*KR-?ctq_F}zre76rrbYNzSXj)>&Ew+Yy1TpG+}s))8%s(`czAduB_+vZ^7Qm{ zNJvOVM#fVb;DVKsAg7)v71d3=sVG7lx$CvsA zSql#PglU?FF$P{_^t??+ne!jKBIMPbTphapP@ww77S(4Ygk9;d!DntM4%tSgKb}g! zp{4g3WM*!xW$)(*HJZQeZ$!j9nM@^^Z#RbCU%^#1C_>O(;w<(yF~m&6NH^XR{BJaA zLy_FDPJfbN2FY{0=40SnQTp%(N5avh=jwEGi@VTEwKzhM`THAFzJlA_f+NPE2+^>5 zx~57-qLDDUz~f1mu6&K>L-GY-*BzEMF;lqnVH@7-F$gJ`BxLjw`3e%r$F~t(s-+3ZpUjtK-w zFoW>CNDs813zCu7{2dKn3L8?y-{VzM)sGBOZ{W1Kqvj=u^2VxK^~*Fm7!)79mU%h7 zI0J`opvol-%K6hs!Yh$U$g-wApW9OoQv9K(?&rc99DeDhAdZLK!8t*0N!JQpBGGwf zzo)sfim!U4XBb2whN}5iuETvzw5nDUped*_5t5rh?$J9$UtTVsQ7$Pwx4W-o zHVwS)0Od%;9egiAzABbbx618YfbK6i>Vj5f;<(B8)>N<7anu=Bkn+K}+1lfP1%Zs% z-)~t;K2OzKxp9deCfc}+-5g2B1z(W{tyf#JuG@aS+=H+C4Hc_SR`c`P#T9z2xB%mN zoG=8A+{*9FPHp!Qx%(Z7upjO-e?BUqfsRPs=Dm_VAhMU)6w6u@$?YxhZgUQ9`bEm! z^fHTiQT#?hm~}4X$V}(eBZ38Jbu7PmGeqdISbeeCt0g0Xtg+JA#J=#O_PKsGlMAJ_ z<0D$H2ztO^76<)MuyAc~o^`wf(?wd%H!^-P_oGT{H7fF_YkC)nu>GbXmIrQcaodg3 znjtvd2CccueyuL$pdF%2f1bD7{a->rqZ=8r5vy)g)sCG$Z546>1>||wQeRQjV`B64 z&x6vT)f)t;J(EQO^^0@9i=n+$EQpekx$PSMY?zBE6ujHk8go)$;W0?MyZlbmb*^4c z-!U_XfBaK8#|>K1&w_GT&n0$VpHj8GhCRf_NH{Epr7I}!+u7B%VMm6Moe(@bGGN>?#Wm+ERyL-FmUi60#?|)3D zY^UikTDNFO#UE35F^`$tJ|;yEnK+5qw2VpVaOv3))9Zw@eq5PY&CuaciqA#d|J0|i}XPD;_g*3j;`cyJur|=?D6=Tes3>voQTDROtiwLzZ#f3 zx){$l4{#e;U&ZWPHJxnIx_j(Av$cEEsd5{koaAP91$g~U0vOUqN0QN$u`Elu;QdDF zBc!}PmM8{r3vX`?F|RN0o0JsV*axo74+5hm3N^AFuQy3s9DHeMabpiIL3#;CB_%qM z>DYhmL0V=udI3k**V7d7%u?}F)dZhvVw7oo}Id1qyHMo7S zwe-;jM|;@mD`Yz~)!Y3~X&37HSJkHGIn}S_hq=w8)!J&`iXYK8C6ZH+ZoW5~gQS^Q zPJDy|X{U0Wai8A|EnQbyoRyR!4B_RpFpWcES^cAQ7p~d08MO39v6a|W7*?(6-pR;$ z4=jS{hTLTRJ#A?W$rizgHnOaJ=|}6@$vGoqDKA=E#pCO+eyg(I=SPjkCY#|pmCfa-^eRl>LyE~O)dD8m=~pm1EC%!#XV@@_D};N_ukVMmyDo=hkxFG;@G zhx|l{F;UcztF%cph&JG`gSBq;K#y?=DQ3|KW5JC*(?y$;GO;?%w8L)zhKJLy#8Vg0 z9!{y*C`-BJy2K8R;nA;g?Xn987xTW9YFQlwp5i(hoOrWWlvj1S`{QlGn_eQAmpmPD z>$R>HXvokp;hTkr(&a7-A#Epu{}leD{iFEc9P-m`v6SC&EbX3dRtL<9FN@eeWeXCl zO_@yVA7plV2X<5wwFgPPyyPFv#9S^&`j zlb8-Q_lEPRTg#l>D~}w^(F1{5q18p#53D{X{i=P_Y5cXwNY+&H_SbMs>@L=f5#cfUdVt zIflIx)i+{xzqMe?BjJ)Opz-;6EFR{Uzg^*H;UL%0s~vQriCqqlvSuft*ZK?}3K|6u zHI6p0E!6a|thdal2QKcWO=i1|xV*IKD$W|2I=o`a^j2|6wzfm&bOOa?D75IEbMi%Y z4l)zF4*w4P2aiz{ca9fjRI||W85=HY;O2vt&ej&W=cm7^QKy8<&yjE%cntEdcf`N< z{}27|WP%1BUi)Td~i*FRn%qeaaH>B zMI{|Is+*A7uQ?iE5E7&Yf(Zb?$pRQ1ilM8LOEL0ZD^d()E+oZxsR)2_AsLaNSVaIY z;Q!p(jQhs?P4o^~_y4!h-=~{1o|Mlt#&{+!wZF*l zFXa7`;J=)FH&a^|4^9RCqL#B-_1{6#f9Cjqto|_*g7B{tmpPHyG933j0nApTurE3aeGyumEL^$0762^!0xo#6b;`|7?C2VRp?IvB*gM%ERvPmd! zL053Hq>!*Ppx_(e0upAARFZ;=g3AQw z7*LQ^E2$z9sz_l$YHVd6Sv#*I`yH0`XAr#&xd{@&AhqL(R@Qmes5+L93)*W> zE>AgKlSsXT?C(ykb6YJU?H05|uM;Tnnm&;goV<6B$VwRJwI3+!oLQS%_A7%hN6o41 ztgkb2N*GO@rlg)bcm83?RonEnpd5}xTTTn*Ii)+>p@0p#qsw+mfM?o*$}1&7KrKvK zGe~*+gX6}vqaVN;=Sv4X{EYZ80<4Eto%Y~>v*Rkn054M4txVo|W+}D5$qAr^7^v*k z`g7~m48+uO+*Hmzw^%4{xxdw=Y@5O0YMp)1tpH-*j2rqsDOOu|iZ9)WUY}D)25qW$ zm|#qTo&|;|)`fb~L#cl~7rc-CBCT6hJ@oMMIf&6)jo!p01{j^WDYIc4E|KoMr|8D} zm@mJwLd2{W5EJGisF_>JUgui!Zc@%v)UaZUH37pony0i8b0=qsq%auI*nh}~a_HD8 z=lwQlFv&s5rf4OJuP8^Z8|Bs49a~EYb9Yvsl-jUG2m}&#W%#5LN62(}y%7VM822yJ z)8nnN-+m&wt=+x86`Biu#77E9&6<^8XYd+m(Zui2L0v`WTPTxJXnYvex##R>UUVz< zzJe6#n3A&g$RhEF(h*3HwPg^^!Ey2LJyU;*F17C0W&Bjrc0Y@3A6RQNs3}rF6|8_JBQ^ zf76bXDhXbPv1XBXeD1FON^f!LxCRo~B+-xGwQc7@M&9g7F_#PfjuZ3=V^c3B7}AqFqK`*6rAT^=JI_V#nWWhM%V=T2H}$r*!wQCnoB%dA z^s9d$A3*^jx`A1{rug8`AbUF!I!MyKT$S;r79EcW<~X0X|xsT1=rtTe1L^)dG-(Swf&gU7?&@!)UUmk0LLM{(`$Q&wEG5d$#C z{(Dly4Lx|dyzEHHJ!(MKG`FVVu>RD8OEnnrYw^SC@L&MwpnB!QRkt;A7ud{jI1SK){nM@()RU5br{l^8xigm%zPv9+j&XZw=WC%Okw>L02f-+t6otFf~0tzngZHMgIW zy4kK|nuo)s+V*nB>zxaWmsa;i^(19--j`Sr*k*%qp?2(g964CaeY|7ieXZM=4>MuU zX&oXw45M~0KeVu2pW8>-6;0)foj*Xi=iD`t&%!3E;xk7_apk#`;k^8-)e6mr(_jgo5=)gVdmfg{7WZ~cYJ$tA4~+@e zVm=xFChTV>uU(#r^NA%#&^$`Cx~x3=)u7mp@^vL9N|B&|xAcm-z#H9EJ?jkHA!43L zkfbrqBN=1@Kk(UNVK2SntZHLTg#>k|;@?Emq;{&7h@p9xOjo%LkNstobh^6DVQ`{D z3J*77kf>x(hN%D$g_{d@&s6}bx#OS;h4&^DNOi6T2D#MtQbnp3^BRO|btu@R{)@*6 z$X!8Ll?%*+>`|LzZIg$#?ebC{Fq_6;vq)BzvlrUxb0X2~`#W3|6agznoPR?Jz@nP_ zT_%JQ*^ X3Emm=}rB2?f|(Ovmz5{J`L>$57~@j}~RN6-}!wF8$Nuvsh|+#r~+1 zVv4ip9=iH7(31E0BWJp%j1xOQ2umO0W0nZ|IT45kdE+pzEu%o*;Ma<;{;9`A+j42ZRyc)P)V4EfKSE3@M>^>5=2AgiFlr6;@ zm;)-MPRtgx+77k)#>R;*YSv#3|^1FUK0ItkQ;HrsC~G%m1}3}RKI^nVsm*| z44&gugRzlDKuBi0JtXR?-UxbRKnr%wR%uDzCT)Caipd<$OJOQWF6yoH zM?LfFXrB)2LjAwFQ1^7hs#JSEgGq2-3l1P{!wx4 zmtDOyMg{c=3d~xQYl~HKje75>KB(eGmG9e=5V_h>?3Jeuj!H`?Wof~2 z_Bz00D4;U@y4+iL`S4^HHm-vu{}R-MU*%S%C#l&`q{0Bzy3C_AJ@~*6FIuh=E;J;{ zQewIbzM5!KgdXX9km|Ws_&7ihr6|-ddVP+)(7Mw^IqUkH!hu_@UX3jpuwuI-pO0pO zv=?rlXsQFCu6MW*BHV&eC((9HDM$Vq>U!`J)w!q8A4f`8%Hx1scQN9bqD$ZXnvE;x zn9*zuUPK7PmRPc)2*N7OeGG6Ux*8Cj0doI2D~b=B8y;9T)EWvPy6gapur4^G4-x+G zV>_7iH{}$f-V#=m8596+>74FHy)(G`0uHC9o8Vejv0=#pbGCucI_6qneyi? zI7!-pH5}F|XN1R7yU8rlrGx9K^X6e(uSa%-jq6IG9ToV1kq;{40f(gMcT-`WmWN7A zUE_2{;>sCgSoI1e>5ce2YhS(+U6bI$t!p(KYG4kYTdBt?hH=Rw^2RAso=jj3QSz^& z`#(6XJJ*y*We&v6SF+{9F=ovs``p8B?63fDJAwJzPYe1!JP>E8BCH8dSoAIMZ=jp9 zQ#s+ZF4kRP_4#~AhyAP2EG7o(vI|91A>YTG!v{}9x<4($uTPBLf(7`+%@8Ltqf*k1 zIeLa^J;XT6ylp}P2rU*5W2|t55&YSlYQi`(l-Q&xSSS3|56| KDOV^yeg1C`{4hZP literal 3440 zcmeH~dr(uy9>?)I4hR=eL8ui0vBFh@c#Dz>1}ySWd0G(uPCf>F?U<_KlX--+=j|vv6+Y%!6;GbIo#p?*R9?w$yNWpRKj> z*zVbiJhiY#qtR&Z-n?_pusC*S&~Ys-LvX$i)<+|&BcB87zbmH~qpp8r59IRIVCHV9blcg*xSHMjtTL)aa z8fBH?p7Gm*{Wg%0%D+6!qMXkyUw?O?C#@hRC0U*>i6?@if=QB>a5teMA-@-y)zq|f z8YDb(C!)@?gUN9hVV-QdjY%bxj>P@AMP9#3ow%)w-~VWK6T~YOht`I~Ava|5PTW{T zVQe!-a{JC=QNG}aYTI2>f+X0PSSh>cKpo$Ydr*IB-cGZBsZb1a3Eq+`hh&dAMx5b3 z!;R>&@8yT3eU=dQB`QWvY`*fdrz)~7G~6>9PZot`5~*_5v7%18j_A8Ke78*F*lcR$MKZB0QH=TV!$6=3nL7SJcMX zXVT#4CsXXYzN(en_=so(D~>Fe3lX>cR=S++IPjhCgP}0Sx&+oSEJZ@$+^dFuL{?2i zkqc(X&d|{s0qkh#lxehardS)49Sp{$J3zA08@0XScpIp+w!t)T1RRNFt#u&)0P_+@ z5iJOtX4g4232f{1rQU7K!3uuycvcNPH2f*Q3FWmi5GhDJ%&7MOSFi?|#c7HQzZ z-wCX>auk0(wj{shL;o{4ma=^k(1rh2FH-G&D{J6SAfwPJx=6RJoE!vxA%uv*Yc2Ar9xoMQ`!-! zREMiHO1d@FxA!>lc3E88K6}i^Mf-ug>4u^h_2i`@7d$)o6_W>h6rpZzQXKy0B9OBZ z^J1M2qwmcX->(6gM|*-U>kgW9bMKPCh7Nn$Nq8)mK5Cq?FJ{WS%n~A%gggGV!EmfATl*UfIi>f&uSfN?Tc00~;0%_w7&E?kBmkiLW{KX+LQ%X#ZilfL2I zWhVQbo8|%GebDOvkizM+aG>2APqI@B3vsogtAdzeXGF-*oF^z z!GFSu`qwIM%*B~{bYhTCJuzg!T!d~;&2az0_PRR|kfMiIT7?0rt;5Te)wPmuG&lVL zatFaXz--sh#iFJ@$DvDCFbeBXMe+#*4}x_ob<0&pn|xzyvHI*}69#H9f`VrC}-=w%UjM&``)8 z3BwkQ+WJ`v2~5P+>oM9JyC(wxELdZfi%GFS_oi)`s8rF4N~-Y6(S0K?{6WmCZ^gm) z3DI>BuH(2cR*Wo~`U*nGk5_`21k=E>8h$xDf9qPx>pb}Z9`i&&LF!oF>m=hPTuf8R z30S(-99PCL&>mu>cK;+ik$SnJ&MdETSs-=IyM5JT@!tP~#;5%Oz3{+2+Z!E71*#E$ z7sF|JmD-Ve-eOVIVlO}rs@{`ASjz&@5c58^eFwne>505-HiC;qdjLD;S`?VJgj;!^ zZfEJwaR>U>p~6uhha%jP4?knStMCV8;Eb8qTs()96nPt)ey<-zHy_?K0{Ie~!RW|Hry9_I$^$q))1Ly>a!I`DJ)XNe$Oo76D8piB}*2C^VT@0nAN#} zVe+K6Mgvu+oD;~{L*>Mzsiw=G&RZKaDTHvoV5Wb$`Rv0{gi$@w0?}=*PdCF$ZxbsPW5B UtNviHJfV zNbgOgSLrRV!S~zUKX!KJ`*vq`zTMeOp1J4#?z#7rd+s^UbHlYXly8vVCI_+6(X`iQ4>#W$h=gHeE|S^s*C4RC+ChV5!BF9(^EV@Kc}FeU}0gYt*uQR z=^(=ApKuP?y!FGAuC;~T-Cb{QZyXM{yu2(ZD5$QXfkYx@A3d_NvWkj|N=Zo>A0H11 z2~kf7w!oykt}AgF|9AiZfSI2t$ms=)t!0G!z*;U&-4*>5Ca9*-Cs~HHZfVV z^PJv?G|!zW7nNO}l=#Z-pM3Q`8d(r_!i%Mqt}8cGQR0T%BdcOE<`#QQHXBOstP+&* zuMoV^&A!`pY!r#moH7^glNS##T$QOOK3ey>3Ap2;_Buhwd`~*~;%F11=k!e{51V?l zZ89Cqc;wrh4GtXYi>u!3>L#(wNJ~0t2qgHl*t&w>?yYZo;~npwI*sQFH7?9Y_SOjb z$7IR6fTt3lh>P~DapnVKA3^?!^G8cT zWGi4->s!K|Bh_J%*A)<#g5JVyRE=xjX2hVn2X1O`aK=^&S#1|VEJnc zK0;-x)dsSGeRXCwvZ#&+PswYNjIZ?=m_uI({23+jlah?Zu_l=meeMkvdBcV)?L3h{si97Er{V3Wg3rf*bf_O1!ax(d#G;eqgUAYc^n7m}g2p0QH2L`w zKr6Ow=`sBDP%SD*aZ-OKTW6-YKRLlj%WGaab_0W~NJ$Z>?t|N%oFJh5FZ|$gv&+6AH2xU-1#7 z7_*!KA=GaiyYX6lEko&9rgL?S*I##5p;LK{8O!6 zs>#eVe~0tDcI%Q;51Jj}Tl;kR2oc=@Y;Vf1!>nH~xF@uOW#lT|CV3_}!oH2zjhSTn zqs;fF5YS|*KR^bKUgAJ_aE$(dJZ{m@Pba72Yf|`FnW&m-PLG#~>ljQ@8u}S)Z!b8^ z8vNLQ$7PK>y-D~hRehe}>uuEAX>mpN3JY$wN+DF`SB`|4HN@a@TUGHWJA(mgfVtD_ zmbaC4Fu6}qlUFt0o%Y1+NdpluXlR>OgvpfCCFB>EkCSnyB|f)uwXs7MSpdh3Vq2Qx z)`CX)TXDXGqG5bT&$py@-&`k$;IG)(0(ydg^ZiyC^eT?!Yoh6u;vspV%~HJ!D^`S8 zJdGJ9B`S>z-WR>UpWh^(5zZgn=GtZNbHlMLGv?lqH1KNpdo;Kp947 zx)8>wZe#)tahP?|KJmBbU-Oh1+nQX%N(bU!U%EV4VK`X@uEy{=THEXUTO^C5eiYkq zpX7X?r=F&CQWa&qIW;4iQ5bgaWXc`W&fBksu*ETXm%4mcEEv8wfBgL2X)_#Nizz%F zA9a5`t>kPjy5T05Y`zmpIE!u4-xxY7ac{I0ZkW^vvUY7&)e?j_xz1443HrFR9dJZA z?=?izjvBR1GtrZu+|jR4=7Dy~XA9UiNcco$ojMmo7e^cvOT6n>;tW1FN~f`VN?Du| z)=XSQm05cFzN{Ehcaxti33lB}c)J~jwA9R+~4G!OW4vP_~ z)9Ed<*;uF|12!x_<;s$>!EWv&sSg|@!2KKx?RT7m@x&t+7O3ox3f7$5>p1f%WLW#4 zl{x>wcDCBN*py1~7(7mPO}CO$#(q3&^&|^cJ)r0Se4im_mHliuFuURa=W!L9%Yu+J z+`-4)OHoL@?dgyYOs3c{a?1G5;5?6m*$qo(rRT?G=0}ua-a4YYj7A(c>?B&P01Wss z6t<9U?HDom`rJY;<8mg}loIc#BQu+f*@2^hVV)wAAG=hC9D!s9V}8ndQ~tZ-ZN z&F1gA&nFqT^6}8zh#}~mrUfU15yPlci(d1Nx8&e`ew*REy6d6Ac|X#{0-dr6YVv(p zKeq#cNXyBnS(**s=TD9GB3BYRJiqn1&wgH0LPBADZZxYOy)2ZGjw8&558ShP;$!;} zG*wgpqAV_c*RzwJ>403PC>{^8ZxVXCJ{&@TyzknG6SRZ+ zB;ou*QJ7K#x(+h>z#1V3tep`4bk8e|%?|d_Tp~jbiGu3w8DV zu2+^k<#4IJt1Z@RT)23&OMwp`*0MX53Nua#=cmD(pLCS2rmvR8JQ|y$qm3~t1@#}1 zD-6=oH+;)HN^<7H}jmR^s6mWSI}-;dz2b@u1$Y^rG3Y-gQO<$c*k5p2f4T% zv#oPvy68g{xw|_Z6qq*;hc92`(cxY(dh9e+b&HdoX8!Yh%!o3Da!l%%(1&(4p3s|T z?;o!EK+NvuQ z2ln;4wiS4%d*L|3&Xn6y?%L^TlrE!?c*5X!!G`fjY&?h}jx~Bxij(G!hssjp49E7p zG&w8lTno<%FP?bM##)%DuyUhyil1^@>xNTMeE)dDf~$6T19dY;L(}jIKVheYka6on zU$cMouf-?NfoUp>4&|P{JgvdC@1|#DYv(@Qzpwnh^V6BZHxC0j^Yh(x&F)0_azf9Y zUm6z1x7stc#io|WWw&7b0rOd`j#D?3LC*k3QAg0GZIWc8YqD=F56R7^ zl*wsFL()=VvaOW4=kCCXr(8iZ?O4hjP>UOnt(6|BY|JlM6U2G6q?H76D)hlp-%WXl zeD)6=GS(NGb?$$@lQJg#yIz>LY{Smx>;X4(PlZ7~)|WPRkbI{-maQSnNn)pzXY%DY zftP^jn}7X@oxjNcE6`aFzGSA_x%1#@=&ZR84N}iyEp$+*cx@@VmZ-%U_hsfA$HHylOiyw)=Is zQF%hLYKGbuhCImGnvhB4qE(ff#*46FW8@+4useGWLe5QWiI*W=$Fr&BwJCZkuV@h` zX|2I77Ti~LQU*Uqm*dse^BI6XEFj{9Bw{l+98EL+)sm0A-R99>EeMvU)qu(M+Vt%~&nfyGk6eR|bw+8ENvg~E7wXLY#$gD12)1vhxr z(w0xz5{Gn_cDeo&zlIb^s2tn+?u*X%V`x>+weBx=A*ajO5=G9B-0{}*Q2A_Hy;%Z7 zU(u<-%0YsGZtXZ-7V*B;KUWO&h%E)?a*f1>W{_|$D{<`#DOwzYyfYirpb6`Ik@(Zv zyb2ii9(Q$16(|b2+&F@bB?VrxaLaC$e@Sm@q<1wLIFk>$3;MihIKDf}mhC|4!qnqD*Y91%Av}d26-Kq2yA{>skkZ zCP!MbDc4+Ost#4~%{Ij=0X%45M6k#}fD*eT>5rUCQp57X>N4!$KG?j^`7=1~uE6b2 z4-F!Zz5}~t-FmB|C$Ildz4V+$f*R6pVFk@X2#qS;OeUXUnpRAmp<27btbCEMj+E>epZ z53U6Y_caNaUGwe*WJXY>B1j@%1SmDcCJ6-_df)nOUt#~x#*hrLxt!D$*H-(R^fzV- zmqzP0o(7klch>Qg5Va6_xu_FSz*(msgrUCo_&}>OEhZfQ6(byZxAfL0-wrTUT*0|# zW)$Hu6OyA5lx_l~D8~)*3va{db<;oeRUM1{eIGmj z;frYMs_CY8$m!1^N%h8nYZldkEnx|JnyL|1QSZYdwu{g#mZX4MPV}002=xv=O$jPDEuyx^ z^Nx%#`4T58Zf4IAS$_Z;U&DjU%V*bz2)qd*Pk~&v6@k=fMsCcU6HdhCLn830<`qD> zm-DPL0(3*8skElV$D+8YH{C;o6DBQl1Mo?{2dkad+HeCXd)x6jVys}OYW0^h0024$ z#e@`&V1yVgo_boQ&A(h`nm--+Z5jVSWJ{I(EVs5{OQNZHWA*(>SprOqxD>XjUTC~V z=tKAI+v&X?bK4>S01$Qz@BLZ|58pZH^X9bObWA7Oob6~$&2KSLp(U9sjIL}mWg$>B zTmpDnXK$CEfX1>}kQKqeXkOS)0af098~ZV5z$Zzg+NOOs3rSn0&I!xmifXShR`0A0 z-XX^Oeb~vIfZKqVa8ugiA;*%rjcLw|mFivQUXM~L=nDQqVKZJE!{AS^H+2e7u#6jj zA};}qmY$|Om$I^6snX6(V0zh5_;tTG-z4$zGjrS5@(TfEBYQ{?gWku2NJOrXo)Gi<+LD4scsw^;W_eB` zkW+jYWMiEI!h=Dx(QZpaEpRJV&>LrKt{wVZ4Hu4x&Pto+>-5zX~?2~f{74Hd% zdhDQlYr5v$)^stqSSi2$+Sr?|Z{xs>XWoy0^2hKzi{+bU?_Nzb=3`gy zGdsUIQ#s7r&;$yUI?l-1M29PYec^ePBGlRrJ8Fk{+=&Gh&5u6R>wvXgYDyoaMXF3) zbIa*|n}M7E!qfJ;%}v~6SipVBxqVKKY`K-=+iT5Aru*7o&gc%&nnmg%7;O z0q=~Y4Jamq+((=jz=+~iAk{D4MxTHlrEFv>Brfn!uLr)q^>F#*24OP5#t^0Iz9!xLMw{jQl zb~ZsxMd$ZnP>)-fD)CU?TFNr?W6+!4-4ps3aQf~nkH&hctD#hog*4SbCLkqsWQMHr zD|$_icvL>)rjYK{6l2Eiku?7ge5&lmQ#y&hqIv}nQ{4p87bHN;?4UH~H^eITE)ofi zaFq1RNN;z6#!>b=kN7=gY+`dN&~F|G<4OnaJr_cYZN112di@JkEY16Q1N6Yu^2B_K zyDMh)hX$B_tm)LqM&iRbN=`>I+I4*|rKnV8r7CKhhvKx~ub$pKaazDMPuG=`Dh}L* zHK~Wi|C9%1vK#1eQpc4mZ%u-on*t}p+Lnc~%;ALAdery!)%iu=M9WB(uuAtxfrS1< z^30vKqUHb)OSY+zBuL4kmtT>+Gcin|L!WP#aVk2j9(D~wO;$m*L2nSG4;&8PTNRQo z_1FdA z~{1;S5mQtEJ!phci4px+*|EmgJaN0K$s0P)6d*R4;+>E zefql9Uzlw7@PSvM+XIoM?%W+F2dJ!f5+%HW*U2Ps*sMsdJ~0KgDp6-hotudsXd9?aS2hB;$)G32L7MABhIaG2ujXy@ofNiNaaNj* zONKu4g!s&H&~A>Fe0ekx-GL2EiqUIcBf6P0=_s}Wn)AHh)RHf>;?-pyg3wINap%lwiu3_iWS zZw5yzcHB=o!&llv(t;00$=eWJoC_fP00?v#WxrZrh%h%*o4i@N4v~}%okR%vS$Bc` zbbIcd%n3JW(GB literal 4738 zcmeHLeN@ut9(S9~wjvn;c8y(ns=ztv`@h)Ia4z*eAXDYx}P zspwrTSw}=nQvqKVl-BBENs=bWRZ3F?Bt;ZNF5d0z+}-=f&h9<;pL;sz^Spk)&-Zzr z@9+D3&iDL^WA{cbw_RgvVPUa+*UpH278dU!mx}d!=9%KwV=8mw7#n?HySe>}|NXW8 zhmR*mm2(D@$u!`;CCWT&leIGeYheKbmdZOnAQ)-p70$aNwjIc=R7y*826r?@d>)Z3NpBn4c}j_RKuux`>7C@yRN1FYeB? z8;BAVmYowkD1yqkob!ue`7H=7yM8xxfK0i=<1T7nnRO$15~8ud1nub93Z;LU-;?mI zNN(@as(+y`GeSYSYm%mEcAwG?KrOgGjOFJRWfmISLjaUG7cN?U_|n=m_|aG_H%LS zR`~1D8hQ~uE_nm<91zL_Hp6sP5OpW%aShxi{q|4v#zAlz_l0Ja^tl*RVZM-lyvRXJ zJK74)vSy0W@?}Z0A*z!KD-Z*h89!L+9_sJxK8%E!;6-Irxs*`yv@+SjF8nlB)# z-HX3`wp&FBABL@bL@@}JW2snva6R4?76@-O^_N5a3}HP1w*&ADTtWu&D?WU z2WiHmAui5h|7$Qns~alNoJ@?wl_MtF+4`JJQeJr+){i-y`a?cwuu|i>rGABr7#GY? zrg%+rIc?ZjQdocfGdkPLyLmZUozYdVgA6TKDE1zC90G2he$`|5fr5k=BzoyoDy;FS zvv>vywyw?RqT>e}#}V$|R-k%kd&Pj1&@ZGR`~sPxK&EEHkyhQTyaFigIYGc(h1BxK zW^1R-+RCc*I6j@NLNNVG*uuhiDhxm;r|+%ko@5<0xM2!|5EYA=isxfy-1MNEoP-bW(sZ)dnq)^q=kIFPq zOaN&{TBO~Nv{vj!2>Y_RkfdPO2^Ad7HfX!Bhr*I=4{KECaXn`?dGy1kw&u2khS9ISWuw2Q3CH^+w3Ecv}yb>O?eI0wJx z8}^I@R{AM2PetGHR{gDKehGrJ0)45h(>2laZ3Ml2EdMnxjIbp%(F+7o<SrVz*!M?d1G z^*)l>eMne>gR}2p>-3OKeExkAAbn86&e9x3hBU78ITY$7rZcVWTw*$;SzFBVW$Gi} zSpwf#lH$%fnr-}y5_TNo3D3`J;~dH(D%2n}(4YJ2Uah^4mD$?Zf!6t4`Wv3|(Kh4~ zG$XQ8-ae8p!_T9auHPH$$rN}`2ldVhXRu}xq$c&Q^N~z1sBKNP=5v5dv?m|kHEZ96 zsedu?v!VY*?O|{C$;CnnIToWEOJ@A1T;o}>E|Neh@g z4cmi}aI~w+@b_<+v+!9pk3%571SMaV4*TZH>Fm*v9#BSWAmau~EzVF}q}|ZW?m@~+ zVJ+bMPg!_HCX$hcl$*xR7<8MrnqsYZlHz#5MDm4EUAxu|A-U^|4|f%(tq~Wq%OY2b zbIPm=E+@jKZdSu*1%|po+IY;^bP`C;b|E&*uv&1*2q~A4J2U!Yb?f=SqPEwF#qrc3``S*8qH(^i`-EBQ z!F25AzPP6AbP}rD@#oKcBJLBOFZGU#IM}B2CaQ$$@BKUlD zL)9qj*t*G7=Co!GHH?)w?RjZrO%?1M>drfDw)sHUAdGxP*F|zRmG2~s84FShl9!IF z8Tah;ovI{GY;?FX5Ch-94=~(fL?FLHXfIhmnq*Wt0@sYs_S?4kE?EBan>z>;FW%er z#V0iKe#1QDz)ARR#G?;a2{#Nsv(Jh;2pH!hcO)1&J~oWtO2K^R#8DU>F_s0rps-R` z?(36va~DPEhjt2U^G@%J_P<#ZGyaUA|LGkW{6Tsp&Q-w#ao!Yfq9Ub!WbM~V zPCseiP{vb}z>phtOJ=(XwD>({Mcj`dbt8LdjmSZ;bwlRIic7-!@5ng8!l7@Q=d{(% z)0L0Yj4!3G3B@wo_ZHn30*uD8Q|Cl7Cog)hzRLwPCmx>!UuI{{`>MZwNx2VGw-BiN zOBOucO_;y)mp82 Date: Fri, 3 Nov 2023 14:48:56 +0100 Subject: [PATCH 69/87] Remove PearsonIII distribution of the documentation --- R/PeriodSPEI.R | 11 ++++++----- R/PeriodStandardization.R | 12 ++++++------ man/CST_PeriodSPEI.Rd | 7 ++++--- man/CST_PeriodStandardization.Rd | 6 +++--- man/PeriodSPEI.Rd | 4 ++-- man/PeriodStandardization.Rd | 6 +++--- 6 files changed, 24 insertions(+), 22 deletions(-) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 77e90d5..38b58a2 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -77,8 +77,8 @@ #' (specified in 'leadtime_dim'); time dimension of length 1 (specified in #' 'time_dim'); and a dimension named 'coef' with the length of the #' coefficients needed for the used distribution (for 'Gamma' coef dimension is -#' of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length 3). It can't -#' have member dimension (specified in 'memb_dim'). +#' of lenght 2, for 'log-Logistic' is of length 3). It can't have member +#' dimension (specified in 'memb_dim'). #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the #' variable 'pr' of 'exp'. If it is NULL it is calculated using the provided @@ -101,7 +101,8 @@ #' function to be used for computing the SPEI. The accepted names are: #' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The #' 'Gamma' method only works when only precipitation is provided and other -#' variables are 0 because it is positive defined (SPI indicator). +#' variables are 0 because it is positive defined (SPI indicator). If other +#' distribution functions want to be used contact the authors. #'@param handle_infinity A logical value wether to return Infinite values (TRUE) #' or not (FALSE). #'@param na.rm A logical value indicating whether NA values should be removed @@ -355,8 +356,8 @@ CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', #' to be of same time dimension (specified in 'time_dim') of 'exp' and a #' dimension named 'coef' with the length of the coefficients needed for the #' used distribution (for 'Gamma' coef dimension is of lenght 2, for -#' 'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a -#' leadtime dimension (specified in 'leadtime_dim') of length 1. +#' 'log-Logistic' is of length 3). It also needs to have a leadtime dimension +#' (specified in 'leadtime_dim') of length 1. #'@param pet_exp A multidimensional array containing the Potential #' EvapoTranspiration data of 'exp'. It must have the same dimensions of the #' variable 'pr' of 'exp'. If it is NULL it is calculated using the provided diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 966d648..d48ac63 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -44,9 +44,9 @@ #' parameters. It needs to be of same time dimensions (specified in 'time_dim' #' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length #' of the coefficients needed for the used distribution (for 'Gamma' coef -#' dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length -#' 3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') -#' of length 1. It will only be used if 'data_cor' is not provided. +#' dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +#' to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +#' will only be used if 'data_cor' is not provided. #'@param handle_infinity A logical value wether to return infinite values (TRUE) #' or not (FALSE). When it is TRUE, the positive infinite values (negative #' infinite) are substituted by the maximum (minimum) values of each @@ -182,9 +182,9 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #' parameters. It needs to be of same time dimensions (specified in 'time_dim' #' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length #' of the coefficients needed for the used distribution (for 'Gamma' coef -#' dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length -#' 3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') -#' of length 1. It will only be used if 'data_cor' is not provided. +#' dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +#' to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +#' will only be used if 'data_cor' is not provided. #'@param handle_infinity A logical value wether to return infinite values (TRUE) #' or not (FALSE). When it is TRUE, the positive infinite values (negative #' infinite) are substituted by the maximum (minimum) values of each diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index 7b9aa77..9c2c357 100644 --- a/man/CST_PeriodSPEI.Rd +++ b/man/CST_PeriodSPEI.Rd @@ -71,8 +71,8 @@ to have the following dimensions: same leadtime dimension of 'exp' (specified in 'leadtime_dim'); time dimension of length 1 (specified in 'time_dim'); and a dimension named 'coef' with the length of the coefficients needed for the used distribution (for 'Gamma' coef dimension is -of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length 3). It can't -have member dimension (specified in 'memb_dim').} +of lenght 2, for 'log-Logistic' is of length 3). It can't have member +dimension (specified in 'memb_dim').} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the @@ -101,7 +101,8 @@ default.} function to be used for computing the SPEI. The accepted names are: 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The 'Gamma' method only works when only precipitation is provided and other -variables are 0 because it is positive defined (SPI indicator).} +variables are 0 because it is positive defined (SPI indicator). If other +distribution functions want to be used contact the authors.} \item{handle_infinity}{A logical value wether to return Infinite values (TRUE) or not (FALSE).} diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd index 823f501..fe0dd3b 100644 --- a/man/CST_PeriodStandardization.Rd +++ b/man/CST_PeriodStandardization.Rd @@ -64,9 +64,9 @@ with named dimensions. This option overrides computation of fitting parameters. It needs to be of same time dimensions (specified in 'time_dim' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length of the coefficients needed for the used distribution (for 'Gamma' coef -dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length -3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') -of length 1. It will only be used if 'data_cor' is not provided.} +dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +will only be used if 'data_cor' is not provided.} \item{return_params}{A logical value indicating wether to return parameters array (TRUE) or not (FALSE). It is FALSE by default.} diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index c3ee473..21184d3 100644 --- a/man/PeriodSPEI.Rd +++ b/man/PeriodSPEI.Rd @@ -81,8 +81,8 @@ SPEI. This option overrides computation of fitting parameters. It needs to be of same time dimension (specified in 'time_dim') of 'exp' and a dimension named 'coef' with the length of the coefficients needed for the used distribution (for 'Gamma' coef dimension is of lenght 2, for -'log-Logistic' or 'PearsonIII' is of length 3). It also needs to have a -leadtime dimension (specified in 'leadtime_dim') of length 1.} +'log-Logistic' is of length 3). It also needs to have a leadtime dimension +(specified in 'leadtime_dim') of length 1.} \item{pet_exp}{A multidimensional array containing the Potential EvapoTranspiration data of 'exp'. It must have the same dimensions of the diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd index b2dad6c..94bbee1 100644 --- a/man/PeriodStandardization.Rd +++ b/man/PeriodStandardization.Rd @@ -67,9 +67,9 @@ with named dimensions. This option overrides computation of fitting parameters. It needs to be of same time dimensions (specified in 'time_dim' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length of the coefficients needed for the used distribution (for 'Gamma' coef -dimension is of lenght 2, for 'log-Logistic' or 'PearsonIII' is of length -3). It also needs to have a leadtime dimension (specified in 'leadtime_dim') -of length 1. It will only be used if 'data_cor' is not provided.} +dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +will only be used if 'data_cor' is not provided.} \item{return_params}{A logical value indicating wether to return parameters array (TRUE) or not (FALSE). It is FALSE by default.} -- GitLab From 8608762c9b2f1da81e385400daaf77b996cc2dde Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 13 Nov 2023 15:37:49 +0100 Subject: [PATCH 70/87] Correct imports and remove unneeded dependencies --- NAMESPACE | 26 ++++++++++++++++++-------- R/PeriodAccumulation.R | 4 ++-- R/PeriodPET.R | 24 ++++++++++-------------- R/PeriodSPEI.R | 15 ++++----------- R/PeriodStandardization.R | 29 +++++++++++++++-------------- R/zzz.R | 16 +++++++++------- 6 files changed, 58 insertions(+), 56 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 49ec262..a15bdb0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,17 +31,27 @@ export(TotalSpellTimeExceedingThreshold) export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) -import(CSTools) -import(ClimProjDiags) -import(SPEI) -import(TLMoments) -import(lmom) -import(lmomco) -import(lubridate) import(multiApply) -import(zoo) +importFrom(CSTools,s2dv_cube) importFrom(ClimProjDiags,Subset) +importFrom(SPEI,hargreaves) +importFrom(SPEI,parglo.maxlik) +importFrom(SPEI,thornthwaite) +importFrom(lmom,cdfgam) +importFrom(lmom,cdfglo) +importFrom(lmom,cdfpe3) +importFrom(lmom,pelgam) +importFrom(lmom,pelglo) +importFrom(lmom,pelpe3) +importFrom(lmomco,are.lmom.valid) +importFrom(lmomco,pargam) +importFrom(lmomco,parglo) +importFrom(lmomco,parpe3) +importFrom(lmomco,pwm.pp) +importFrom(lmomco,pwm.ub) +importFrom(lmomco,pwm2lmom) importFrom(stats,approxfun) importFrom(stats,ecdf) importFrom(stats,quantile) importFrom(utils,read.delim) +importFrom(zoo,rollapply) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 09f4211..e573de9 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -204,7 +204,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' end = list(21, 10)) #' #'@import multiApply -#'@import zoo +#'@importFrom zoo rollapply #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, time_dim = 'time', rollwidth = NULL, @@ -322,7 +322,7 @@ data <- array(c(1,3,2,4), dim = c(time = 2, sdate = 2)) } } - data_accum <- rollapply(data = data_vector, width = rollwidth, FUN = sum, na.rm = na.rm) + data_accum <- zoo::rollapply(data = data_vector, width = rollwidth, FUN = sum, na.rm = na.rm) if (!forwardroll) { data_accum <- c(rep(NA, rollwidth-1), data_accum) } else { diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 87dc8ca..de20b2d 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -56,9 +56,7 @@ #'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) #'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) #' -#'@import SPEI -#'@import lubridate -#'@import multiApply +#'@importFrom CSTools s2dv_cube #'@export CST_PeriodPET <- function(data, pet_method = 'hargreaves', time_dim = 'syear', leadtime_dim = 'time', @@ -163,8 +161,7 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) #'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) #' -#'@import SPEI -#'@import lubridate +#'@importFrom SPEI hargreaves thornthwaite #'@import multiApply #'@export PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', @@ -249,7 +246,7 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', if (is.null(dates)) { stop("Parameter 'dates' is missing, dates must be provided.") } - if (!(is.Date(dates)) & !(is.POSIXct(dates))) { + if (!any(inherits(dates, 'Date'), inherits(dates, 'POSIXct'))) { stop("Parameter 'dates' is not of the correct class, ", "only 'Date' and 'POSIXct' classes are accepted.") } @@ -276,7 +273,6 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', # complete dates mask_dates <- .datesmask(dates) - lat_mask <- array(lat, dim = c(1, length(lat))) names(dim(lat_mask)) <- c('dat', lat_dim) @@ -368,22 +364,22 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', rm(data_tmp) } if (pet_method == 'hargreaves') { - pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, na.rm = FALSE, verbose = FALSE) + pet <- SPEI::hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = FALSE, verbose = FALSE) # line to return the vector to the size of the actual original data pet <- array(pet[which(mask_dates == 1)], dim = dims) } if (pet_method == 'hargreaves_modified') { - pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, - verbose = FALSE) + pet <- SPEI::hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, + verbose = FALSE) pet <- array(pet[which(mask_dates == 1)], dim = dims) } if (pet_method == 'thornthwaite') { - pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, - verbose = FALSE) + pet <- SPEI::thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, + verbose = FALSE) # line to return the vector to the size of the actual original data pet <- array(pet[which(mask_dates == 1)], dim = dims) } diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R index 38b58a2..1f4ef4c 100644 --- a/R/PeriodSPEI.R +++ b/R/PeriodSPEI.R @@ -159,14 +159,7 @@ #' #'res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) #' -#'@import multiApply -#'@import ClimProjDiags -#'@import SPEI -#'@import zoo -#'@import TLMoments -#'@import lmomco -#'@import lubridate -#'@import CSTools +#'@importFrom CSTools s2dv_cube #'@export CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', leadtime_dim = 'time', memb_dim = 'ensemble', @@ -545,7 +538,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, exp_cor = NULL, dates_expcor = NULL, if (is.null(dates_exp)) { stop("Parameter 'dates_exp' is missing, dates must be provided.") } - if (!(is.Date(dates_exp)) & !(is.POSIXct(dates_exp))) { + if (!any(inherits(dates_exp, 'Date'), inherits(dates_exp, 'POSIXct'))) { stop("Parameter 'dates_exp' is not of the correct class, ", "only 'Date' and 'POSIXct' classes are accepted.") } @@ -563,7 +556,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, exp_cor = NULL, dates_expcor = NULL, stop("Parameter 'dates_expcor' is missing, dates for 'exp_cor' must be ", "provided if exp_cor is not NULL.") } - if (!(is.Date(dates_expcor)) & !(is.POSIXct(dates_expcor))) { + if (!any(inherits(dates_expcor, 'Date'), inherits(dates_expcor, 'POSIXct'))) { stop("Element 'Dates' in 'exp_cor' is not of the correct class, ", "only 'Date' and 'POSIXct' classes are accepted.") } @@ -590,7 +583,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, exp_cor = NULL, dates_expcor = NULL, if (!is.logical(na.rm)) { stop("Parameter 'na.rm' must be logical.") } - + # Complete dates dates <- .return2list(dates_exp, dates_expcor) diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index d48ac63..6a83ed4 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -226,9 +226,10 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'SPEI <- PeriodStandardization(data = data) #'SPEIcor <- PeriodStandardization(data = data, data_cor = datacor) #'@import multiApply -#'@import ClimProjDiags -#'@import TLMoments -#'@import lmom +#'@importFrom ClimProjDiags Subset +#'@importFrom lmomco pwm.pp pwm.ub pwm2lmom are.lmom.valid parglo pargam parpe3 +#'@importFrom lmom cdfglo cdfgam cdfpe3 pelglo pelgam pelpe3 +#'@importFrom SPEI parglo.maxlik #'@export PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, time_dim = 'syear', leadtime_dim = 'time', @@ -257,7 +258,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } ## dates if (!is.null(dates)) { - if (!(is.Date(dates)) & !(is.POSIXct(dates))) { + if (!any(inherits(dates, 'Date'), inherits(dates, 'POSIXct'))) { stop("Parameter 'dates' is not of the correct class, ", "only 'Date' and 'POSIXct' classes are accepted.") } @@ -338,8 +339,8 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "It will not be used.") ref_period <- NULL } else { - years <- year(ClimProjDiags::Subset(dates, along = leadtime_dim, - indices = 1)) + years <- format(ClimProjDiags::Subset(dates, along = leadtime_dim, + indices = 1), "%Y") ref_period[[1]] <- which(ref_period[[1]] == years) ref_period[[2]] <- which(ref_period[[2]] == years) } @@ -619,22 +620,22 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, .std <- function(data, fit = 'pp-pwm', distribution = 'log-Logistic') { pwm = switch(fit, - 'pp-pwm' = pwm.pp(data, -0.35, 0, nmom = 3), - pwm.ub(data, nmom = 3) + 'pp-pwm' = lmomco::pwm.pp(data, -0.35, 0, nmom = 3), + lmomco::pwm.ub(data, nmom = 3) # TLMoments::PWM(data, order = 0:2) ) - lmom <- pwm2lmom(pwm) - if (!(!are.lmom.valid(lmom) || anyNA(lmom[[1]]) || any(is.nan(lmom[[1]])))) { + lmom <- lmomco::pwm2lmom(pwm) + if (!any(!lmomco::are.lmom.valid(lmom), anyNA(lmom[[1]]), any(is.nan(lmom[[1]])))) { fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) params_result = switch(distribution, 'log-Logistic' = tryCatch(lmom::pelglo(fortran_vec), - error = function(e){parglo(lmom)$para}), + error = function(e){lmomco::parglo(lmom)$para}), 'Gamma' = tryCatch(lmom::pelgam(fortran_vec), - error = function(e){pargam(lmom)$para}), + error = function(e){lmomco::pargam(lmom)$para}), 'PearsonIII' = tryCatch(lmom::pelpe3(fortran_vec), - error = function(e){parpe3(lmom)$para})) + error = function(e){lmomco::parpe3(lmom)$para})) if (distribution == 'log-Logistic' && fit == 'max-lik') { - params_result = parglo.maxlik(data, params_result)$para + params_result = SPEI::parglo.maxlik(data, params_result)$para } return(params_result) } else { diff --git a/R/zzz.R b/R/zzz.R index 4c8d0a4..b108beb 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -110,16 +110,18 @@ wind2CF <- function(wind, pc) { # Function that creates a mask array from dates for the whole year .datesmask <- function(dates, frequency = 'monthly') { - ini <- as.Date(paste(lubridate::year(min(dates)), 01, 01, sep = '-')) - end <- as.Date(paste(lubridate::year(max(dates)), 12, 31, sep = '-')) - daily <- as.Date(ini:end) + years <- format(dates, "%Y") + ini <- as.Date(paste(min(years), 01, 01, sep = '-')) + end <- as.Date(paste(max(years), 12, 31, sep = '-')) + daily <- as.Date(seq(ini, end, by = "day")) if (frequency == 'monthly') { - monthly <- daily[which(lubridate::day(daily) == 1)] + days <- format(daily, "%d") + monthly <- daily[which(days == 1)] dates_mask <- array(0, dim = length(monthly)) for (dd in 1:length(dates)) { - ii <- which(monthly == as.Date(paste(lubridate::year(dates[dd]), - lubridate::month(dates[dd]), - 01, sep = '-'))) + year <- format(dates[dd], "%Y") + month <- format(dates[dd], "%m") + ii <- which(monthly == as.Date(paste(year, month, 01, sep = '-'))) dates_mask[ii] <- 1 } } else { -- GitLab From 86547ee1de285d565c421ff3881b8a2bce1b6b83 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 15 Nov 2023 16:41:14 +0100 Subject: [PATCH 71/87] Remove function PeriodSPEI --- NAMESPACE | 2 - R/PeriodSPEI.R | 635 ------------------------------------------ man/CST_PeriodSPEI.Rd | 209 -------------- man/PeriodSPEI.Rd | 209 -------------- 4 files changed, 1055 deletions(-) delete mode 100644 R/PeriodSPEI.R delete mode 100644 man/CST_PeriodSPEI.Rd delete mode 100644 man/PeriodSPEI.Rd diff --git a/NAMESPACE b/NAMESPACE index a15bdb0..9b14b18 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,7 +8,6 @@ export(CST_MergeRefToExp) export(CST_PeriodAccumulation) export(CST_PeriodMean) export(CST_PeriodPET) -export(CST_PeriodSPEI) export(CST_PeriodStandardization) export(CST_QThreshold) export(CST_SelectPeriodOnData) @@ -21,7 +20,6 @@ export(MergeRefToExp) export(PeriodAccumulation) export(PeriodMean) export(PeriodPET) -export(PeriodSPEI) export(PeriodStandardization) export(QThreshold) export(SelectPeriodOnData) diff --git a/R/PeriodSPEI.R b/R/PeriodSPEI.R deleted file mode 100644 index 1f4ef4c..0000000 --- a/R/PeriodSPEI.R +++ /dev/null @@ -1,635 +0,0 @@ -#'Compute the Standardised Precipitation-Evapotranspiration Index -#' -#'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) -#'that is a multiscalar drought index based on climatic data. It can be used for -#'determining the onset, duration and magnitude of drought conditions with -#'respect to normal conditions. The idea behind the SPEI is to compare the -#'highest possible evapotranspiration with the current water availability. The -#'SPEI uses for a specific time frequency the difference between precipitation -#'and potential evapotranspiration. This represents a simple climatic water -#'balance which is calculated at different time scales to obtain the SPEI. This -#'function is build to be compatible with other tools in that work with -#''s2dv_cube' object class. The input data must be this object class. If you -#'don't work with 's2dv_cube', see PeriodSPEI. -#' -#'Next, some specifications for the calculation of this indicator will be -#'discussed. On the one hand, the model to be used to calculate Potential -#'Evapotranspiration is specified with the 'pet_method' parameter (it can be -#'hargreaves, hargraves modified or thornwhite). On the other hand, to choose -#'the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is -#'done using the 'accum' parameter, where you must indicate the number of time -#'steps you want to accumulate throughout 'leadtime_dim'. The accumulation will -#'be performed backwards by default. Since the accumulation is done for the -#'elapsed time steps, there will be no complete accumulations until reaching the -#'time instant equal to the value of the 'accum' parameter. For this reason, in -#'the result, we will find that for the dimension where the accumulation has -#'been carried out, the values of the array will be NA since they do not include -#'complete accumulations. Also, there is a parameter to specify if the -#'standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a -#'probability distribution to transform the original values to standardized -#'units that are comparable in space and time and at different SPEI time scales. -#'The 'na.rm' parameter is a logical parameter used to decide whether to remove -#'the NA values from the data before doing the calculation. It must be taken -#'into account that if 'na.rm' is FALSE and there is some NA value in the -#'specific coordinates which the SPEI is computed, standardization cannot be -#'carried out for those coordinates and therefore, the result will be filled -#'with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the -#'amount of data for those specific coordinates is smaller than 4, it will not -#'be possible to carry out because we will not have enough data and the result -#'will be also filled with NAs for that coordinates. When only 'exp' is provided -#'('exp_cor' is NULL) the Standardization is computed with cross validation. For -#'more information about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation -#'and CST_PeriodStandardization. -#' -#'@param exp A named list with the needed \code{s2dv_cube} objects containing -#' the seasonal forecast experiment in the data element for each variable. -#' Specific variables are needed for each method used in computing the -#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and -#' 'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. -#' Variable 'pr' is always needed. The units for temperature variables -#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -#' precipitation ('pr') need to be in mm/month. -#'@param exp_cor A named list with the needed \code{s2dv_cube} objects for each -#' variable in which the quantile PeriodSPEI should be applied. If it is not -#' specified, the PeriodSPEI is calculated from object 'exp'. -#'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'syear'. -#'@param leadtime_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'time'. -#'@param memb_dim A character string indicating the name of the dimension in -#' which the ensemble members are stored. When set it to NULL, threshold is -#' computed for individual members. -#'@param lat_dim A character string indicating the name of the latitudinal -#' dimension. By default it is set by 'latitude'. -#'@param accum An integer value indicating the number of months for the -#' accumulation for each variable. When it is greater than 1, the result will -#' be filled with NA until the accum 'time_dim' dimension number due to the -#' accumulation to previous months. The accumulation is performed backwards -#' by default. -#'@param ref_period A list with two numeric values with the starting and end -#' points of the reference period used for computing the index. The default -#' value is NULL indicating that the first and end values in data will be -#' used as starting and end points. -#'@param params A multidimensional array with named dimensions for computing the -#' SPEI. This option overrides computation of fitting parameters. It needs -#' to have the following dimensions: same leadtime dimension of 'exp' -#' (specified in 'leadtime_dim'); time dimension of length 1 (specified in -#' 'time_dim'); and a dimension named 'coef' with the length of the -#' coefficients needed for the used distribution (for 'Gamma' coef dimension is -#' of lenght 2, for 'log-Logistic' is of length 3). It can't have member -#' dimension (specified in 'memb_dim'). -#'@param pet_exp A multidimensional array containing the Potential -#' EvapoTranspiration data of 'exp'. It must have the same dimensions of the -#' variable 'pr' of 'exp'. If it is NULL it is calculated using the provided -#' variables with specified 'pet_method'. It is NULL by default. -#'@param pet_expcor A multidimensional array containing the Potential -#' EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -#' the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the -#' provided variables with specified 'pet_method'. It is NULL by default. -#'@param standardization A logical value indicating wether the standardization -#' is computed. -#'@param pet_method A character string indicating the method used to compute -#' the potential evapotranspiration. The accepted methods are: -#' 'hargreaves' and 'hargreaves_modified', that require the data to have -#' variables tmin and tmax; and 'thornthwaite', that requires variable -#' 'tmean'. -#'@param method A character string indicating the standardization method used. -#' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by -#' default. -#'@param distribution A character string indicating the name of the distribution -#' function to be used for computing the SPEI. The accepted names are: -#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The -#' 'Gamma' method only works when only precipitation is provided and other -#' variables are 0 because it is positive defined (SPI indicator). If other -#' distribution functions want to be used contact the authors. -#'@param handle_infinity A logical value wether to return Infinite values (TRUE) -#' or not (FALSE). -#'@param na.rm A logical value indicating whether NA values should be removed -#' from data. It is FALSE by default. If it is FALSE and there are NA values, -#' (if standardization is TRUE) all values of other dimensions except time_dim -#' and leadtime_dim will be set to NA directly. On the other hand, if it is -#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is -#' not reaching 4 values, it is not enough values to estimate the parameters -#' and the result will include NA. -#'@param ncores An integer value indicating the number of cores to use in -#' parallel computation. -#' -#'@return An 's2dv_cube' object containing the SPEI multidimensional array in -#'element \code{data} with same dimensions as input data. If 'exp_cor' is -#'provided, only results from 'exp_cor' will be provided. The parameters of the -#'standardization will only be returned if 'return_params' is TRUE. The SPEI -#'will only be computed if 'standardization' is TRUE. If 'standardization' is -#'FALSE, only the climatic water balance (precipitation minus -#'evapotranspiration) will be returned. The resultant arrays will have the same -#'dimensions as the initial input data. The other elements in the 's2dv_cube' -#'will be updated with the combined information of the input data arrays. -#' -#'@examples -#'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, -#' latitude = 2, longitude = 1, ensemble = 25) -#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, -#' latitude = 2, longitude = 1, ensemble = 15) -#' -#'dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), -#' paste0(2010:2015, "-09-15"), -#' paste0(2010:2015, "-10-16")), 'UTC') -#'dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -#'dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), -#' paste0(2020, "-10-16")), 'UTC') -#'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) -#'lat <- c(40,40.1) -#' -#'exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -#'exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -#'exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) -#' -#'expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -#'expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -#'expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) -#' -#'exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) -#'exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, -#' 'pr' = expcor_pr) -#' -#'exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), -#' Dates = dates_exp) -#'exp_cor <- lapply(exp_cor, CSTools::s2dv_cube, coords = list(latitude = lat), -#' Dates = dates_expcor) -#' -#'res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) -#' -#'@importFrom CSTools s2dv_cube -#'@export -CST_PeriodSPEI <- function(exp, exp_cor = NULL, time_dim = 'syear', - leadtime_dim = 'time', memb_dim = 'ensemble', - lat_dim = 'latitude', accum = 1, ref_period = NULL, - params = NULL, pet_exp = NULL, pet_expcor = NULL, - standardization = TRUE, pet_method = 'hargreaves', - method = 'parametric', distribution = 'log-Logistic', - handle_infinity = FALSE, return_params = FALSE, - na.rm = FALSE, ncores = NULL) { - - # Check 's2dv_cube' - if (is.null(exp)) { - stop("Parameter 'exp' cannot be NULL.") - } - if (!all(sapply(exp, function(x) inherits(x, 's2dv_cube')))) { - stop("Parameter 'exp' must be a list of 's2dv_cube' class.") - } - if (!is.null(exp_cor)) { - if (!all(sapply(exp_cor, function(x) inherits(x, 's2dv_cube')))) { - stop("Parameter 'exp_cor' must be a list of 's2dv_cube' class.") - } - } - # latitude - if (!any(names(exp[[1]]$coords) %in% .KnownLatNames())) { - stop("Spatial coordinate names of parameter 'exp' do not match any ", - "of the names accepted by the package.") - } - # Dates - dates_exp <- exp[[1]]$attrs$Dates - if (!'Dates' %in% names(exp[[1]]$attrs)) { - stop("Element 'Dates' is not found in 'attrs' list of 'exp'. ", - "See 's2dv_cube' object description in README file for more ", - "information.") - } - - if (!is.null(exp_cor)) { - if (!'Dates' %in% names(exp_cor[[1]]$attrs)) { - stop("Element 'Dates' is not found in 'attrs' list of 'exp_cor'. ", - "See 's2dv_cube' object description in README file for more ", - "information.") - } - } - - lat_dim <- names(exp[[1]]$coords)[[which(names(exp[[1]]$coords) %in% .KnownLatNames())]] - - res <- PeriodSPEI(exp = lapply(exp, function(x) x$data), - dates_exp = exp[[1]]$attrs$Dates, - lat = exp[[1]]$coords[[lat_dim]], - exp_cor = if (is.null(exp_cor)) {NULL} else { - lapply(exp_cor, function(x) x$data)}, - dates_expcor = exp_cor[[1]]$attrs$Dates, - time_dim = time_dim, leadtime_dim = leadtime_dim, - memb_dim = memb_dim, lat_dim = lat_dim, - accum = accum, ref_period = ref_period, params = params, - pet_exp = pet_exp, pet_expcor = pet_expcor, - standardization = standardization, - pet_method = pet_method, method = method, - distribution = distribution, - handle_infinity = handle_infinity, - return_params = return_params, na.rm = na.rm, - ncores = ncores) - - if (!is.null(exp_cor)) { - source_files_expcor <- lapply(exp_cor, function(x) {x$attrs$source_files}) - source_files <- lapply(exp, function(x) {x$attrs$source_files}) - source_files <- c(exp = source_files, exp_cor = source_files_expcor) - coords <- exp_cor[[1]]$coords - Dates <- exp_cor[[1]]$attrs$Dates - metadata <- exp_cor[[1]]$attrs$Variable$metadata - metadata_names <- names(metadata) - } else { - source_files <- lapply(exp, function(x) {x$attrs$source_files}) - coords <- exp[[1]]$coords - Dates <- exp[[1]]$attrs$Dates - metadata <- exp[[1]]$attrs$Variable$metadata - metadata_names <- names(metadata) - } - - if (standardization) { - varname <- 'SPEI' - } else { - varname <- 'Precipitation minus accumulated PET' - } - - if (return_params & standardization) { - metadata_names <- intersect(names(dim(res[[1]])), metadata_names) - suppressWarnings( - res[[1]] <- CSTools::s2dv_cube(data = res[[1]], coords = coords, - varName = varname, - metadata = metadata[metadata_names], - Dates = Dates, - source_files = source_files, - when = Sys.time()) - ) - return(list(spei = res[[1]], params = res[[2]])) - } else { - metadata_names <- intersect(names(dim(res)), metadata_names) - suppressWarnings( - res <- CSTools::s2dv_cube(data = res, coords = coords, - varName = varname, - metadata = metadata[metadata_names], - Dates = Dates, - source_files = source_files, - when = Sys.time()) - ) - return(res) - } -} - - -#'Compute the Standardised Precipitation-Evapotranspiration Index -#' -#'Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) -#'that is a multiscalar drought index based on climatic data. It can be used for -#'determining the onset, duration and magnitude of drought conditions with -#'respect to normal conditions. The idea behind the SPEI is to compare the -#'highest possible evapotranspiration with the current water availability. The -#'SPEI uses for a specific time frequency the difference between precipitation -#'and potential evapotranspiration. -#' -#'Next, some specifications for the calculation of this indicator will be -#'discussed. On the one hand, the model to be used to calculate Potential -#'Evapotranspiration is specified with the 'pet_method' parameter (it can be -#'hargreaves, hargraves modified or thornwhite). On the other hand, to choose -#'the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is -#'done using the 'accum' parameter, where you must indicate the number of time -#'steps you want to accumulate throughout 'leadtime_dim'. The accumulation will -#'be performed backwards by default. Since the accumulation is done for the -#'elapsed time steps, there will be no complete accumulations until reaching the -#'time instant equal to the value of the 'accum' parameter. For this reason, in -#'the result, we will find that for the dimension where the accumulation has -#'been carried out, the values of the array will be NA since they do not include -#'complete accumulations. Also, there is a parameter to specify if the -#'standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a -#'probability distribution to transform the original values to standardized -#'units that are comparable in space and time and at different SPEI time scales. -#'The 'na.rm' parameter is a logical parameter used to decide whether to remove -#'the NA values from the data before doing the calculation. It must be taken -#'into account that if 'na.rm' is FALSE and there is some NA value in the -#'specific coordinates which the SPEI is computed, standardization cannot be -#'carried out for those coordinates and therefore, the result will be filled -#'with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the -#'amount of data for those specific coordinates is smaller than 4, it will not -#'be possible to carry out because we will not have enough data and the result -#'will be also filled with NAs for that coordinates. When only 'exp' is provided -#'('exp_cor' is NULL) the Standardization is computed with cross validation. For -#'more information about SPEI calculation, see functions PeriodPET, -#'PeriodAccumulation and PeriodStandardization. -#' -#'@param exp A named list with multidimensional array objects containing -#' the seasonal forecast experiment in the data element for each variable. -#' Specific variables are needed for each method used in computing the -#' Potential Evapotranspiration. See parameter 'pet_method'. The accepted -#' variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and -#' 'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. -#' Variable 'pr' is always needed. The units for temperature variables -#' ('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -#' precipitation ('pr') need to be in mm/month. -#'@param dates_exp An array of temporal dimensions containing the Dates of -#' 'exp'. It must be of class 'Date' or 'POSIXct'. -#'@param lat A numeric vector containing the latitude values of 'exp'. -#'@param exp_cor A named list with multidimensional array objects for each -#' variable in which the quantile PeriodSPEI should be applied. If it is not -#' specified, the PeriodSPEI is calculated from object 'exp'. -#'@param dates_expcor An array of temporal dimensions containing the Dates of -#' 'exp_cor'. It must be of class 'Date' or 'POSIXct'. -#'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'syear'. -#'@param leadtime_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'time'. -#'@param memb_dim A character string indicating the name of the dimension in -#' which the ensemble members are stored. When set it to NULL, threshold is -#' computed for individual members. -#'@param lat_dim A character string indicating the name of the latitudinal -#' dimension. By default it is set by 'latitude'. -#'@param accum accum An integer value indicating the number of months for the -#' accumulation for each variable. When it is greater than 1, the result will -#' be filled with NA until the accum time_dim dimension number due to the -#' accumulation to previous months. The accumulation is performed backwards -#' by default. -#'@param ref_period A list with two numeric values with the starting and end -#' points of the reference period used for computing the index. The default -#' value is NULL indicating that the first and end values in data will be -#' used as starting and end points. -#'@param params A multidimensional array with named dimensions for computing the -#' SPEI. This option overrides computation of fitting parameters. It needs -#' to be of same time dimension (specified in 'time_dim') of 'exp' and a -#' dimension named 'coef' with the length of the coefficients needed for the -#' used distribution (for 'Gamma' coef dimension is of lenght 2, for -#' 'log-Logistic' is of length 3). It also needs to have a leadtime dimension -#' (specified in 'leadtime_dim') of length 1. -#'@param pet_exp A multidimensional array containing the Potential -#' EvapoTranspiration data of 'exp'. It must have the same dimensions of the -#' variable 'pr' of 'exp'. If it is NULL it is calculated using the provided -#' variables with specified 'pet_method'. It is NULL by default. -#'@param pet_expcor A multidimensional array containing the Potential -#' EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -#' the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the -#' provided variables with specified 'pet_method'. It is NULL by default. -#'@param standardization A logical value indicating wether the standardization -#' is computed. -#'@param pet_method A character string indicating the method used to compute -#' the potential evapotranspiration. The accepted methods are: -#' 'hargreaves' and 'hargreaves_modified', that require the data to have -#' variables tmin and tmax; and 'thornthwaite', that requires variable -#' 'tmean'. -#'@param method A character string indicating the standardization method used. -#' If can be: 'parametric' or 'non-parametric'. -#'@param distribution A character string indicating the name of the distribution -#' function to be used for computing the SPEI. The accepted names are: -#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The -#' 'Gamma' method only works when only precipitation is provided and other -#' variables are 0 because it is positive defined (SPI indicator). -#'@param handle_infinity A logical value wether to return Infinite values (TRUE) -#' or not (FALSE). -#'@param return_params A logical value indicating wether to return parameters -#' array (TRUE) or not (FALSE). It is FALSE by default. -#'@param na.rm A logical value indicating whether NA values should be removed -#' from data. It is FALSE by default. If it is FALSE and there are NA values, -#' (if standardization is TRUE) all values of other dimensions except time_dim -#' and leadtime_dim will be set to NA directly. On the other hand, if it is -#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is -#' not reaching 4 values, it is not enough values to estimate the parameters -#' and the result will include NA. -#'@param ncores An integer value indicating the number of cores to use in -#' parallel computation. -#' -#'@return A multidimensional array containing the SPEI with same dimensions as -#'input data. If 'exp_cor' is provided, only results from 'exp_cor' will be -#'provided. The parameters of the standardization will only be returned -#'if 'return_params' is TRUE. The SPEI will only be computed if -#''standardization' is TRUE. If 'standardization' is FALSE, only the climatic -#'water balance (precipitation minus evapotranspiration) will be returned. The -#'resultant arrays will have the same dimensions as the initial input data. -#' -#'@examples -#'dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, -#' latitude = 2, longitude = 1, ensemble = 25) -#'dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, -#' latitude = 2, longitude = 1, ensemble = 15) -#'exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -#'exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -#'exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) -#' -#'expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -#'expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -#'expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) -#' -#'dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), -#' paste0(2010:2015, "-09-15"), -#' paste0(2010:2015, "-10-16"))) -#'dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -#'dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), -#' paste0(2020, "-09-15"), -#' paste0(2020, "-10-16")), 'UTC') -#'dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) -#'lat <- c(40,40.1) -#' -#'exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) -#'exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, -#' 'pr' = expcor_pr) -#'res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, -#' dates_exp = dates_exp, dates_expcor = dates_expcor) -#' -#'@export -PeriodSPEI <- function(exp, dates_exp, lat, exp_cor = NULL, dates_expcor = NULL, - time_dim = 'syear', leadtime_dim = 'time', - memb_dim = 'ensemble', lat_dim = 'latitude', - accum = 1, ref_period = NULL, params = NULL, - pet_exp = NULL, pet_expcor = NULL, standardization = TRUE, - pet_method = 'hargreaves', method = 'parametric', - distribution = 'log-Logistic', handle_infinity = FALSE, - return_params = FALSE, na.rm = FALSE, ncores = NULL) { - - # Initial checks - ## exp - if (!inherits(exp, 'list')) { - stop("Parameter 'exp' needs to be a named list with the needed variables.") - } - if (is.null(names(exp))) { - stop("Parameter 'exp' needs to be a named list with the variable names.") - } - if (any(sapply(exp, function(x) is.null(names(dim(x)))))) { - stop("Parameter 'exp' needs to be a list of arrays with dimension names.") - } - dims <- lapply(exp, function(x) dim(x)) - first_dims <- dims[[1]] - all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) - if (!all_equal) { - stop("Parameter 'exp' variables need to have the same dimensions.") - } - - ## exp_cor - if (!is.null(exp_cor)) { - if (!inherits(exp_cor, 'list')) { - stop("Parameter 'exp_cor' needs to be a named list with the needed ", - "variables if it is not NULL.") - } - if (is.null(names(exp_cor))) { - stop("Parameter 'exp_cor' needs to be a named list with the variable names.") - } - if (any(sapply(exp_cor, function(x) is.null(names(dim(x)))))) { - stop("Parameter 'exp_cor' needs to be a list of arrays with dimension names.") - } - dimscor <- lapply(exp_cor, function(x) dim(x)) - first_dimscor <- dimscor[[1]] - all_equal <- all(sapply(dimscor[-1], function(x) identical(first_dimscor, x))) - if (!all_equal) { - stop("Parameter 'exp_cor' variables need to have the same dimensions.") - } - } - # Variable checks - ## exp (2) - pet <- vector("list", 2) - if (!('pr' %in% names(exp))) { - stop("Variable 'pr' is not included in 'exp'.") - } - ## exp_cor (2) - if (!is.null(exp_cor)) { - if (!('pr' %in% names(exp_cor))) { - stop("Variable 'pr' is not included in 'exp_cor'.") - } - if (length(pet_method) == 1) { - pet_method <- rep(pet_method, 2) - } - } - ## time_dim - if (!is.character(time_dim) | length(time_dim) != 1) { - stop("Parameter 'time_dim' must be a character string.") - } - if (!all(sapply(exp, function(x) time_dim %in% names(dim(x))))) { - stop("Parameter 'time_dim' is not found in 'exp' dimension.") - } - if (!is.null(exp_cor)) { - if (!all(sapply(exp_cor, function(x) time_dim %in% names(dim(x))))) { - stop("Parameter 'time_dim' is not found in 'exp_cor' dimension.") - } - } - ## leadtime_dim - if (!is.character(leadtime_dim) | length(leadtime_dim) != 1) { - stop("Parameter 'leadtime_dim' must be a character string.") - } - if (!all(sapply(exp, function(x) leadtime_dim %in% names(dim(x))))) { - stop("Parameter 'leadtime_dim' is not found in 'exp' dimension.") - } - if (!is.null(exp_cor)) { - if (!all(sapply(exp_cor, function(x) leadtime_dim %in% names(dim(x))))) { - stop("Parameter 'leadtime_dim' is not found in 'exp_cor' dimension.") - } - } - ## memb_dim - if (!is.character(memb_dim) | length(memb_dim) != 1) { - stop("Parameter 'memb_dim' must be a character string.") - } - if (!all(sapply(exp, function(x) memb_dim %in% names(dim(x))))) { - stop("Parameter 'memb_dim' is not found in 'exp' dimension.") - } - if (!is.null(exp_cor)) { - if (!all(sapply(exp_cor, function(x) memb_dim %in% names(dim(x))))) { - stop("Parameter 'memb_dim' is not found in 'exp_cor' dimension.") - } - } - ## lat_dim - if (!is.character(lat_dim) | length(lat_dim) != 1) { - stop("Parameter 'lat_dim' must be a character string.") - } - if (!all(sapply(exp, function(x) lat_dim %in% names(dim(x))))) { - stop("Parameter 'lat_dim' is not found in 'exp' dimension.") - } - if (!is.null(exp_cor)) { - if (!all(sapply(exp_cor, function(x) lat_dim %in% names(dim(x))))) { - stop("Parameter 'lat_dim' is not found in 'exp_cor' dimension.") - } - } - ## dates - if (is.null(dates_exp)) { - stop("Parameter 'dates_exp' is missing, dates must be provided.") - } - if (!any(inherits(dates_exp, 'Date'), inherits(dates_exp, 'POSIXct'))) { - stop("Parameter 'dates_exp' is not of the correct class, ", - "only 'Date' and 'POSIXct' classes are accepted.") - } - if (!time_dim %in% names(dim(dates_exp)) | !leadtime_dim %in% names(dim(dates_exp))) { - stop("Parameter 'dates_exp' must have 'time_dim' and 'leadtime_dim' ", - "dimension.") - } - if (!all(dim(exp[[1]])[c(time_dim, leadtime_dim)] == - dim(dates_exp)[c(time_dim, leadtime_dim)])) { - stop("Parameter 'dates_exp' needs to have the same length as 'time_dim' ", - "and 'leadtime_dim' as 'exp'.") - } - if (!is.null(exp_cor)) { - if (is.null(dates_expcor)) { - stop("Parameter 'dates_expcor' is missing, dates for 'exp_cor' must be ", - "provided if exp_cor is not NULL.") - } - if (!any(inherits(dates_expcor, 'Date'), inherits(dates_expcor, 'POSIXct'))) { - stop("Element 'Dates' in 'exp_cor' is not of the correct class, ", - "only 'Date' and 'POSIXct' classes are accepted.") - } - if (!time_dim %in% names(dim(dates_expcor)) | !leadtime_dim %in% names(dim(dates_expcor))) { - stop("Parameter 'dates_expcor' must have 'time_dim' and 'leadtime_dim' ", - "dimension.") - } - if (!all(dim(exp_cor[[1]])[c(time_dim, leadtime_dim)] == - dim(dates_expcor)[c(time_dim, leadtime_dim)])) { - stop("Parameter 'dates_expcor' needs to have the same length as ", - "'time_dim' and 'leadtime_dim' as 'exp_cor'.") - } - } - ## accum - if (accum > dim(exp[[1]])[leadtime_dim]) { - stop(paste0("Cannot compute accumulation of ", accum, " months because ", - "loaded data has only ", dim(exp[[1]])[leadtime_dim], " months.")) - } - ## standardization - if (!is.logical(standardization)) { - stop("Parameter 'standardization' must be a logical value.") - } - ## na.rm - if (!is.logical(na.rm)) { - stop("Parameter 'na.rm' must be logical.") - } - - # Complete dates - dates <- .return2list(dates_exp, dates_expcor) - - # Compute PeriodSPEI - k = 0 - spei_res <- NULL - computed_pet <- FALSE - accumulated <- list(NULL, NULL) - for (data in .return2list(exp, exp_cor)) { - k = k + 1 - # Evapotranspiration estimation (unless pet is already provided) - if (is.null(pet[[k]]) | computed_pet) { - pet[[k]] <- PeriodPET(data = data, dates = dates[[k]], - lat = lat, pet_method = pet_method[k], - time_dim = time_dim, leadtime_dim = leadtime_dim, - lat_dim = lat_dim, na.rm = na.rm, ncores = ncores) - computed_pet <- TRUE - } - if (!na.rm & any(is.na(pet[[k]]))) { - mask_na <- which(is.na(pet[[k]])) - warning("There are NAs in PET.") - } - - # Accumulation - diff_p_pet <- data$pr - pet[[k]] - accumulated[[k]] <- PeriodAccumulation(data = diff_p_pet, dates = dates[[k]], - rollwidth = accum, time_dim = leadtime_dim, - sdate_dim = time_dim, frequency = 'monthly', - ncores = ncores) - } - - if (standardization) { - # Standardization - spei <- PeriodStandardization(data = accumulated[[1]], - data_cor = accumulated[[2]], - dates = dates[[1]], - params = params, - time_dim = time_dim, - leadtime_dim = leadtime_dim, - memb_dim = memb_dim, ref_period = ref_period, - handle_infinity = handle_infinity, - return_params = return_params, - method = method, distribution = distribution, - na.rm = TRUE, ncores = ncores) - } else { - spei <- accumulated[[k]] - } - return(spei) -} \ No newline at end of file diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd deleted file mode 100644 index 9c2c357..0000000 --- a/man/CST_PeriodSPEI.Rd +++ /dev/null @@ -1,209 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PeriodSPEI.R -\name{CST_PeriodSPEI} -\alias{CST_PeriodSPEI} -\title{Compute the Standardised Precipitation-Evapotranspiration Index} -\usage{ -CST_PeriodSPEI( - exp, - exp_cor = NULL, - time_dim = "syear", - leadtime_dim = "time", - memb_dim = "ensemble", - lat_dim = "latitude", - accum = 1, - ref_period = NULL, - params = NULL, - pet_exp = NULL, - pet_expcor = NULL, - standardization = TRUE, - pet_method = "hargreaves", - method = "parametric", - distribution = "log-Logistic", - handle_infinity = FALSE, - return_params = FALSE, - na.rm = FALSE, - ncores = NULL -) -} -\arguments{ -\item{exp}{A named list with the needed \code{s2dv_cube} objects containing -the seasonal forecast experiment in the data element for each variable. -Specific variables are needed for each method used in computing the -Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and -'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. -Variable 'pr' is always needed. The units for temperature variables -('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -precipitation ('pr') need to be in mm/month.} - -\item{exp_cor}{A named list with the needed \code{s2dv_cube} objects for each -variable in which the quantile PeriodSPEI should be applied. If it is not -specified, the PeriodSPEI is calculated from object 'exp'.} - -\item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'syear'.} - -\item{leadtime_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'time'.} - -\item{memb_dim}{A character string indicating the name of the dimension in -which the ensemble members are stored. When set it to NULL, threshold is -computed for individual members.} - -\item{lat_dim}{A character string indicating the name of the latitudinal -dimension. By default it is set by 'latitude'.} - -\item{accum}{An integer value indicating the number of months for the -accumulation for each variable. When it is greater than 1, the result will -be filled with NA until the accum 'time_dim' dimension number due to the -accumulation to previous months. The accumulation is performed backwards -by default.} - -\item{ref_period}{A list with two numeric values with the starting and end -points of the reference period used for computing the index. The default -value is NULL indicating that the first and end values in data will be -used as starting and end points.} - -\item{params}{A multidimensional array with named dimensions for computing the -SPEI. This option overrides computation of fitting parameters. It needs -to have the following dimensions: same leadtime dimension of 'exp' -(specified in 'leadtime_dim'); time dimension of length 1 (specified in -'time_dim'); and a dimension named 'coef' with the length of the -coefficients needed for the used distribution (for 'Gamma' coef dimension is -of lenght 2, for 'log-Logistic' is of length 3). It can't have member -dimension (specified in 'memb_dim').} - -\item{pet_exp}{A multidimensional array containing the Potential -EvapoTranspiration data of 'exp'. It must have the same dimensions of the -variable 'pr' of 'exp'. If it is NULL it is calculated using the provided -variables with specified 'pet_method'. It is NULL by default.} - -\item{pet_expcor}{A multidimensional array containing the Potential -EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the -provided variables with specified 'pet_method'. It is NULL by default.} - -\item{standardization}{A logical value indicating wether the standardization -is computed.} - -\item{pet_method}{A character string indicating the method used to compute -the potential evapotranspiration. The accepted methods are: -'hargreaves' and 'hargreaves_modified', that require the data to have -variables tmin and tmax; and 'thornthwaite', that requires variable -'tmean'.} - -\item{method}{A character string indicating the standardization method used. -If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by -default.} - -\item{distribution}{A character string indicating the name of the distribution -function to be used for computing the SPEI. The accepted names are: -'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The -'Gamma' method only works when only precipitation is provided and other -variables are 0 because it is positive defined (SPI indicator). If other -distribution functions want to be used contact the authors.} - -\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) -or not (FALSE).} - -\item{na.rm}{A logical value indicating whether NA values should be removed -from data. It is FALSE by default. If it is FALSE and there are NA values, -(if standardization is TRUE) all values of other dimensions except time_dim -and leadtime_dim will be set to NA directly. On the other hand, if it is -TRUE, if the data from other dimensions except time_dim and leadtime_dim is -not reaching 4 values, it is not enough values to estimate the parameters -and the result will include NA.} - -\item{ncores}{An integer value indicating the number of cores to use in -parallel computation.} -} -\value{ -An 's2dv_cube' object containing the SPEI multidimensional array in -element \code{data} with same dimensions as input data. If 'exp_cor' is -provided, only results from 'exp_cor' will be provided. The parameters of the -standardization will only be returned if 'return_params' is TRUE. The SPEI -will only be computed if 'standardization' is TRUE. If 'standardization' is -FALSE, only the climatic water balance (precipitation minus -evapotranspiration) will be returned. The resultant arrays will have the same -dimensions as the initial input data. The other elements in the 's2dv_cube' -will be updated with the combined information of the input data arrays. -} -\description{ -Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) -that is a multiscalar drought index based on climatic data. It can be used for -determining the onset, duration and magnitude of drought conditions with -respect to normal conditions. The idea behind the SPEI is to compare the -highest possible evapotranspiration with the current water availability. The -SPEI uses for a specific time frequency the difference between precipitation -and potential evapotranspiration. This represents a simple climatic water -balance which is calculated at different time scales to obtain the SPEI. This -function is build to be compatible with other tools in that work with -'s2dv_cube' object class. The input data must be this object class. If you -don't work with 's2dv_cube', see PeriodSPEI. -} -\details{ -Next, some specifications for the calculation of this indicator will be -discussed. On the one hand, the model to be used to calculate Potential -Evapotranspiration is specified with the 'pet_method' parameter (it can be -hargreaves, hargraves modified or thornwhite). On the other hand, to choose -the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is -done using the 'accum' parameter, where you must indicate the number of time -steps you want to accumulate throughout 'leadtime_dim'. The accumulation will -be performed backwards by default. Since the accumulation is done for the -elapsed time steps, there will be no complete accumulations until reaching the -time instant equal to the value of the 'accum' parameter. For this reason, in -the result, we will find that for the dimension where the accumulation has -been carried out, the values of the array will be NA since they do not include -complete accumulations. Also, there is a parameter to specify if the -standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a -probability distribution to transform the original values to standardized -units that are comparable in space and time and at different SPEI time scales. -The 'na.rm' parameter is a logical parameter used to decide whether to remove -the NA values from the data before doing the calculation. It must be taken -into account that if 'na.rm' is FALSE and there is some NA value in the -specific coordinates which the SPEI is computed, standardization cannot be -carried out for those coordinates and therefore, the result will be filled -with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the -amount of data for those specific coordinates is smaller than 4, it will not -be possible to carry out because we will not have enough data and the result -will be also filled with NAs for that coordinates. When only 'exp' is provided -('exp_cor' is NULL) the Standardization is computed with cross validation. For -more information about SPEI calculation, see functions CST_PeriodPET, CST_PeriodAccumulation -and CST_PeriodStandardization. -} -\examples{ -dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, - latitude = 2, longitude = 1, ensemble = 25) -dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, - latitude = 2, longitude = 1, ensemble = 15) - -dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), - paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16")), 'UTC') -dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), - paste0(2020, "-10-16")), 'UTC') -dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) -lat <- c(40,40.1) - -exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) - -expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) - -exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) -exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, - 'pr' = expcor_pr) - -exp <- lapply(exp, CSTools::s2dv_cube, coords = list(latitude = lat), - Dates = dates_exp) -exp_cor <- lapply(exp_cor, CSTools::s2dv_cube, coords = list(latitude = lat), - Dates = dates_expcor) - -res <- CST_PeriodSPEI(exp = exp, exp_cor = exp_cor) - -} diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd deleted file mode 100644 index 21184d3..0000000 --- a/man/PeriodSPEI.Rd +++ /dev/null @@ -1,209 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/PeriodSPEI.R -\name{PeriodSPEI} -\alias{PeriodSPEI} -\title{Compute the Standardised Precipitation-Evapotranspiration Index} -\usage{ -PeriodSPEI( - exp, - dates_exp, - lat, - exp_cor = NULL, - dates_expcor = NULL, - time_dim = "syear", - leadtime_dim = "time", - memb_dim = "ensemble", - lat_dim = "latitude", - accum = 1, - ref_period = NULL, - params = NULL, - pet_exp = NULL, - pet_expcor = NULL, - standardization = TRUE, - pet_method = "hargreaves", - method = "parametric", - distribution = "log-Logistic", - handle_infinity = FALSE, - return_params = FALSE, - na.rm = FALSE, - ncores = NULL -) -} -\arguments{ -\item{exp}{A named list with multidimensional array objects containing -the seasonal forecast experiment in the data element for each variable. -Specific variables are needed for each method used in computing the -Potential Evapotranspiration. See parameter 'pet_method'. The accepted -variables are: 'tmin' and 'tmax', required for methods 'hargreaves' and -'hargreaves_modified' and 'tmean', required for method 'thornthwaite'. -Variable 'pr' is always needed. The units for temperature variables -('tmin', 'tmax' and 'tmean') need to be in Celcius degrees; the units for -precipitation ('pr') need to be in mm/month.} - -\item{dates_exp}{An array of temporal dimensions containing the Dates of -'exp'. It must be of class 'Date' or 'POSIXct'.} - -\item{lat}{A numeric vector containing the latitude values of 'exp'.} - -\item{exp_cor}{A named list with multidimensional array objects for each -variable in which the quantile PeriodSPEI should be applied. If it is not -specified, the PeriodSPEI is calculated from object 'exp'.} - -\item{dates_expcor}{An array of temporal dimensions containing the Dates of -'exp_cor'. It must be of class 'Date' or 'POSIXct'.} - -\item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'syear'.} - -\item{leadtime_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'time'.} - -\item{memb_dim}{A character string indicating the name of the dimension in -which the ensemble members are stored. When set it to NULL, threshold is -computed for individual members.} - -\item{lat_dim}{A character string indicating the name of the latitudinal -dimension. By default it is set by 'latitude'.} - -\item{accum}{accum An integer value indicating the number of months for the -accumulation for each variable. When it is greater than 1, the result will -be filled with NA until the accum time_dim dimension number due to the -accumulation to previous months. The accumulation is performed backwards -by default.} - -\item{ref_period}{A list with two numeric values with the starting and end -points of the reference period used for computing the index. The default -value is NULL indicating that the first and end values in data will be -used as starting and end points.} - -\item{params}{A multidimensional array with named dimensions for computing the -SPEI. This option overrides computation of fitting parameters. It needs -to be of same time dimension (specified in 'time_dim') of 'exp' and a -dimension named 'coef' with the length of the coefficients needed for the -used distribution (for 'Gamma' coef dimension is of lenght 2, for -'log-Logistic' is of length 3). It also needs to have a leadtime dimension -(specified in 'leadtime_dim') of length 1.} - -\item{pet_exp}{A multidimensional array containing the Potential -EvapoTranspiration data of 'exp'. It must have the same dimensions of the -variable 'pr' of 'exp'. If it is NULL it is calculated using the provided -variables with specified 'pet_method'. It is NULL by default.} - -\item{pet_expcor}{A multidimensional array containing the Potential -EvapoTranspiration data of 'exp_cor'. It must have the same dimensions of -the variable 'pr' of 'exp_cor'. If it is NULL it is calculated using the -provided variables with specified 'pet_method'. It is NULL by default.} - -\item{standardization}{A logical value indicating wether the standardization -is computed.} - -\item{pet_method}{A character string indicating the method used to compute -the potential evapotranspiration. The accepted methods are: -'hargreaves' and 'hargreaves_modified', that require the data to have -variables tmin and tmax; and 'thornthwaite', that requires variable -'tmean'.} - -\item{method}{A character string indicating the standardization method used. -If can be: 'parametric' or 'non-parametric'.} - -\item{distribution}{A character string indicating the name of the distribution -function to be used for computing the SPEI. The accepted names are: -'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The -'Gamma' method only works when only precipitation is provided and other -variables are 0 because it is positive defined (SPI indicator).} - -\item{handle_infinity}{A logical value wether to return Infinite values (TRUE) -or not (FALSE).} - -\item{return_params}{A logical value indicating wether to return parameters -array (TRUE) or not (FALSE). It is FALSE by default.} - -\item{na.rm}{A logical value indicating whether NA values should be removed -from data. It is FALSE by default. If it is FALSE and there are NA values, -(if standardization is TRUE) all values of other dimensions except time_dim -and leadtime_dim will be set to NA directly. On the other hand, if it is -TRUE, if the data from other dimensions except time_dim and leadtime_dim is -not reaching 4 values, it is not enough values to estimate the parameters -and the result will include NA.} - -\item{ncores}{An integer value indicating the number of cores to use in -parallel computation.} -} -\value{ -A multidimensional array containing the SPEI with same dimensions as -input data. If 'exp_cor' is provided, only results from 'exp_cor' will be -provided. The parameters of the standardization will only be returned -if 'return_params' is TRUE. The SPEI will only be computed if -'standardization' is TRUE. If 'standardization' is FALSE, only the climatic -water balance (precipitation minus evapotranspiration) will be returned. The -resultant arrays will have the same dimensions as the initial input data. -} -\description{ -Calculation of the Standardised Precipitation-Evapotranspiration Index (SPEI) -that is a multiscalar drought index based on climatic data. It can be used for -determining the onset, duration and magnitude of drought conditions with -respect to normal conditions. The idea behind the SPEI is to compare the -highest possible evapotranspiration with the current water availability. The -SPEI uses for a specific time frequency the difference between precipitation -and potential evapotranspiration. -} -\details{ -Next, some specifications for the calculation of this indicator will be -discussed. On the one hand, the model to be used to calculate Potential -Evapotranspiration is specified with the 'pet_method' parameter (it can be -hargreaves, hargraves modified or thornwhite). On the other hand, to choose -the time scale in which you want to accumulate the SPEI (SPEI3, SPEI6...) is -done using the 'accum' parameter, where you must indicate the number of time -steps you want to accumulate throughout 'leadtime_dim'. The accumulation will -be performed backwards by default. Since the accumulation is done for the -elapsed time steps, there will be no complete accumulations until reaching the -time instant equal to the value of the 'accum' parameter. For this reason, in -the result, we will find that for the dimension where the accumulation has -been carried out, the values of the array will be NA since they do not include -complete accumulations. Also, there is a parameter to specify if the -standardization that can be TRUE or FALSE. If it is TRUE, the data is fit to a -probability distribution to transform the original values to standardized -units that are comparable in space and time and at different SPEI time scales. -The 'na.rm' parameter is a logical parameter used to decide whether to remove -the NA values from the data before doing the calculation. It must be taken -into account that if 'na.rm' is FALSE and there is some NA value in the -specific coordinates which the SPEI is computed, standardization cannot be -carried out for those coordinates and therefore, the result will be filled -with NA for the specific coordinates. However, when 'na.rm' is TRUE, if the -amount of data for those specific coordinates is smaller than 4, it will not -be possible to carry out because we will not have enough data and the result -will be also filled with NAs for that coordinates. When only 'exp' is provided -('exp_cor' is NULL) the Standardization is computed with cross validation. For -more information about SPEI calculation, see functions PeriodPET, -PeriodAccumulation and PeriodStandardization. -} -\examples{ -dims <- c(var = 1, sday = 1, sweek = 1, syear = 6, time = 3, - latitude = 2, longitude = 1, ensemble = 25) -dimscor <- c(var = 1, sday = 1, sweek = 1, syear = 1, time = 3, - latitude = 2, longitude = 1, ensemble = 15) -exp_tmax <- array(rnorm(900, 27.73, 5.26), dim = dims) -exp_tmin <- array(rnorm(900, 14.83, 3.86), dim = dims) -exp_pr <- array(rnorm(900, 21.19, 25.64), dim = dims) - -expcor_tmax <- array(rnorm(540, 29.03, 5.67), dim = dimscor) -expcor_tmin <- array(rnorm(540, 15.70, 4.40), dim = dimscor) -expcor_pr <- array(rnorm(540, 15.62, 21.38), dim = dimscor) - -dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), - paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) -dim(dates_exp) <- c(sday = 1, sweek = 1, syear = 6, time = 3) -dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), - paste0(2020, "-09-15"), - paste0(2020, "-10-16")), 'UTC') -dim(dates_expcor) <- c(sday = 1, sweek = 1, syear = 1, time = 3) -lat <- c(40,40.1) - -exp <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) -exp_cor <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, - 'pr' = expcor_pr) -res <- PeriodSPEI(exp = exp, exp_cor = exp_cor, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor) - -} -- GitLab From 59143d15626ee15083b1a63b42bc472746792c6b Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 15 Nov 2023 17:15:21 +0100 Subject: [PATCH 72/87] Update PeriodAccumulation with last changes --- R/PeriodAccumulation.R | 17 ++++++++++------- man/CST_PeriodAccumulation.Rd | 12 +++++++----- man/PeriodAccumulation.Rd | 4 ++-- 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index e573de9..fff4fd4 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -20,8 +20,8 @@ #'input data must be this object class. If you don't work with 's2dv_cube', see #'PeriodAccumulation. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial m onth of the period. By default it is @@ -74,10 +74,12 @@ #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) #'dim(Dates) <- c(sdate = 3, ftime = 214) #'exp$attrs$Dates <- Dates -#'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) +#'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), +#' time_dim = 'ftime') #'dim(SprR$data) #'head(SprR$attrs$Dates) -#'HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10)) +#'HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10), +#' time_dim = 'ftime') #'dim(HarR$data) #'head(HarR$attrs$Dates) #' @@ -85,7 +87,7 @@ #'@importFrom ClimProjDiags Subset #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', rollwidth = NULL, + time_dim = 'time', rollwidth = NULL, na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -118,6 +120,7 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, data$attrs$Dates <- Dates } if (is.null(rollwidth)) { + data$coords[[time_dim]] <- NULL if (!is.null(dim(Dates))) { # Create time_bounds time_bounds <- NULL @@ -199,9 +202,9 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) #'dim(Dates) <- c(sdate = 3, time = 214) #'SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), -#' end = list(21, 6)) +#' end = list(21, 6), time_dim = 'ftime') #'HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), -#' end = list(21, 10)) +#' end = list(21, 10), time_dim = 'ftime') #' #'@import multiApply #'@importFrom zoo rollapply diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 3de6d4b..2637f02 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -8,15 +8,15 @@ CST_PeriodAccumulation( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", rollwidth = NULL, na.rm = FALSE, ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -98,10 +98,12 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) dim(Dates) <- c(sdate = 3, ftime = 214) exp$attrs$Dates <- Dates -SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) +SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), + time_dim = 'ftime') dim(SprR$data) head(SprR$attrs$Dates) -HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10)) +HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10), + time_dim = 'ftime') dim(HarR$data) head(HarR$attrs$Dates) diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 3e134c8..7aade02 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -92,8 +92,8 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) dim(Dates) <- c(sdate = 3, time = 214) SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), - end = list(21, 6)) + end = list(21, 6), time_dim = 'ftime') HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), - end = list(21, 10)) + end = list(21, 10), time_dim = 'ftime') } -- GitLab From a6a138816fb8f23e268ea300fac709657dc3316a Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 09:26:39 +0100 Subject: [PATCH 73/87] Add imports in DESCRIPTION --- DESCRIPTION | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ea4cb58..b716d5d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,10 +31,14 @@ Depends: Imports: multiApply (>= 2.1.1), stats, - ClimProjDiags + ClimProjDiags, + CSTools, + SPEI, + lmom, + lmomco, + zoo Suggests: testthat, - CSTools, knitr, markdown, rmarkdown -- GitLab From 74f0aa2292d99d1ac43d74d50c532062f9692647 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 12:56:28 +0100 Subject: [PATCH 74/87] Correct unit tests, examples and improve documentation --- R/PeriodAccumulation.R | 34 ++++++++++++++++-------- R/PeriodPET.R | 7 +++-- R/PeriodStandardization.R | 3 ++- R/zzz.R | 6 ++--- man/CST_PeriodAccumulation.Rd | 14 +++++++++- man/CST_PeriodPET.Rd | 8 ++---- man/PeriodAccumulation.Rd | 16 ++++++++--- man/PeriodPET.Rd | 3 ++- tests/testthat/test-PeriodAccumulation.R | 8 +++--- 9 files changed, 65 insertions(+), 34 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index fff4fd4..d5dc059 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -40,6 +40,14 @@ #' applied backwards 'time_dim', if it is negative, it will be forward it. When #' this parameter is NULL, the sum is applied over all 'time_dim', in a #' specified period. It is NULL by default. +#'@param sdate_dim (Only needed when rollwidth is used). A character string +#' indicating the name of the start date dimension to compute the rolling +#' accumulation. By default, it is set to 'sdate'. +#'@param frequency (Only needed when rollwidth is used). A character string +#' indicating the time frequency of the data to apply the rolling accumulation. +#' It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +#' continuous months will be accumulated; if it is 'daliy', values from +#' continuous days will be accumulated. It is set to 'monthly' by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). #'@param ncores An integer indicating the number of cores to use in parallel @@ -63,7 +71,7 @@ #'exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, #' ftime = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' -#'TP <- CST_PeriodAccumulation(exp) +#'TP <- CST_PeriodAccumulation(exp, time_dim = 'ftime') #'exp$data <- array(rnorm(5 * 3 * 214 * 2), #' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), @@ -88,6 +96,7 @@ #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, time_dim = 'time', rollwidth = NULL, + sdate_dim = 'sdate', frequency = 'monthly', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -111,8 +120,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, data$data <- PeriodAccumulation(data = data$data, dates = Dates, start = start, end = end, time_dim = time_dim, rollwidth = rollwidth, - sdate_dim = sdate_dim, na.rm = na.rm, - ncores = ncores) + sdate_dim = sdate_dim, frequency = frequency, + na.rm = na.rm, ncores = ncores) data$dims <- dim(data$data) if (!is.null(start) & !is.null(end)) { Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, @@ -169,19 +178,24 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'time'. More than one -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. +#' compute the indicator. By default, it is set to 'time'. #'@param rollwidth An optional parameter to indicate the number of time #' steps the rolling sum is applied to. If it is positive, the rolling sum is #' applied backwards 'time_dim', if it is negative, it will be forward it. When #' this parameter is NULL, the sum is applied over all 'time_dim', in a #' specified period. It is NULL by default. +#'@param sdate_dim (Only needed when rollwidth is used). A character string +#' indicating the name of the start date dimension to compute the rolling +#' accumulation. By default, it is set to 'sdate'. +#'@param frequency (Only needed when rollwidth is used). A character string +#' indicating the time frequency of the data to apply the rolling accumulation. +#' It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +#' continuous months will be accumulated; if it is 'daliy', values from +#' continuous days will be accumulated. It is set to 'monthly' by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). #'@param ncores An integer indicating the number of cores to use in parallel #' computation. -#' #'@return A multidimensional array with named dimensions containing the #'accumulated data in the element \code{data}. If parameter 'rollwidth' is #'not used, it will have the dimensions of the input 'data' except the dimension @@ -211,8 +225,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, time_dim = 'time', rollwidth = NULL, - sdate_dim = 'sdate', na.rm = FALSE, - frequency = 'daily', ncores = NULL) { + sdate_dim = 'sdate', frequency = 'monthly', + na.rm = FALSE, ncores = NULL) { # Initial checks ## data if (is.null(data)) { @@ -311,8 +325,6 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, return(total) } -data <- array(c(1,3,2,4), dim = c(time = 2, sdate = 2)) - .rollaccumulation <- function(data, mask_dates, rollwidth = 1, forwardroll = FALSE, na.rm = FALSE) { dims <- dim(data) diff --git a/R/PeriodPET.R b/R/PeriodPET.R index de20b2d..2bfefa6 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -23,9 +23,7 @@ #' 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units #' for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius #' degrees; the units for precipitation ('pr') need to be in mm/month. -#'@param dates An array of temporal dimensions containing the Dates of -#' 'data'. It must be of class 'Date' or 'POSIXct'. -#'@param lat A numeric vector containing the latitude values of 'data'. +#' Currently the function works only with monthly data from different years. #'@param pet_method A character string indicating the method used to compute #' the potential evapotranspiration. The accepted methods are: #' 'hargreaves' and 'hargreaves_modified', that require the data to have @@ -128,6 +126,7 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #' 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units #' for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius #' degrees; the units for precipitation ('pr') need to be in mm/month. +#' Currently the function works only with monthly data from different years. #'@param dates An array of temporal dimensions containing the Dates of #' 'data'. It must be of class 'Date' or 'POSIXct'. #'@param lat A numeric vector containing the latitude values of 'data'. @@ -272,7 +271,7 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', } # complete dates - mask_dates <- .datesmask(dates) + mask_dates <- .datesmask(dates, frequency = 'monthly') lat_mask <- array(lat, dim = c(1, length(lat))) names(dim(lat_mask)) <- c('dat', lat_dim) diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 6a83ed4..da693d7 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -316,6 +316,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } ## ref_period if (!is.null(ref_period)) { + years_dates <- format(dates, "%Y") if (is.null(dates)) { warning("Parameter 'dates' is not provided so 'ref_period' can't be ", "used.") @@ -334,7 +335,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, warning("In parameter 'ref_period' 'start' cannot be after 'end'. It ", "will not be used.") ref_period <- NULL - } else if (!all(unlist(ref_period) %in% year(dates))) { + } else if (!all(unlist(ref_period) %in% years_dates)) { warning("Parameter 'ref_period' contain years outside the dates. ", "It will not be used.") ref_period <- NULL diff --git a/R/zzz.R b/R/zzz.R index b108beb..cee01de 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -109,13 +109,13 @@ wind2CF <- function(wind, pc) { } # Function that creates a mask array from dates for the whole year -.datesmask <- function(dates, frequency = 'monthly') { +.datesmask <- function(dates, frequency = 'daily') { years <- format(dates, "%Y") ini <- as.Date(paste(min(years), 01, 01, sep = '-')) end <- as.Date(paste(max(years), 12, 31, sep = '-')) daily <- as.Date(seq(ini, end, by = "day")) if (frequency == 'monthly') { - days <- format(daily, "%d") + days <- as.numeric(format(daily, "%d")) monthly <- daily[which(days == 1)] dates_mask <- array(0, dim = length(monthly)) for (dd in 1:length(dates)) { @@ -134,4 +134,4 @@ wind2CF <- function(wind, pc) { } return(dates_mask) -} \ No newline at end of file +} diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 2637f02..1b8a305 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -10,6 +10,8 @@ CST_PeriodAccumulation( end = NULL, time_dim = "time", rollwidth = NULL, + sdate_dim = "sdate", + frequency = "monthly", na.rm = FALSE, ncores = NULL ) @@ -40,6 +42,16 @@ applied backwards 'time_dim', if it is negative, it will be forward it. When this parameter is NULL, the sum is applied over all 'time_dim', in a specified period. It is NULL by default.} +\item{sdate_dim}{(Only needed when rollwidth is used). A character string +indicating the name of the start date dimension to compute the rolling +accumulation. By default, it is set to 'sdate'.} + +\item{frequency}{(Only needed when rollwidth is used). A character string +indicating the time frequency of the data to apply the rolling accumulation. +It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +continuous months will be accumulated; if it is 'daliy', values from +continuous days will be accumulated. It is set to 'monthly' by default.} + \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -87,7 +99,7 @@ exp <- NULL exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' -TP <- CST_PeriodAccumulation(exp) +TP <- CST_PeriodAccumulation(exp, time_dim = 'ftime') exp$data <- array(rnorm(5 * 3 * 214 * 2), c(memb = 5, sdate = 3, ftime = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd index d705a3c..eb84f25 100644 --- a/man/CST_PeriodPET.Rd +++ b/man/CST_PeriodPET.Rd @@ -26,7 +26,8 @@ for Precipitation is 'pr'. The accepted variable names for each method are: For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius -degrees; the units for precipitation ('pr') need to be in mm/month.} +degrees; the units for precipitation ('pr') need to be in mm/month. +Currently the function works only with monthly data from different years.} \item{pet_method}{A character string indicating the method used to compute the potential evapotranspiration. The accepted methods are: @@ -48,11 +49,6 @@ from data. It is FALSE by default.} \item{ncores}{An integer value indicating the number of cores to use in parallel computation.} - -\item{dates}{An array of temporal dimensions containing the Dates of -'data'. It must be of class 'Date' or 'POSIXct'.} - -\item{lat}{A numeric vector containing the latitude values of 'data'.} } \description{ Compute the Potential evapotranspiration (PET) that is the amount of diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 7aade02..94754d0 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -12,8 +12,8 @@ PeriodAccumulation( time_dim = "time", rollwidth = NULL, sdate_dim = "sdate", + frequency = "monthly", na.rm = FALSE, - frequency = "daily", ncores = NULL ) } @@ -36,9 +36,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'time'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} +compute the indicator. By default, it is set to 'time'.} \item{rollwidth}{An optional parameter to indicate the number of time steps the rolling sum is applied to. If it is positive, the rolling sum is @@ -46,6 +44,16 @@ applied backwards 'time_dim', if it is negative, it will be forward it. When this parameter is NULL, the sum is applied over all 'time_dim', in a specified period. It is NULL by default.} +\item{sdate_dim}{(Only needed when rollwidth is used). A character string +indicating the name of the start date dimension to compute the rolling +accumulation. By default, it is set to 'sdate'.} + +\item{frequency}{(Only needed when rollwidth is used). A character string +indicating the time frequency of the data to apply the rolling accumulation. +It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +continuous months will be accumulated; if it is 'daliy', values from +continuous days will be accumulated. It is set to 'monthly' by default.} + \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd index 1b00339..d8c7747 100644 --- a/man/PeriodPET.Rd +++ b/man/PeriodPET.Rd @@ -28,7 +28,8 @@ for Precipitation is 'pr'. The accepted variable names for each method are: For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius -degrees; the units for precipitation ('pr') need to be in mm/month.} +degrees; the units for precipitation ('pr') need to be in mm/month. +Currently the function works only with monthly data from different years.} \item{dates}{An array of temporal dimensions containing the Dates of 'data'. It must be of class 'Date' or 'POSIXct'.} diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 1ce36d9..0e054ba 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -43,7 +43,8 @@ test_that("1. Initial checks", { ) # Dates subset expect_warning( - CST_PeriodAccumulation(data = dat1_2, start = list(1,2), end = list(2,3)), + CST_PeriodAccumulation(data = dat1_2, start = list(1,2), end = list(2,3), + time_dim = 'ftime'), paste0("Dimensions in 'data' element 'attrs$Dates' are missed and ", "all data would be used."), fixed = TRUE @@ -106,7 +107,8 @@ test_that("2. Seasonal", { c(memb = 1, sdate = 3, lon = 2)) expect_equal( - CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6))$data, + CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), + time_dim = 'ftime')$data, output$data ) }) @@ -218,4 +220,4 @@ test_that("4. Rolling", { start = list(1, 4), end = list(2, 4)), array(c(NA, NA, 4, 6), dim = c(sdate = 2, time = 2, member = 1)) ) -}) \ No newline at end of file +}) -- GitLab From 9265758cfbbe35fa117bcf18ab36558f5d9a4de9 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 14:24:54 +0100 Subject: [PATCH 75/87] Correct example --- R/PeriodAccumulation.R | 4 ++-- man/PeriodAccumulation.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index d5dc059..8893e46 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -207,14 +207,14 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' ftime = 9, lat = 2, lon = 2)) #'TP <- PeriodAccumulation(exp, time_dim = 'ftime') #'data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, time = 214, lon = 2)) +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, time = 214) +#'dim(Dates) <- c(sdate = 3, ftime = 214) #'SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), #' end = list(21, 6), time_dim = 'ftime') #'HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 94754d0..ca01c20 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -91,14 +91,14 @@ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) TP <- PeriodAccumulation(exp, time_dim = 'ftime') data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, time = 214, lon = 2)) + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, time = 214) +dim(Dates) <- c(sdate = 3, ftime = 214) SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), end = list(21, 6), time_dim = 'ftime') HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), -- GitLab From fce7b060cdc84ccd8c01860c140b7275c48c2d1d Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 15:15:13 +0100 Subject: [PATCH 76/87] Add package import stats and correct parameters in .standardization --- DESCRIPTION | 3 ++- NAMESPACE | 3 +++ R/PeriodStandardization.R | 28 +++++++++++++++------------- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b716d5d..a117544 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,7 +36,8 @@ Imports: SPEI, lmom, lmomco, - zoo + zoo, + stats Suggests: testthat, knitr, diff --git a/NAMESPACE b/NAMESPACE index 9b14b18..0065b6e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -50,6 +50,9 @@ importFrom(lmomco,pwm.ub) importFrom(lmomco,pwm2lmom) importFrom(stats,approxfun) importFrom(stats,ecdf) +importFrom(stats,qnorm) importFrom(stats,quantile) +importFrom(stats,sd) +importFrom(stats,window) importFrom(utils,read.delim) importFrom(zoo,rollapply) diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index da693d7..2cd9646 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -230,6 +230,7 @@ CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', #'@importFrom lmomco pwm.pp pwm.ub pwm2lmom are.lmom.valid parglo pargam parpe3 #'@importFrom lmom cdfglo cdfgam cdfpe3 pelglo pelgam pelpe3 #'@importFrom SPEI parglo.maxlik +#'@importFrom stats qnorm sd window #'@export PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, time_dim = 'syear', leadtime_dim = 'time', @@ -419,7 +420,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, res <- Apply(data = list(data), target_dims = c(leadtime_dim, time_dim, memb_dim), fun = .standardization, data_cor = NULL, params = NULL, - leadtime_dim = leadtime_dim, + leadtime_dim = leadtime_dim, time_dim = time_dim, ref_start = ref_start, ref_end = ref_end, handle_infinity = handle_infinity, method = method, distribution = distribution, @@ -430,7 +431,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), params = c(leadtime_dim, time_dim, 'coef')), fun = .standardization, data_cor = NULL, - leadtime_dim = leadtime_dim, + leadtime_dim = leadtime_dim, time_dim = time_dim, ref_start = ref_start, ref_end = ref_end, handle_infinity = handle_infinity, method = method, distribution = distribution, @@ -440,8 +441,8 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } else { res <- Apply(data = list(data = data, data_cor = data_cor), target_dims = c(leadtime_dim, time_dim, memb_dim), - fun = .standardization, - params = NULL, leadtime_dim = leadtime_dim, + fun = .standardization, params = NULL, + leadtime_dim = leadtime_dim, time_dim = time_dim, ref_start = ref_start, ref_end = ref_end, handle_infinity = handle_infinity, method = method, distribution = distribution, @@ -473,7 +474,8 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } } -.standardization <- function(data, data_cor = NULL, params = NULL, leadtime_dim = 'time', +.standardization <- function(data, data_cor = NULL, params = NULL, + leadtime_dim = 'time', time_dim = 'syear', ref_start = NULL, ref_end = NULL, handle_infinity = FALSE, method = 'parametric', distribution = 'log-Logistic', return_params = FALSE, na.rm = FALSE) { @@ -500,12 +502,12 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, for (i in 1:length(data2)) { bp[i,1] = sum(data2[] <= data2[i], na.rm = na.rm); # Writes the rank of the data } - std_index <- qnorm((bp - 0.44)/(length(data2) + 0.12)) + std_index <- stats::qnorm((bp - 0.44)/(length(data2) + 0.12)) dim(std_index) <- dims spei_mod[ff, , ] <- std_index } else { if (!is.null(ref_start) && !is.null(ref_end)) { - data_fit <- window(data2, ref_start, ref_end) + data_fit <- stats::window(data2, ref_start, ref_end) } else { data_fit <- data2 } @@ -519,7 +521,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } f_params <- NA if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { - acu_sd <- sd(acu_sorted) + acu_sd <- stats::sd(acu_sorted) if (!is.na(acu_sd) & acu_sd != 0) { if (distribution != "log-Logistic") { acu_sorted <- acu_sorted[acu_sorted > 0] @@ -542,7 +544,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "Gamma" = lmom::cdfgam(data2, f_params), "PearsonIII" = lmom::cdfpe3(data2, f_params)) } - std_index_cv <- array(qnorm(cdf_res), dim = dims) + std_index_cv <- array(stats::qnorm(cdf_res), dim = dims) spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] if (return_params) params_result[ff, nsd, ] <- f_params } @@ -563,14 +565,14 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, for (i in 1:length(data_cor2)) { bp[i,1] = sum(data_cor2[] <= data_cor2[i], na.rm = na.rm); # Writes the rank of the data } - std_index <- qnorm((bp - 0.44)/(length(data_cor2) + 0.12)) + std_index <- stats::qnorm((bp - 0.44)/(length(data_cor2) + 0.12)) dim(std_index) <- dimscor spei_mod[ff, , ] <- std_index } else { data2 <- data[ff, , ] dim(data2) <- dims if (!is.null(ref_start) && !is.null(ref_end)) { - data_fit <- window(data2, ref_start, ref_end) + data_fit <- stats::window(data2, ref_start, ref_end) } else { data_fit <- data2 } @@ -581,7 +583,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) } if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { - acu_sd <- sd(acu_sorted) + acu_sd <- stats::sd(acu_sorted) if (!is.na(acu_sd) & acu_sd != 0) { if (distribution != "log-Logistic") { acu_sorted <- acu_sorted[acu_sorted > 0] @@ -599,7 +601,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "Gamma" = lmom::cdfgam(data_cor2, f_params), "PearsonIII" = lmom::cdfpe3(data_cor2, f_params)) } - std_index_cv <- array(qnorm(cdf_res), dim = dimscor) + std_index_cv <- array(stats::qnorm(cdf_res), dim = dimscor) spei_mod[ff, , ] <- std_index_cv if (return_params) params_result[ff, , ] <- f_params } -- GitLab From 34d59dc742168d7cbefae8fd2906d1816ab79155 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 15:42:04 +0100 Subject: [PATCH 77/87] Correct DESCRIPTION --- DESCRIPTION | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a117544..b716d5d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,8 +36,7 @@ Imports: SPEI, lmom, lmomco, - zoo, - stats + zoo Suggests: testthat, knitr, -- GitLab From f4d61bd77d6e554dc389113ce091888f77cdb000 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 15:51:35 +0100 Subject: [PATCH 78/87] Develte test from PerodSPEI --- tests/testthat/test-PeriodSPEI.R | 467 ------------------------------- 1 file changed, 467 deletions(-) delete mode 100644 tests/testthat/test-PeriodSPEI.R diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R deleted file mode 100644 index b16bb69..0000000 --- a/tests/testthat/test-PeriodSPEI.R +++ /dev/null @@ -1,467 +0,0 @@ -############################################## -# cube1 -cube1 <- NULL -cube1$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) -class(cube1) <- 's2dv_cube' - -# cube2 -cube2 <- NULL -cube2$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) -class(cube2) <- 's2dv_cube' -cube2$coords <- list(lat = 1:2) - -# cube3 -cube3 <- NULL -cube3$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) -class(cube3) <- 's2dv_cube' -cube3$coords <- list(lat = 1:2) -cube3$attrs$Dates <- as.Date(c(paste0(2010:2014, "-08-16"))) - -# dat1 -dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) -dimscor <- c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) - -set.seed(1) -exp_tmax <- array(rnorm(360, 27.73, 5.26), dim = dims) -set.seed(2) -exp_tmin <- array(rnorm(360, 14.83, 3.86), dim = dims) -set.seed(3) -exp_pr <- array(rnorm(360, 21.19, 25.64), dim = dims) - -set.seed(1) -expcor_tmax <- array(rnorm(60, 29.03, 5.67), dim = dimscor) -set.seed(2) -expcor_tmin <- array(rnorm(60, 15.70, 4.40), dim = dimscor) -set.seed(3) -expcor_pr <- array(rnorm(60, 15.62, 21.38), dim = dimscor) - -dates_exp <- as.POSIXct(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16")), "UTC") -dim(dates_exp) <- c(syear = 6, time = 3) - -dates_expcor <- as.POSIXct(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), - paste0(2020, "-10-16")), "UTC") -dim(dates_expcor) <- c(syear = 1, time = 3) - -lat <- c(40,40.1) - -exp1 <- list('tmax' = exp_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) -exp_cor1 <- list('tmax' = expcor_tmax, 'tmin' = expcor_tmin, 'pr' = expcor_pr) -params1 <- array(abs(rnorm(100)), dim = c(syear = 1, time = 3, latitude = 2, - longitude = 1, coef = 3)) -params2 <- array(abs(rnorm(100)), dim = c(syear = 6, time = 3, latitude = 2, - longitude = 1, coef = 3)) - -# dat2 -dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) -dimscor2 <- c(styear = 1, ftime = 3, lat = 2, lon = 1, member = 15) - -set.seed(1) -exp_tmean <- array(rnorm(100, 17.34, 9.18), dim = dims2) -set.seed(2) -exp_pr <- array(rnorm(360, 21.19, 25.64), dim = dims2) - -set.seed(1) -expcor_tmean <- array(rnorm(100, 17.23, 9.19), dim = dimscor2) -set.seed(2) -expcor_pr <- array(rnorm(60, 15.62, 21.38), dim = dimscor2) - -dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), - paste0(2010:2015, "-10-16"))) -dim(dates_exp2) <- c(sday = 1, sweek = 1, styear = 6, ftime = 3) - -dates_expcor2 <- as.Date(c(paste0(2020, "-08-16"), paste0(2020, "-09-15"), - paste0(2020, "-10-16"))) -dim(dates_expcor2) <- c(sday = 1, sweek = 1, styear = 1, ftime = 3) - -lat <- c(40,40.1) - -exp2 <- list('tmean' = exp_tmean, 'pr' = exp_pr) -exp_cor2 <- list('tmean' = expcor_tmean, 'pr' = expcor_pr) - -# cube4 -cube4_exp <- lapply(exp1, function(x) { - suppressWarnings( - CSTools::s2dv_cube(data = x, coords = list(latitude = c(40, 40.1)), - varName = 'test', Dates = dates_exp) - ) -}) -cube4_expcor <- lapply(exp_cor1, function(x) { - suppressWarnings( - CSTools::s2dv_cube(data = x, coords = list(latitude = c(40, 40.1)), - varName = 'test', Dates = dates_expcor) - ) -}) - -############################################## - -test_that("1. Initial checks CST_PeriodSPEI", { - # Check 's2dv_cube' - expect_error( - CST_PeriodSPEI(exp = NULL), - "Parameter 'exp' cannot be NULL." - ) - expect_error( - CST_PeriodSPEI(exp = array(10)), - "Parameter 'exp' must be a list of 's2dv_cube' class." - ) - # latitude - expect_error( - CST_PeriodSPEI(exp = list(cube1)), - paste0("Spatial coordinate names of parameter 'exp' do not match any ", - "of the names accepted by the package.") - ) - # Dates - expect_error( - CST_PeriodSPEI(exp = list(cube2)), - paste0("Element 'Dates' is not found in 'attrs' list of 'exp'. ", - "See 's2dv_cube' object description in README file for more ", - "information.") - ) - expect_error( - CST_PeriodSPEI(exp = list(cube3), exp_cor = list(cube2)), - paste0("Element 'Dates' is not found in 'attrs' list of 'exp_cor'. ", - "See 's2dv_cube' object description in README file for more ", - "information.") - ) -}) - -############################################## - -test_that("1. Initial checks PeriodSPEI", { - # exp - expect_error( - PeriodSPEI(exp = NULL), - "Parameter 'exp' needs to be a named list with the needed variables." - ) - expect_error( - PeriodSPEI(exp = list(1)), - "Parameter 'exp' needs to be a named list with the variable names." - ) - expect_error( - PeriodSPEI(exp = list(tmax = array(10))), - "Parameter 'exp' needs to be a list of arrays with dimension names." - ) - expect_error( - PeriodSPEI(exp = list(tmax = array(10, c(time = 10)), - tmin = array(10, c(time = 11)))), - "Parameter 'exp' variables need to have the same dimensions." - ) - expect_error( - PeriodSPEI(exp = list(tmax = array(10, c(time = 10)), - tmin = array(10, c(ftime = 10)))), - "Parameter 'exp' variables need to have the same dimensions." - ) - # exp_cor - expect_error( - PeriodSPEI(exp = exp1, exp_cor = 1), - paste0("Parameter 'exp_cor' needs to be a named list with the needed ", - "variables if it is not NULL.") - ) - expect_error( - PeriodSPEI(exp = exp1, exp_cor = list(1)), - "Parameter 'exp_cor' needs to be a named list with the variable names." - ) - expect_error( - PeriodSPEI(exp = exp1, exp_cor = list('tmax' = array(10))), - "Parameter 'exp_cor' needs to be a list of arrays with dimension names." - ) - expect_error( - PeriodSPEI(exp = exp1, exp_cor = list(tmax = array(10, c(time = 10)), - tmin = array(10, c(time = 11)))), - "Parameter 'exp_cor' variables need to have the same dimensions." - ) - expect_error( - PeriodSPEI(exp = exp1, lat = 'lat', dates_exp = dates_exp), - "Parameter 'lat' must be numeric." - ) - expect_error( - PeriodSPEI(exp = list(pr = array(10, c(time = 10, syear = 1, ensemble = 1))), - lat = 1:2, dates_exp = dates_exp), - "Parameter 'lat_dim' is not found in 'exp' dimension." - ) - # exp (2) - expect_warning( - PeriodSPEI(exp = exp1, pet_method = '1', dates_exp = dates_exp, lat = lat), - paste0("Parameter 'pet_method' needs to be 'hargreaves' or ", - "'hargreaves_modified'. It is set to 'hargreaves_modified'.") - ) - # time_dim - expect_error( - PeriodSPEI(exp = exp1, time_dim = 1, dates_exp = dates_exp, lat = lat), - "Parameter 'time_dim' must be a character string." - ) - expect_error( - PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, - dates_exp = dates_exp2, dates_expcor = dates_expcor2, - lat_dim = 'lat', pet_method = 'thornthwaite'), - "Parameter 'time_dim' is not found in 'exp' dimension." - ) - # leadtime_dim - expect_error( - PeriodSPEI(exp = exp1, leadtime_dim = 1, dates_exp = dates_exp, lat = lat), - "Parameter 'leadtime_dim' must be a character string." - ) - expect_error( - PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, - dates_exp = dates_exp2, dates_expcor = dates_expcor2, - lat_dim = 'lat', time_dim = 'ftime', pet_method = 'thornthwaite'), - "Parameter 'leadtime_dim' is not found in 'exp' dimension." - ) - # memb_dim - expect_error( - PeriodSPEI(exp = exp1, memb_dim = 1, dates_exp = dates_exp, lat = lat), - "Parameter 'memb_dim' must be a character string." - ) - expect_error( - PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, - dates_exp = dates_exp2, dates_expcor = dates_expcor2, - lat_dim = 'lat', time_dim = 'ftime', leadtime_dim = 'styear', - pet_method = 'thornthwaite'), - "Parameter 'memb_dim' is not found in 'exp' dimension." - ) - # lat_dim - expect_error( - PeriodSPEI(exp = exp1, lat_dim = 1, dates_exp = dates_exp, lat = lat) - ) - expect_error( - PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, - dates_exp = dates_exp2, dates_expcor = dates_expcor2), - "Parameter 'time_dim' is not found in 'exp' dimension." - ) - # accum - expect_error( - PeriodSPEI(exp = exp1, accum = 10, dates_exp = dates_exp, lat = lat), - "Cannot compute accumulation of 10 months because loaded data has only 3 months." - ) - # ref_period - expect_warning( - PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, - dates_expcor = dates_expcor, lat = lat, ref_period = 1), - paste0("Parameter 'ref_period' must be of length two indicating the ", - "first and end years of the reference period. It will not ", - "be used.") - ) - expect_warning( - PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, - dates_expcor = dates_expcor, lat = lat, ref_period = list('a', 1)), - paste0("Parameter 'ref_period' must be a numeric vector indicating the ", - "'start' and 'end' years of the reference period. It will not ", - "be used.") - ) - expect_warning( - PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, - dates_expcor = dates_expcor, lat = lat, ref_period = list(2012, 2011)), - paste0("In parameter 'ref_period' 'start' cannot be after 'end'. It ", - "will not be used.") - ) - expect_warning( - PeriodSPEI(exp = exp1, exp_cor = exp_cor1, dates_exp = dates_exp, - dates_expcor = dates_expcor, lat = lat, ref_period = list(2008, 2021)), - paste0("Parameter 'ref_period' contain years outside the dates. ", - "It will not be used.") - ) - # standardization - expect_error( - PeriodSPEI(exp = exp1, standardization = 10, dates_exp = dates_exp, lat = lat), - "Parameter 'standardization' must be a logical value." - ) - # handle_infinity - expect_error( - PeriodSPEI(exp = exp1, handle_infinity = 1, dates_exp = dates_exp, lat = lat), - "Parameter 'handle_infinity' must be a logical value." - ) - # method - expect_error( - PeriodSPEI(exp = exp1, method = 1, dates_exp = dates_exp, lat = lat), - paste0("Parameter 'method' must be a character string containing one ", - "of the following methods: 'parametric' or 'non-parametric'.") - ) - # distribution - expect_error( - PeriodSPEI(exp = exp1, distribution = 1, dates_exp = dates_exp, lat = lat), - paste0("Parameter 'distribution' must be a character string containing one ", - "of the following distributions: 'log-Logistic', 'Gamma' or ", - "'PearsonIII'.") - ) - # ncores - expect_error( - PeriodSPEI(exp = exp1, ncores = 1.5, dates_exp = dates_exp, lat = lat), - "Parameter 'ncores' must be a positive integer." - ) -}) - -############################################## - -test_that("2. Output checks: CST_PeriodSPEI", { - res1 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = NULL) - res2 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = cube4_expcor) - res3 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = cube4_expcor, standardization = F) - res4 <- CST_PeriodSPEI(exp = cube4_exp, exp_cor = NULL, return_params = T) - expect_equal( - names(res1), - c("data", "dims", "coords", "attrs") - ) - expect_equal( - res2$attrs$Variable$varName, - "SPEI" - ) - expect_equal( - res3$attrs$Variable$varName, - "Precipitation minus accumulated PET" - ) - expect_equal( - names(res3), - c("data", "dims", "coords", "attrs") - ) - expect_equal( - names(res4), - c("spei", "params") - ) -}) - -############################################## - -test_that("2. Output checks", { - res1 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - return_params = TRUE, na.rm = TRUE) - res2 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - standardization = FALSE) # No info about accumulation - res3 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, return_params = TRUE) - # output dims - expect_equal( - names(res1), - c('spei', 'params') - ) - expect_equal( - dim(res2), - c(syear = 1, time = 3, latitude = 2, longitude = 1, ensemble = 15) - ) - expect_equal( - names(res3), - c('spei', 'params') - ) - expect_equal( - dim(res1[[1]]), - dimscor - ) - expect_equal( - dim(res1[[2]])[which(!names(dim(res1[[2]])) %in% c('coef', 'syear'))], - dims[which(!names(dims) %in% c('syear', 'ensemble'))] - ) - expect_equal( - dim(res2), - dimscor - ) - expect_equal( - dim(res3[[2]]), - c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) - ) - # exp - # exp_cor - # pet - # accum - res11 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, accum = 2, - dates_exp = dates_exp, na.rm = TRUE) - expect_equal( - res11[1,3,1,1,][1:4], - c(-0.6130081, -0.3446050, -0.7267427, -0.6112921), - tolerance = 0.0001 - ) - # ref_period - res_ref <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, accum = 2, - dates_exp = dates_exp, dates_expcor = dates_expcor, - na.rm = TRUE, ref_period = list(2011, 2013)) - expect_equal( - !identical(res1[[1]], res_ref), - TRUE - ) - # params - expect_error( - PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - params = params1, return_params = TRUE), - paste0("Parameter 'data' and 'params' must have same common dimensions ", - "except 'memb_dim' and 'coef'.") - ) - res6 <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - params = params2, return_params = TRUE) - expect_error( - PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - params = array(abs(rnorm(100)), dim = dimscor)), - paste0("Parameter 'params' must be a multidimensional array with named ", - "dimensions: 'syear', 'time' and 'coef'.") - ) - expect_equal( - dim(res6$params), - c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) - ) - # standarization - res4 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, standardization = FALSE) - expect_equal( - names(res4), - NULL - ) - expect_equal( - dim(res4), - c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) - ) - # cross_validation - res_crossval_T <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - return_params = TRUE) - res_crossval_F <- PeriodSPEI(exp = exp1, lat = lat, dates_exp = dates_exp, - return_params = TRUE) - # cross_validation = TRUE - expect_equal( - dim(res_crossval_T$spei), - dims - ) - expect_equal( - dim(res_crossval_T$params), - c(syear = 6, time = 3, latitude = 2, longitude = 1, coef = 3) - ) - - # pet_method - ok - res5 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - pet_method = c('hargreaves', 'hargreaves_modified')) - res6 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - pet_method = c('hargreaves_modified', 'hargreaves')) - expect_equal( - identical(res5, res6), - FALSE - ) - expect_equal( - dim(res5), - dim(res6) - ) - - # time_dim, leadtime_dim, memb_dim, lat_dim - res7 <- PeriodSPEI(exp = exp2, exp_cor = exp_cor2, lat = lat, - dates_exp = dates_exp2, dates_expcor = dates_expcor2, - pet_method = c('thornthwaite', 'thornthwaite'), - lat_dim = 'lat', time_dim = 'styear', - leadtime_dim = 'ftime', memb_dim = 'member') - # method - ok - res8 <- PeriodSPEI(exp = exp1, exp_cor = exp_cor1, lat = lat, - dates_exp = dates_exp, dates_expcor = dates_expcor, - method = 'non-parametric') - # distribution - Only works for 'log-Logistic' - res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, distribution = 'PearsonIII') # NA - res10 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, distribution = 'Gamma') # NA - # param_error - - # handle_infinity - OK - res9 <- PeriodSPEI(exp = exp1, exp_cor = NULL, lat = lat, - dates_exp = dates_exp, handle_infinity = FALSE) - # na.rm - - - # ncores -}) - -############################################## \ No newline at end of file -- GitLab From 232988a15e42db297da72fa3eba12d2fcfcdf08a Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 16:09:10 +0100 Subject: [PATCH 79/87] Correct documentation --- R/PeriodAccumulation.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 0d67630..a9e9f5f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -69,18 +69,18 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, -#' time = 9, lat = 2, lon = 2)) +#' ftime = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' #'TP <- CST_PeriodAccumulation(exp, time_dim = 'ftime') #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, time = 214, lon = 2)) +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(sdate = 3, time = 214) +#'dim(Dates) <- c(sdate = 3, ftime = 214) #'exp$attrs$Dates <- Dates #'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), #' time_dim = 'ftime') @@ -204,8 +204,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' #'@examples #'exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, -#' time = 9, lat = 2, lon = 2)) -#'TP <- PeriodAccumulation(exp, time_dim = 'time') +#' ftime = 9, lat = 2, lon = 2)) +#'TP <- PeriodAccumulation(exp, time_dim = 'ftime') #'data <- array(rnorm(5 * 3 * 214 * 2), #' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), -- GitLab From 7085ab2caa2acc0bb54f37c5949173eab11084d1 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Thu, 16 Nov 2023 16:18:53 +0100 Subject: [PATCH 80/87] Correct unit test --- R/zzz.R | 2 +- man/CST_PeriodAccumulation.Rd | 6 +++--- man/PeriodAccumulation.Rd | 4 ++-- tests/testthat/test-PeriodAccumulation.R | 23 ++++++----------------- 4 files changed, 12 insertions(+), 23 deletions(-) diff --git a/R/zzz.R b/R/zzz.R index 763dc8c..da7c3a1 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -80,7 +80,7 @@ wind2CF <- function(wind, pc) { } # Function that creates a mask array from dates for the whole year -.datesmask <- function(dates, frequency = 'daily') { +.datesmask <- function(dates, frequency = 'monthly') { years <- format(dates, "%Y") ini <- as.Date(paste(min(years), 01, 01, sep = '-')) end <- as.Date(paste(max(years), 12, 31, sep = '-')) diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 1b48e92..4d71ff3 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -97,18 +97,18 @@ PeriodAccumulation. \examples{ exp <- NULL exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, - time = 9, lat = 2, lon = 2)) + ftime = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' TP <- CST_PeriodAccumulation(exp, time_dim = 'ftime') exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, time = 214, lon = 2)) + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(sdate = 3, time = 214) +dim(Dates) <- c(sdate = 3, ftime = 214) exp$attrs$Dates <- Dates SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), time_dim = 'ftime') diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 9b1b970..ca01c20 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -88,8 +88,8 @@ negative, the rolling sum is applied backwards. } \examples{ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, - time = 9, lat = 2, lon = 2)) -TP <- PeriodAccumulation(exp, time_dim = 'time') + ftime = 9, lat = 2, lon = 2)) +TP <- PeriodAccumulation(exp, time_dim = 'ftime') data <- array(rnorm(5 * 3 * 214 * 2), c(memb = 5, sdate = 3, ftime = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 8a990c5..9dcbcf9 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -100,18 +100,6 @@ test_that("1. Initial checks", { ############################################## test_that("2. Seasonal", { - exp <- NULL - exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, time = 214, lon = 2)) - exp$dims <- dim(exp$data) - exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), - as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2001", format = "%d-%m-%Y"), - as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2002", format = "%d-%m-%Y"), - as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) - class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(sum(exp$data[1,1,21:82,1]), sum(exp$data[1,2,21:82,1]), sum(exp$data[1,3,21:82,1]), sum(exp$data[1,1,21:82,2]), @@ -207,29 +195,30 @@ test_that("4. Rolling", { ) # Output checks expect_equal( - PeriodAccumulation(data = dat2, rollwidth = -2, dates = dates2), + PeriodAccumulation(data = dat2, rollwidth = -2, dates = dates2, frequency = 'daily'), array(c(4,6,8, 10, NA, NA), dim = c(sdate = 2, time = 3, member = 1)) ) expect_equal( - PeriodAccumulation(data = dat2, rollwidth = 3, dates = dates2), + PeriodAccumulation(data = dat2, rollwidth = 3, dates = dates2, frequency = 'daily'), array(c(rep(NA, 4), 9, 12), dim = c(sdate = 2, time = 3, member = 1)) ) dat2_1 <- dat2 dat2_1[1,1,1] <- NA expect_equal( - PeriodAccumulation(data = dat2_1, rollwidth = 2, dates = dates2, na.rm = FALSE), + PeriodAccumulation(data = dat2_1, rollwidth = 2, dates = dates2, na.rm = FALSE, + frequency = 'daily'), array(c(rep(NA, 3), 6,8,10), dim = c(sdate = 2, time = 3, member = 1)) ) # Test rolling with start and end expect_equal( PeriodAccumulation(data = dat2, rollwidth = 1, dates = dates2, - start = list(1, 4), end = list(2, 4)), + start = list(1, 4), end = list(2, 4), frequency = 'daily'), array(c(1, 2, 3, 4), dim = c(sdate = 2, time = 2, member = 1)) ) expect_equal( PeriodAccumulation(data = dat2, rollwidth = 2, dates = dates2, - start = list(1, 4), end = list(2, 4)), + start = list(1, 4), end = list(2, 4), frequency = 'daily'), array(c(NA, NA, 4, 6), dim = c(sdate = 2, time = 2, member = 1)) ) }) -- GitLab From 294c052d14d05adcc2c10834b3db910029a4b427 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 17 Nov 2023 14:49:16 +0100 Subject: [PATCH 81/87] Remove specifying NAMESPACE --- R/PeriodAccumulation.R | 6 +++--- R/PeriodPET.R | 26 +++++++++++++------------- R/PeriodStandardization.R | 19 +++++++++---------- 3 files changed, 25 insertions(+), 26 deletions(-) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index a9e9f5f..60245b6 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -133,8 +133,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, if (!is.null(dim(Dates))) { # Create time_bounds time_bounds <- NULL - time_bounds$start <- ClimProjDiags::Subset(Dates, time_dim, 1, drop = 'selected') - time_bounds$end <- ClimProjDiags::Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + time_bounds$start <- Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') # Add Dates in attrs data$attrs$Dates <- time_bounds$start @@ -337,7 +337,7 @@ PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, } } - data_accum <- zoo::rollapply(data = data_vector, width = rollwidth, FUN = sum, na.rm = na.rm) + data_accum <- rollapply(data = data_vector, width = rollwidth, FUN = sum, na.rm = na.rm) if (!forwardroll) { data_accum <- c(rep(NA, rollwidth-1), data_accum) } else { diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 2bfefa6..27d6eca 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -94,12 +94,12 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', metadata <- data[[1]]$attrs$Variable$metadata metadata_names <- intersect(names(dim(res)), names(metadata)) suppressWarnings( - res <- CSTools::s2dv_cube(data = res, coords = coords, - varName = paste0('PET'), - metadata = metadata[metadata_names], - Dates = Dates, - source_files = source_files, - when = Sys.time()) + res <- s2dv_cube(data = res, coords = coords, + varName = paste0('PET'), + metadata = metadata[metadata_names], + Dates = Dates, + source_files = source_files, + when = Sys.time()) ) return(res) } @@ -363,22 +363,22 @@ PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', rm(data_tmp) } if (pet_method == 'hargreaves') { - pet <- SPEI::hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, na.rm = FALSE, verbose = FALSE) + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = FALSE, verbose = FALSE) # line to return the vector to the size of the actual original data pet <- array(pet[which(mask_dates == 1)], dim = dims) } if (pet_method == 'hargreaves_modified') { - pet <- SPEI::hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), - lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, - verbose = FALSE) + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, + verbose = FALSE) pet <- array(pet[which(mask_dates == 1)], dim = dims) } if (pet_method == 'thornthwaite') { - pet <- SPEI::thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, - verbose = FALSE) + pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, + verbose = FALSE) # line to return the vector to the size of the actual original data pet <- array(pet[which(mask_dates == 1)], dim = dims) } diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R index 2cd9646..6ab707e 100644 --- a/R/PeriodStandardization.R +++ b/R/PeriodStandardization.R @@ -341,8 +341,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "It will not be used.") ref_period <- NULL } else { - years <- format(ClimProjDiags::Subset(dates, along = leadtime_dim, - indices = 1), "%Y") + years <- format(Subset(dates, along = leadtime_dim, indices = 1), "%Y") ref_period[[1]] <- which(ref_period[[1]] == years) ref_period[[2]] <- which(ref_period[[2]] == years) } @@ -502,12 +501,12 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, for (i in 1:length(data2)) { bp[i,1] = sum(data2[] <= data2[i], na.rm = na.rm); # Writes the rank of the data } - std_index <- stats::qnorm((bp - 0.44)/(length(data2) + 0.12)) + std_index <- qnorm((bp - 0.44)/(length(data2) + 0.12)) dim(std_index) <- dims spei_mod[ff, , ] <- std_index } else { if (!is.null(ref_start) && !is.null(ref_end)) { - data_fit <- stats::window(data2, ref_start, ref_end) + data_fit <- window(data2, ref_start, ref_end) } else { data_fit <- data2 } @@ -521,7 +520,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, } f_params <- NA if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { - acu_sd <- stats::sd(acu_sorted) + acu_sd <- sd(acu_sorted) if (!is.na(acu_sd) & acu_sd != 0) { if (distribution != "log-Logistic") { acu_sorted <- acu_sorted[acu_sorted > 0] @@ -544,7 +543,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "Gamma" = lmom::cdfgam(data2, f_params), "PearsonIII" = lmom::cdfpe3(data2, f_params)) } - std_index_cv <- array(stats::qnorm(cdf_res), dim = dims) + std_index_cv <- array(qnorm(cdf_res), dim = dims) spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] if (return_params) params_result[ff, nsd, ] <- f_params } @@ -565,14 +564,14 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, for (i in 1:length(data_cor2)) { bp[i,1] = sum(data_cor2[] <= data_cor2[i], na.rm = na.rm); # Writes the rank of the data } - std_index <- stats::qnorm((bp - 0.44)/(length(data_cor2) + 0.12)) + std_index <- qnorm((bp - 0.44)/(length(data_cor2) + 0.12)) dim(std_index) <- dimscor spei_mod[ff, , ] <- std_index } else { data2 <- data[ff, , ] dim(data2) <- dims if (!is.null(ref_start) && !is.null(ref_end)) { - data_fit <- stats::window(data2, ref_start, ref_end) + data_fit <- window(data2, ref_start, ref_end) } else { data_fit <- data2 } @@ -583,7 +582,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) } if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { - acu_sd <- stats::sd(acu_sorted) + acu_sd <- sd(acu_sorted) if (!is.na(acu_sd) & acu_sd != 0) { if (distribution != "log-Logistic") { acu_sorted <- acu_sorted[acu_sorted > 0] @@ -601,7 +600,7 @@ PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, "Gamma" = lmom::cdfgam(data_cor2, f_params), "PearsonIII" = lmom::cdfpe3(data_cor2, f_params)) } - std_index_cv <- array(stats::qnorm(cdf_res), dim = dimscor) + std_index_cv <- array(qnorm(cdf_res), dim = dimscor) spei_mod[ff, , ] <- std_index_cv if (return_params) params_result[ff, , ] <- f_params } -- GitLab From f7dab663dd139d2c0c96169015390a370321616f Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 17 Nov 2023 18:01:08 +0100 Subject: [PATCH 82/87] Develop v 1.1.0 --- DESCRIPTION | 2 +- NEWS.md | 31 +++++-- inst/doc/paper-figure-PlotForecastPDF.R | 104 ------------------------ 3 files changed, 27 insertions(+), 110 deletions(-) delete mode 100644 inst/doc/paper-figure-PlotForecastPDF.R diff --git a/DESCRIPTION b/DESCRIPTION index b716d5d..a54bf19 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: CSIndicators Title: Climate Services' Indicators Based on Sub-Seasonal to Decadal Predictions -Version: 1.0.1 +Version: 1.1.0 Authors@R: c( person("Eva", "Rifà", , "eva.rifarovira@bsc.es", role = c("cre")), person("Nuria", "Perez-Zanon", , "nuria.perez@bsc.es", role = c("aut"), comment = c(ORCID = "0000-0001-8568-3071")), diff --git a/NEWS.md b/NEWS.md index 44285d2..3f6308b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,19 +1,40 @@ +# CSIndicators 1.1.0 (Release date: 2023-11-20) + +### Fixes +- Improve CST_PeriodMean() and CST_PeriodAccumulation() in order that Dates from the s2dv_cube reflect time aggregation. +- Correct output coordinates consistency (coords element) in CST functions +- Include again ClimProjDiags and s2dv dependency due to a dependency issue with an external package. +- Change default value of time_dim to be 'time' in all the function. +- Improve documentation of function MergeRefToExp mentioned the method used. + +### New features +- Include new publication in documentation. +- Change to testthat edition 3. +- Add 'memb_dim' parameter to MergeRefToExp. +- Add reference and improve documentation in MergeRefToExp. +- Substitute CST_Load by CST_Start in vignettes. +- New functions to compute SPEI: PeriodPET, PeriodAccumulation with rolling accumulation and PeriodStandardization. +- New functions to compute bioclimatic indicators: PeriodMax, PeriodMin and PeriodVariance. + # CSIndicators 1.0.1 (Release date: 2023-05-18) -**Fixes** + +### Fixes - Add EnergyIndicators vignette figures - Remove ClimProjDiags dependency - Remove s2dv dependency -# CSIndicators 1.0.0 (Release date: 2023-04-05) -**Fixes** +# CSIndicators 1.0.0 (Release date: 2023-04-05) + +### Fixes - Correct vignettes figures links. -**New features** +### New features - Exceeding Threshold functions to allow between thresholds or equal threshold options. - New s2dv_cube object development for all the functions, unit tests, examples and vignettes. # CSIndicators 0.0.2 (Release date: 2022-10-21) -**Fixes** + +### Fixes - Correct figures of EnergyIndicators vignette. - Sanity check correction in functions CST_PeriodAccumulation, CST_AbsToProbs, CST_AccumulationExceedingThreshold, CST_MergeRefToExp, CST_PeriodMean, CST_QThreshold, CST_SelectPeriodOnData, CST_Threshold, TotalSpellTimeExceedingThreshold, CST_TotalTimeExceedingThreshold, CST_WindCapacityFactor and CST_WindPowerDensity. - Revise examples using s2dv::InsertDim in MergeRefToExp(). diff --git a/inst/doc/paper-figure-PlotForecastPDF.R b/inst/doc/paper-figure-PlotForecastPDF.R deleted file mode 100644 index bebc497..0000000 --- a/inst/doc/paper-figure-PlotForecastPDF.R +++ /dev/null @@ -1,104 +0,0 @@ -rm(list=ls()) - -### Creation date: January 2023 -# Author: N. Pérez-Zanón -# For CSIndicators package manuscript -# ---------------------------------------- -# Figure 1. sprR probability distribution of the forecast initialised on the 1st -# of April 2022 for the western Iberian peninsula. The daily values of the -# hindcast and forecast have been corrected before calculating the sprR and the -# spatial aggregation. The adjusted hindcast has been used to calculate the -# fRPSS and the terciles and extremes thresholds. -# ---------------------------------------- - -library(CSIndicators) -library(CSTools) -library(zeallot) -library(s2dv) - -S5path <- list(name = 'SEAS5', - path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_s0-24h/$VAR_NAME$_$START_DATE$.nc') - -ERA5path <- list(name = 'ERA5', - path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - -sdates <- paste0(1993:2016, '04', '01') - -c(hcst, hcst_ref) %<-% CST_Load(var = 'prlr', - exp = list(S5path), - obs = list(ERA5path), - sdates = sdates, - lonmin = -10, lonmax = 0, - latmin = 35, latmax = 40, - storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, - nmember = 25, output = "lonlat") -hcst$data <- hcst$data * 3600 * 24 * 1000 -hcst$attrs$Variable$metadata$prlr$units <- 'mm' -hcst_ref$data <- hcst_ref$data * 3600 * 24 * 1000 -hcst_ref$attrs$Variable$metadata$prlr$units <- 'mm' - - -c(fcst, obs) %<-% CST_Load(var = 'prlr', - exp = list(S5path), - obs = list(ERA5path), - sdates = '20220401', - lonmin = -10, lonmax = 0, - latmin = 35, latmax = 40, - storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, - nmember = 50, output = "lonlat") -fcst$data <- fcst$data * 1000 * 3600 * 24 -fcst$attrs$Variable$metadata$prlr$units <- 'mm' -obs$data <- obs$data * 1000 * 3600 * 24 -obs$attrs$Variable$metadata$prlr$units <- 'mm' - - -fcst_QM <- CST_QuantileMapping(exp = hcst, - obs = hcst_ref, - exp_cor = fcst, wet = TRUE, - ncores = 6) -hcst_QM <- CST_QuantileMapping(exp = hcst, - obs = hcst_ref, wet = TRUE, - ncores = 6) - -sprR_fcst <- CST_PeriodAccumulation(fcst_QM, - start = list(21,4), - end = list(21,6), na.rm = FALSE, - time_dim = 'ftime', ncores = 6) -sprR_hcst_ref <- CST_PeriodAccumulation(hcst_ref, - start = list(21,4), - end = list(21,6), - time_dim = 'ftime', ncores = 6) -sprR_obs <- CST_PeriodAccumulation(obs, - start = list(21,4), - end = list(21,6), - time_dim = 'ftime', ncores = 6) -sprR_hcst <- CST_PeriodAccumulation(hcst_QM, - start = list(21,4), - end = list(21,6), - time_dim = 'ftime', ncores = 6) - -sprR_fcst$data <- MeanDims(sprR_fcst$data, c('lat', 'lon')) -sprR_hcst_ref$data <- MeanDims(sprR_hcst_ref$data, c('lat', 'lon')) -sprR_obs$data <- MeanDims(sprR_obs$data, c('lat', 'lon')) -sprR_hcst$data <- MeanDims(sprR_hcst$data, c('lat', 'lon')) - - -metric <- RPSS(sprR_hcst$data, obs = sprR_hcst_ref$data) - -terciles <- quantile(sprR_hcst$data, c(0.33, 0.66)) -extremes <- quantile(sprR_hcst$data, c(0.10, 0.90)) - -dim(sprR_fcst$data) <- c(member = 50, sdate = 1) -PlotForecastPDF(sprR_fcst$data, - tercile.limits = as.vector(terciles), - extreme.limits = extremes, - var.name = "sprR (mm)", - title = "Seasonal forecasts at West Iberian Peninsula", - fcst.names = paste("Start date: 2022-04-01\n fRPSS:", - round(metric$rpss, 3)), - obs = as.vector(sprR_obs$data), - plotfile = "sprR_PlotForecast_csindicators_2022.png") - - -- GitLab From 34597453da18f5a1dfdc8e84afb4ba714a24ff7f Mon Sep 17 00:00:00 2001 From: EVA RIFA ROVIRA Date: Mon, 20 Nov 2023 10:44:35 +0100 Subject: [PATCH 83/87] Change NEWS order --- NEWS.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/NEWS.md b/NEWS.md index 3f6308b..c3047f9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,13 +8,13 @@ - Improve documentation of function MergeRefToExp mentioned the method used. ### New features -- Include new publication in documentation. -- Change to testthat edition 3. +- New functions to compute SPEI: PeriodPET, PeriodAccumulation with rolling accumulation and PeriodStandardization. +- New functions to compute bioclimatic indicators: PeriodMax, PeriodMin and PeriodVariance. - Add 'memb_dim' parameter to MergeRefToExp. - Add reference and improve documentation in MergeRefToExp. - Substitute CST_Load by CST_Start in vignettes. -- New functions to compute SPEI: PeriodPET, PeriodAccumulation with rolling accumulation and PeriodStandardization. -- New functions to compute bioclimatic indicators: PeriodMax, PeriodMin and PeriodVariance. +- Include new publication in documentation. +- Change to testthat edition 3. # CSIndicators 1.0.1 (Release date: 2023-05-18) -- GitLab From 76a90a4e223948988c82ccc662d6468f90868566 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 20 Nov 2023 10:49:10 +0100 Subject: [PATCH 84/87] Add doc that was deleted --- inst/doc/paper-figure-PlotForecastPDF.R | 104 ++++++++++++++++++++++++ 1 file changed, 104 insertions(+) create mode 100644 inst/doc/paper-figure-PlotForecastPDF.R diff --git a/inst/doc/paper-figure-PlotForecastPDF.R b/inst/doc/paper-figure-PlotForecastPDF.R new file mode 100644 index 0000000..bebc497 --- /dev/null +++ b/inst/doc/paper-figure-PlotForecastPDF.R @@ -0,0 +1,104 @@ +rm(list=ls()) + +### Creation date: January 2023 +# Author: N. Pérez-Zanón +# For CSIndicators package manuscript +# ---------------------------------------- +# Figure 1. sprR probability distribution of the forecast initialised on the 1st +# of April 2022 for the western Iberian peninsula. The daily values of the +# hindcast and forecast have been corrected before calculating the sprR and the +# spatial aggregation. The adjusted hindcast has been used to calculate the +# fRPSS and the terciles and extremes thresholds. +# ---------------------------------------- + +library(CSIndicators) +library(CSTools) +library(zeallot) +library(s2dv) + +S5path <- list(name = 'SEAS5', + path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_s0-24h/$VAR_NAME$_$START_DATE$.nc') + +ERA5path <- list(name = 'ERA5', + path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') + +sdates <- paste0(1993:2016, '04', '01') + +c(hcst, hcst_ref) %<-% CST_Load(var = 'prlr', + exp = list(S5path), + obs = list(ERA5path), + sdates = sdates, + lonmin = -10, lonmax = 0, + latmin = 35, latmax = 40, + storefreq = 'daily', + leadtimemin = 1, leadtimemax = 214, + nmember = 25, output = "lonlat") +hcst$data <- hcst$data * 3600 * 24 * 1000 +hcst$attrs$Variable$metadata$prlr$units <- 'mm' +hcst_ref$data <- hcst_ref$data * 3600 * 24 * 1000 +hcst_ref$attrs$Variable$metadata$prlr$units <- 'mm' + + +c(fcst, obs) %<-% CST_Load(var = 'prlr', + exp = list(S5path), + obs = list(ERA5path), + sdates = '20220401', + lonmin = -10, lonmax = 0, + latmin = 35, latmax = 40, + storefreq = 'daily', + leadtimemin = 1, leadtimemax = 214, + nmember = 50, output = "lonlat") +fcst$data <- fcst$data * 1000 * 3600 * 24 +fcst$attrs$Variable$metadata$prlr$units <- 'mm' +obs$data <- obs$data * 1000 * 3600 * 24 +obs$attrs$Variable$metadata$prlr$units <- 'mm' + + +fcst_QM <- CST_QuantileMapping(exp = hcst, + obs = hcst_ref, + exp_cor = fcst, wet = TRUE, + ncores = 6) +hcst_QM <- CST_QuantileMapping(exp = hcst, + obs = hcst_ref, wet = TRUE, + ncores = 6) + +sprR_fcst <- CST_PeriodAccumulation(fcst_QM, + start = list(21,4), + end = list(21,6), na.rm = FALSE, + time_dim = 'ftime', ncores = 6) +sprR_hcst_ref <- CST_PeriodAccumulation(hcst_ref, + start = list(21,4), + end = list(21,6), + time_dim = 'ftime', ncores = 6) +sprR_obs <- CST_PeriodAccumulation(obs, + start = list(21,4), + end = list(21,6), + time_dim = 'ftime', ncores = 6) +sprR_hcst <- CST_PeriodAccumulation(hcst_QM, + start = list(21,4), + end = list(21,6), + time_dim = 'ftime', ncores = 6) + +sprR_fcst$data <- MeanDims(sprR_fcst$data, c('lat', 'lon')) +sprR_hcst_ref$data <- MeanDims(sprR_hcst_ref$data, c('lat', 'lon')) +sprR_obs$data <- MeanDims(sprR_obs$data, c('lat', 'lon')) +sprR_hcst$data <- MeanDims(sprR_hcst$data, c('lat', 'lon')) + + +metric <- RPSS(sprR_hcst$data, obs = sprR_hcst_ref$data) + +terciles <- quantile(sprR_hcst$data, c(0.33, 0.66)) +extremes <- quantile(sprR_hcst$data, c(0.10, 0.90)) + +dim(sprR_fcst$data) <- c(member = 50, sdate = 1) +PlotForecastPDF(sprR_fcst$data, + tercile.limits = as.vector(terciles), + extreme.limits = extremes, + var.name = "sprR (mm)", + title = "Seasonal forecasts at West Iberian Peninsula", + fcst.names = paste("Start date: 2022-04-01\n fRPSS:", + round(metric$rpss, 3)), + obs = as.vector(sprR_obs$data), + plotfile = "sprR_PlotForecast_csindicators_2022.png") + + -- GitLab From 10797be794d098ebf87e491a468bf824428b538b Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 20 Nov 2023 10:51:47 +0100 Subject: [PATCH 85/87] Add line in Rbuildignore for issue template --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index c0e2736..83f840f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,5 +1,6 @@ .*\.git$ .*\.gitignore$ +.*\.gitlab$ .*\.tar.gz$ .*\.pdf$ ./.nc$ -- GitLab From c409518f6aa48f702ffd589f335410b017b923a8 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Mon, 20 Nov 2023 11:32:03 +0100 Subject: [PATCH 86/87] Correct item lists in documentation --- R/AccumulationExceedingThreshold.R | 8 ++-- R/MergeRefToExp.R | 4 +- R/PeriodAccumulation.R | 16 ++++---- R/PeriodMax.R | 26 ++++++------- R/PeriodMean.R | 16 ++++---- R/PeriodMin.R | 26 ++++++------- R/PeriodVariance.R | 42 ++++++++++----------- R/TotalSpellTimeExceedingThreshold.R | 12 +++--- R/TotalTimeExceedingThreshold.R | 36 +++++++++--------- man/AccumulationExceedingThreshold.Rd | 4 +- man/CST_AccumulationExceedingThreshold.Rd | 4 +- man/CST_MergeRefToExp.Rd | 2 +- man/CST_PeriodAccumulation.Rd | 8 ++-- man/CST_PeriodMax.Rd | 13 +++---- man/CST_PeriodMean.Rd | 8 ++-- man/CST_PeriodMin.Rd | 13 +++---- man/CST_PeriodVariance.Rd | 21 +++++------ man/CST_TotalSpellTimeExceedingThreshold.Rd | 6 +-- man/CST_TotalTimeExceedingThreshold.Rd | 18 ++++----- man/MergeRefToExp.Rd | 2 +- man/PeriodAccumulation.Rd | 8 ++-- man/PeriodMax.Rd | 13 +++---- man/PeriodMean.Rd | 8 ++-- man/PeriodMin.Rd | 13 +++---- man/PeriodVariance.Rd | 21 +++++------ man/TotalSpellTimeExceedingThreshold.Rd | 6 +-- man/TotalTimeExceedingThreshold.Rd | 18 ++++----- 27 files changed, 180 insertions(+), 192 deletions(-) diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index feee031..b8ae9ae 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -8,8 +8,8 @@ #'following agriculture indices for heat stress can be obtained by using this #'function: #'\itemize{ -#' \item\code{GDD}{Summation of daily differences between daily average -#' temperatures and 10°C between April 1st and October 31st} +#' \item{'GDD', Summation of daily differences between daily average +#' temperatures and 10°C between April 1st and October 31st.} #'} #' #'@param data An 's2dv_cube' object as provided function \code{CST_Start} or @@ -151,8 +151,8 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'following agriculture indices for heat stress can be obtained by using this #'function: #'\itemize{ -#' \item\code{GDD}{Summation of daily differences between daily average -#' temperatures and 10°C between April 1st and October 31st} +#' \item{'GDD', Summation of daily differences between daily average +#' temperatures and 10°C between April 1st and October 31st.} #'} #' #'@param data A multidimensional array with named dimensions. diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 56c3c3d..6d9fd6e 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -68,7 +68,7 @@ #'M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and #'N. González-Reviriego (2023). Advanced seasonal predictions for vine #'management based on bioclimatic indicators tailored to the wine sector. -#'Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. +#'Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), @@ -295,7 +295,7 @@ CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, #'M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and #'N. González-Reviriego (2023). Advanced seasonal predictions for vine #'management based on bioclimatic indicators tailored to the wine sector. -#'Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. +#'Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 60245b6..8986e3f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -4,10 +4,10 @@ #'period. Providing precipitation data, two agriculture indices can be obtained #'by using this function: #'\itemize{ -#' \item\code{SprR}{Spring Total Precipitation: The total precipitation from -#' April 21th to June 21st} -#' \item\code{HarR}{Harvest Total Precipitation: The total precipitation from -#' August 21st to October 21st} +#' \item{'SprR', Spring Total Precipitation: The total precipitation from +#' April 21th to June 21st.} +#' \item{'HarR', Harvest Total Precipitation: The total precipitation from +#' August 21st to October 21st.} #'} #' #'There are two possible ways of performing the accumulation. The default one @@ -151,10 +151,10 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'period. Providing precipitation data, two agriculture indices can be obtained #'by using this function: #'\itemize{ -#' \item\code{SprR}{Spring Total Precipitation: The total precipitation from -#' April 21th to June 21st} -#' \item\code{HarR}{Harvest Total Precipitation: The total precipitation from -#' August 21st to October 21st} +#' \item{'SprR', Spring Total Precipitation: The total precipitation from +#' April 21th to June 21st.} +#' \item{'HarR', Harvest Total Precipitation: The total precipitation from +#' August 21st to October 21st.} #'} #' #'There are two possible ways of performing the accumulation. The default one diff --git a/R/PeriodMax.R b/R/PeriodMax.R index 8c56156..3ae23ec 100644 --- a/R/PeriodMax.R +++ b/R/PeriodMax.R @@ -3,13 +3,12 @@ #'Period Max computes the maximum (max) of a given variable in a period. #'Two bioclimatic indicators can be obtained by using this function: #'\itemize{ -#' \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest -#' Month. The maximum monthly temperature occurrence over a -#' given year (time-series) or averaged span of years -#' (normal).} -#' \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest -#' Month. This index identifies the total precipitation -#' that prevails during the wettest month.} +#' \item{'BIO5', (Providing temperature data) Max Temperature of Warmest +#' Month. The maximum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO13', (Providing precipitation data) Precipitation of Wettest +#' Month. This index identifies the total precipitation +#' that prevails during the wettest month.} #'} #' #'@param data An 's2dv_cube' object as provided function \code{CST_Start} or @@ -117,13 +116,12 @@ CST_PeriodMax <- function(data, start = NULL, end = NULL, #'Period max computes the average (max) of a given variable in a period. #'Two bioclimatic indicators can be obtained by using this function: #'\itemize{ -#' \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest -#' Month. The maximum monthly temperature occurrence over a -#' given year (time-series) or averaged span of years -#' (normal).} -#' \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest -#' Month. This index identifies the total precipitation -#' that prevails during the wettest month.} +#' \item{'BIO5', (Providing temperature data) Max Temperature of Warmest +#' Month. The maximum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO13', (Providing precipitation data) Precipitation of Wettest +#' Month. This index identifies the total precipitation +#' that prevails during the wettest month.} #'} #' #'@param data A multidimensional array with named dimensions. diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 9106927..f58bbeb 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -4,10 +4,10 @@ #'Providing temperature data, two agriculture indices can be obtained by using #'this function: #'\itemize{ -#' \item\code{GST}{Growing Season average Temperature: The average temperature -#' from April 1st to Octobe 31st} -#' \item\code{SprTX}{Spring Average Maximum Temperature: The average daily -#' maximum temperature from April 1st to May 31st} +#' \item{'GST', Growing Season average Temperature: The average temperature +#' from April 1st to Octobe 31st.} +#' \item{'SprTX', Spring Average Maximum Temperature: The average daily +#' maximum temperature from April 1st to May 31st.} #'} #' #'@param data An 's2dv_cube' object as provided function \code{CST_Start} or @@ -117,10 +117,10 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'Providing temperature data, two agriculture indices can be obtained by using #'this function: #'\itemize{ -#' \item\code{GST}{Growing Season average Temperature: The average -#' temperature from April 1st to Octobe 31st} -#' \item\code{SprTX}{Spring Average Maximum Temperature: The average daily -#' maximum temperature from April 1st to May 31st} +#' \item{'GST', Growing Season average Temperature: The average temperature +#' from April 1st to Octobe 31st.} +#' \item{'SprTX', Spring Average Maximum Temperature: The average daily +#' maximum temperature from April 1st to May 31st.} #'} #' #'@param data A multidimensional array with named dimensions. diff --git a/R/PeriodMin.R b/R/PeriodMin.R index 74547cc..99ce801 100644 --- a/R/PeriodMin.R +++ b/R/PeriodMin.R @@ -3,13 +3,12 @@ #'Period Min computes the average (min) of a given variable in a period. #'Two bioclimatic indicators can be obtained by using this function: #'\itemize{ -#' \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest -#' Month. The minimum monthly temperature occurrence over a -#' given year (time-series) or averaged span of years -#' (normal).} -#' \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest -#' Month. This index identifies the total precipitation -#' that prevails during the driest month.} +#' \item{'BIO6', (Providing temperature data) Min Temperature of Coldest +#' Month. The minimum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO14', (Providing precipitation data) Precipitation of Driest +#' Month. This index identifies the total precipitation +#' that prevails during the driest month.} #'} #' #'@param data An 's2dv_cube' object as provided function \code{CST_Start} or @@ -117,13 +116,12 @@ CST_PeriodMin <- function(data, start = NULL, end = NULL, #'Period Min computes the average (min) of a given variable in a period. #'Two bioclimatic indicators can be obtained by using this function: #'\itemize{ -#' \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest -#' Month. The minimum monthly temperature occurrence over a -#' given year (time-series) or averaged span of years -#' (normal).} -#' \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest -#' Month. This index identifies the total precipitation -#' that prevails during the driest month.} +#' \item{'BIO6', (Providing temperature data) Min Temperature of Coldest +#' Month. The minimum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO14', (Providing precipitation data) Precipitation of Driest +#' Month. This index identifies the total precipitation +#' that prevails during the driest month.} #'} #' #'@param data A multidimensional array with named dimensions. diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R index f95b8e4..4e1e93e 100644 --- a/R/PeriodVariance.R +++ b/R/PeriodVariance.R @@ -3,17 +3,16 @@ #'Period Variance computes the average (var) of a given variable in a period. #'Two bioclimatic indicators can be obtained by using this function: #'\itemize{ -#' \item\code{BIO4}{(Providing temperature data) Temperature Seasonality -#' (Standard Deviation). The amount of temperature variation -#' over a given year (or averaged years) based on the standard -#' deviation (variation) of monthly temperature averages. } -#' \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality -#' (CV). This is a measure of the variation in -#' monthly precipitation totals over the course of the year. -#' This index is the ratio of the standard deviation of the -#' monthly total precipitation to the mean monthly total -#' precipitation (also known as the coefficient of variation) -#' and is expressed as a percentage} +#' \item{'BIO4', (Providing temperature data) Temperature Seasonality +#' (Standard Deviation). The amount of temperature variation +#' over a given year (or averaged years) based on the standard +#' deviation (variation) of monthly temperature averages.} +#' \item{'BIO15', (Providing precipitation data) Precipitation Seasonality +#' (CV). This is a measure of the variation in monthly precipitation +#' totals over the course of the year. This index is the ratio of the +#' standard deviation of the monthly total precipitation to the mean +#' monthly total precipitation (also known as the coefficient of +#' variation) and is expressed as a percentage.} #'} #' #'@param data An 's2dv_cube' object as provided function \code{CST_Start} or @@ -121,17 +120,16 @@ CST_PeriodVariance <- function(data, start = NULL, end = NULL, #'Period Variance computes the average (var) of a given variable in a period. #'Two bioclimatic indicators can be obtained by using this function: #'\itemize{ -#' \item\code{BIO4}{(Providing temperature data) Temperature Seasonality -#' (Standard Deviation). The amount of temperature variation -#' over a given year (or averaged years) based on the standard -#' deviation (variation) of monthly temperature averages. } -#' \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality -#' (CV). This is a measure of the variation in -#' monthly precipitation totals over the course of the year. -#' This index is the ratio of the standard deviation of the -#' monthly total precipitation to the mean monthly total -#' precipitation (also known as the coefficient of variation) -#' and is expressed as a percentage} +#' \item{'BIO4', (Providing temperature data) Temperature Seasonality +#' (Standard Deviation). The amount of temperature variation +#' over a given year (or averaged years) based on the standard +#' deviation (variation) of monthly temperature averages.} +#' \item{'BIO15', (Providing precipitation data) Precipitation Seasonality +#' (CV). This is a measure of the variation in monthly precipitation +#' totals over the course of the year. This index is the ratio of the +#' standard deviation of the monthly total precipitation to the mean +#' monthly total precipitation (also known as the coefficient of +#' variation) and is expressed as a percentage.} #'} #' #'@param data A multidimensional array with named dimensions. diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index cd2676e..1450703 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -6,9 +6,9 @@ #'This function allows to compute indicators widely used in Climate Services, #'such as: #'\itemize{ -#' \code{WSDI}{Warm Spell Duration Index that count the total number of days -#' with at least 6 consecutive days when the daily temperature -#' maximum exceeds its 90th percentile.} +#' \item{'WSDI', Warm Spell Duration Index that count the total number of days +#' with at least 6 consecutive days when the daily temperature +#' maximum exceeds its 90th percentile.} #'} #'This function requires the data and the threshold to be in the same units. The #'90th percentile can be translate into absolute values given a reference dataset @@ -151,9 +151,9 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'This function allows to compute indicators widely used in Climate Services, #'such as: #'\itemize{ -#' \code{WSDI}{Warm Spell Duration Index that count the total number of days -#' with at least 6 consecutive days when the daily temperature -#' maximum exceeds its 90th percentile.} +#' \item{'WSDI', Warm Spell Duration Index that count the total number of days +#' with at least 6 consecutive days when the daily temperature +#' maximum exceeds its 90th percentile.} #'} #'This function requires the data and the threshold to be in the same units. The #'90th percentile can be translate into absolute values given a reference diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index fa57208..15b822c 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -9,15 +9,15 @@ #'Providing maximum temperature daily data, the following agriculture #'indices for heat stress can be obtained by using this function: #'\itemize{ -#' \item\code{SU35}{Total count of days when daily maximum temperatures exceed -#' 35°C in the seven months from the start month given (e.g. -#' from April to October for start month of April).} -#' \item\code{SU36}{Total count of days when daily maximum temperatures exceed -#' 36 between June 21st and September 21st} -#' \item\code{SU40}{Total count of days when daily maximum temperatures exceed -#' 40 between June 21st and September 21st} -#' \item\code{Spr32}{Total count of days when daily maximum temperatures exceed -#' 32 between April 21st and June 21st} +#' \item{'SU35', Total count of days when daily maximum temperatures exceed +#' 35°C in the seven months from the start month given (e.g. from April +#' to October for start month of April).} +#' \item{'SU36', Total count of days when daily maximum temperatures exceed +#' 36 between June 21st and September 21st.} +#' \item{'SU40', Total count of days when daily maximum temperatures exceed +#' 40 between June 21st and September 21st.} +#' \item{'Spr32', Total count of days when daily maximum temperatures exceed +#' 32 between April 21st and June 21st.} #'} #' #'@param data An 's2dv_cube' object as provided function \code{CST_Start} or @@ -157,15 +157,15 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #'Providing maximum temperature daily data, the following agriculture #'indices for heat stress can be obtained by using this function: #'\itemize{ -#' \item\code{SU35}{Total count of days when daily maximum temperatures exceed -#' 35°C in the seven months from the start month given (e.g. -#' from April to October for start month of April).} -#' \item\code{SU36}{Total count of days when daily maximum temperatures exceed -#' 36 between June 21st and September 21st} -#' \item\code{SU40}{Total count of days when daily maximum temperatures exceed -#' 40 between June 21st and September 21st} -#' \item\code{Spr32}{Total count of days when daily maximum temperatures exceed -#' 32 between April 21st and June 21st} +#' \item{'SU35', Total count of days when daily maximum temperatures exceed +#' 35°C in the seven months from the start month given (e.g. from April +#' to October for start month of April).} +#' \item{'SU36', Total count of days when daily maximum temperatures exceed +#' 36 between June 21st and September 21st.} +#' \item{'SU40', Total count of days when daily maximum temperatures exceed +#' 40 between June 21st and September 21st.} +#' \item{'Spr32', Total count of days when daily maximum temperatures exceed +#' 32 between April 21st and June 21st.} #'} #' #'@param data A multidimensional array with named dimensions. diff --git a/man/AccumulationExceedingThreshold.Rd b/man/AccumulationExceedingThreshold.Rd index cf6c8df..976c967 100644 --- a/man/AccumulationExceedingThreshold.Rd +++ b/man/AccumulationExceedingThreshold.Rd @@ -78,8 +78,8 @@ use a percentile as a scalar, the function \code{Threshold} or following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{GDD}{Summation of daily differences between daily average - temperatures and 10°C between April 1st and October 31st} + \item{'GDD', Summation of daily differences between daily average + temperatures and 10°C between April 1st and October 31st.} } } \examples{ diff --git a/man/CST_AccumulationExceedingThreshold.Rd b/man/CST_AccumulationExceedingThreshold.Rd index 0bea015..ceb9ad7 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -79,8 +79,8 @@ use a percentile as a scalar, the function \code{Threshold} or following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{GDD}{Summation of daily differences between daily average - temperatures and 10°C between April 1st and October 31st} + \item{'GDD', Summation of daily differences between daily average + temperatures and 10°C between April 1st and October 31st.} } } \examples{ diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index 9832912..b95ef79 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -120,5 +120,5 @@ Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and N. González-Reviriego (2023). Advanced seasonal predictions for vine management based on bioclimatic indicators tailored to the wine sector. -Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. +Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. } diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 4d71ff3..c1b4a1c 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -77,10 +77,10 @@ Period Accumulation computes the sum (accumulation) of a given variable in a period. Providing precipitation data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{SprR}{Spring Total Precipitation: The total precipitation from - April 21th to June 21st} - \item\code{HarR}{Harvest Total Precipitation: The total precipitation from - August 21st to October 21st} + \item{'SprR', Spring Total Precipitation: The total precipitation from + April 21th to June 21st.} + \item{'HarR', Harvest Total Precipitation: The total precipitation from + August 21st to October 21st.} } } \details{ diff --git a/man/CST_PeriodMax.Rd b/man/CST_PeriodMax.Rd index a372a1d..3c760ba 100644 --- a/man/CST_PeriodMax.Rd +++ b/man/CST_PeriodMax.Rd @@ -52,13 +52,12 @@ element. Period Max computes the maximum (max) of a given variable in a period. Two bioclimatic indicators can be obtained by using this function: \itemize{ - \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest - Month. The maximum monthly temperature occurrence over a - given year (time-series) or averaged span of years - (normal).} - \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest - Month. This index identifies the total precipitation - that prevails during the wettest month.} + \item{'BIO5', (Providing temperature data) Max Temperature of Warmest + Month. The maximum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO13', (Providing precipitation data) Precipitation of Wettest + Month. This index identifies the total precipitation + that prevails during the wettest month.} } } \examples{ diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index 323adae..3f51041 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -54,10 +54,10 @@ Period Mean computes the average (mean) of a given variable in a period. Providing temperature data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{GST}{Growing Season average Temperature: The average temperature - from April 1st to Octobe 31st} - \item\code{SprTX}{Spring Average Maximum Temperature: The average daily - maximum temperature from April 1st to May 31st} + \item{'GST', Growing Season average Temperature: The average temperature + from April 1st to Octobe 31st.} + \item{'SprTX', Spring Average Maximum Temperature: The average daily + maximum temperature from April 1st to May 31st.} } } \examples{ diff --git a/man/CST_PeriodMin.Rd b/man/CST_PeriodMin.Rd index 9d3833f..97caa6e 100644 --- a/man/CST_PeriodMin.Rd +++ b/man/CST_PeriodMin.Rd @@ -52,13 +52,12 @@ element. Period Min computes the average (min) of a given variable in a period. Two bioclimatic indicators can be obtained by using this function: \itemize{ - \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest - Month. The minimum monthly temperature occurrence over a - given year (time-series) or averaged span of years - (normal).} - \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest - Month. This index identifies the total precipitation - that prevails during the driest month.} + \item{'BIO6', (Providing temperature data) Min Temperature of Coldest + Month. The minimum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO14', (Providing precipitation data) Precipitation of Driest + Month. This index identifies the total precipitation + that prevails during the driest month.} } } \examples{ diff --git a/man/CST_PeriodVariance.Rd b/man/CST_PeriodVariance.Rd index b04b4ed..4d789dd 100644 --- a/man/CST_PeriodVariance.Rd +++ b/man/CST_PeriodVariance.Rd @@ -52,17 +52,16 @@ element. Period Variance computes the average (var) of a given variable in a period. Two bioclimatic indicators can be obtained by using this function: \itemize{ - \item\code{BIO4}{(Providing temperature data) Temperature Seasonality - (Standard Deviation). The amount of temperature variation - over a given year (or averaged years) based on the standard - deviation (variation) of monthly temperature averages. } - \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality - (CV). This is a measure of the variation in - monthly precipitation totals over the course of the year. - This index is the ratio of the standard deviation of the - monthly total precipitation to the mean monthly total - precipitation (also known as the coefficient of variation) - and is expressed as a percentage} + \item{'BIO4', (Providing temperature data) Temperature Seasonality + (Standard Deviation). The amount of temperature variation + over a given year (or averaged years) based on the standard + deviation (variation) of monthly temperature averages.} + \item{'BIO15', (Providing precipitation data) Precipitation Seasonality + (CV). This is a measure of the variation in monthly precipitation + totals over the course of the year. This index is the ratio of the + standard deviation of the monthly total precipitation to the mean + monthly total precipitation (also known as the coefficient of + variation) and is expressed as a percentage.} } } \examples{ diff --git a/man/CST_TotalSpellTimeExceedingThreshold.Rd b/man/CST_TotalSpellTimeExceedingThreshold.Rd index 831bf2c..89d2fb2 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -71,9 +71,9 @@ exceed) a threshold are calculated with \code{TotalSpellTimeExceedingThreshold}. This function allows to compute indicators widely used in Climate Services, such as: \itemize{ -\code{WSDI}{Warm Spell Duration Index that count the total number of days - with at least 6 consecutive days when the daily temperature - maximum exceeds its 90th percentile.} + \item{'WSDI', Warm Spell Duration Index that count the total number of days + with at least 6 consecutive days when the daily temperature + maximum exceeds its 90th percentile.} } This function requires the data and the threshold to be in the same units. The 90th percentile can be translate into absolute values given a reference dataset diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index db9a3d6..e0b8ed4 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -76,15 +76,15 @@ variable units, i.e. to use a percentile as a scalar, the function Providing maximum temperature daily data, the following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{SU35}{Total count of days when daily maximum temperatures exceed - 35°C in the seven months from the start month given (e.g. - from April to October for start month of April).} - \item\code{SU36}{Total count of days when daily maximum temperatures exceed - 36 between June 21st and September 21st} - \item\code{SU40}{Total count of days when daily maximum temperatures exceed - 40 between June 21st and September 21st} - \item\code{Spr32}{Total count of days when daily maximum temperatures exceed - 32 between April 21st and June 21st} + \item{'SU35', Total count of days when daily maximum temperatures exceed + 35°C in the seven months from the start month given (e.g. from April + to October for start month of April).} + \item{'SU36', Total count of days when daily maximum temperatures exceed + 36 between June 21st and September 21st.} + \item{'SU40', Total count of days when daily maximum temperatures exceed + 40 between June 21st and September 21st.} + \item{'Spr32', Total count of days when daily maximum temperatures exceed + 32 between April 21st and June 21st.} } } \examples{ diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index 81cda03..e524ead 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -120,5 +120,5 @@ Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and N. González-Reviriego (2023). Advanced seasonal predictions for vine management based on bioclimatic indicators tailored to the wine sector. -Climate Services, 30, 100343, \doi{doi.org/10.1016/j.cliser.2023.100343}. +Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. } diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index ca01c20..71b7d73 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -72,10 +72,10 @@ Period Accumulation computes the sum (accumulation) of a given variable in a period. Providing precipitation data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{SprR}{Spring Total Precipitation: The total precipitation from - April 21th to June 21st} - \item\code{HarR}{Harvest Total Precipitation: The total precipitation from - August 21st to October 21st} + \item{'SprR', Spring Total Precipitation: The total precipitation from + April 21th to June 21st.} + \item{'HarR', Harvest Total Precipitation: The total precipitation from + August 21st to October 21st.} } } \details{ diff --git a/man/PeriodMax.Rd b/man/PeriodMax.Rd index cb776d2..762b3c9 100644 --- a/man/PeriodMax.Rd +++ b/man/PeriodMax.Rd @@ -51,13 +51,12 @@ indicator in the element \code{data}. Period max computes the average (max) of a given variable in a period. Two bioclimatic indicators can be obtained by using this function: \itemize{ - \item\code{BIO5}{(Providing temperature data) Max Temperature of Warmest - Month. The maximum monthly temperature occurrence over a - given year (time-series) or averaged span of years - (normal).} - \item\code{BIO13}{(Providing precipitation data) Precipitation of Wettest - Month. This index identifies the total precipitation - that prevails during the wettest month.} + \item{'BIO5', (Providing temperature data) Max Temperature of Warmest + Month. The maximum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO13', (Providing precipitation data) Precipitation of Wettest + Month. This index identifies the total precipitation + that prevails during the wettest month.} } } \examples{ diff --git a/man/PeriodMean.Rd b/man/PeriodMean.Rd index 9637d58..b639d09 100644 --- a/man/PeriodMean.Rd +++ b/man/PeriodMean.Rd @@ -52,10 +52,10 @@ Period Mean computes the average (mean) of a given variable in a period. Providing temperature data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{GST}{Growing Season average Temperature: The average - temperature from April 1st to Octobe 31st} - \item\code{SprTX}{Spring Average Maximum Temperature: The average daily - maximum temperature from April 1st to May 31st} + \item{'GST', Growing Season average Temperature: The average temperature + from April 1st to Octobe 31st.} + \item{'SprTX', Spring Average Maximum Temperature: The average daily + maximum temperature from April 1st to May 31st.} } } \examples{ diff --git a/man/PeriodMin.Rd b/man/PeriodMin.Rd index 154acf0..597421c 100644 --- a/man/PeriodMin.Rd +++ b/man/PeriodMin.Rd @@ -51,13 +51,12 @@ indicator in the element \code{data}. Period Min computes the average (min) of a given variable in a period. Two bioclimatic indicators can be obtained by using this function: \itemize{ - \item\code{BIO6}{(Providing temperature data) Min Temperature of Coldest - Month. The minimum monthly temperature occurrence over a - given year (time-series) or averaged span of years - (normal).} - \item\code{BIO14}{(Providing precipitation data) Precipitation of Driest - Month. This index identifies the total precipitation - that prevails during the driest month.} + \item{'BIO6', (Providing temperature data) Min Temperature of Coldest + Month. The minimum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO14', (Providing precipitation data) Precipitation of Driest + Month. This index identifies the total precipitation + that prevails during the driest month.} } } \examples{ diff --git a/man/PeriodVariance.Rd b/man/PeriodVariance.Rd index e1e8d7c..9155c4b 100644 --- a/man/PeriodVariance.Rd +++ b/man/PeriodVariance.Rd @@ -51,17 +51,16 @@ indicator in the element \code{data}. Period Variance computes the average (var) of a given variable in a period. Two bioclimatic indicators can be obtained by using this function: \itemize{ - \item\code{BIO4}{(Providing temperature data) Temperature Seasonality - (Standard Deviation). The amount of temperature variation - over a given year (or averaged years) based on the standard - deviation (variation) of monthly temperature averages. } - \item\code{BIO15}{(Providing precipitation data) Precipitation Seasonality - (CV). This is a measure of the variation in - monthly precipitation totals over the course of the year. - This index is the ratio of the standard deviation of the - monthly total precipitation to the mean monthly total - precipitation (also known as the coefficient of variation) - and is expressed as a percentage} + \item{'BIO4', (Providing temperature data) Temperature Seasonality + (Standard Deviation). The amount of temperature variation + over a given year (or averaged years) based on the standard + deviation (variation) of monthly temperature averages.} + \item{'BIO15', (Providing precipitation data) Precipitation Seasonality + (CV). This is a measure of the variation in monthly precipitation + totals over the course of the year. This index is the ratio of the + standard deviation of the monthly total precipitation to the mean + monthly total precipitation (also known as the coefficient of + variation) and is expressed as a percentage.} } } \examples{ diff --git a/man/TotalSpellTimeExceedingThreshold.Rd b/man/TotalSpellTimeExceedingThreshold.Rd index ea1a6ab..d7815bf 100644 --- a/man/TotalSpellTimeExceedingThreshold.Rd +++ b/man/TotalSpellTimeExceedingThreshold.Rd @@ -71,9 +71,9 @@ exceed) a threshold are calculated with \code{TotalSpellTimeExceedingThreshold}. This function allows to compute indicators widely used in Climate Services, such as: \itemize{ -\code{WSDI}{Warm Spell Duration Index that count the total number of days - with at least 6 consecutive days when the daily temperature - maximum exceeds its 90th percentile.} + \item{'WSDI', Warm Spell Duration Index that count the total number of days + with at least 6 consecutive days when the daily temperature + maximum exceeds its 90th percentile.} } This function requires the data and the threshold to be in the same units. The 90th percentile can be translate into absolute values given a reference diff --git a/man/TotalTimeExceedingThreshold.Rd b/man/TotalTimeExceedingThreshold.Rd index 31f3161..5b9627e 100644 --- a/man/TotalTimeExceedingThreshold.Rd +++ b/man/TotalTimeExceedingThreshold.Rd @@ -75,15 +75,15 @@ variable units, i.e. to use a percentile as a scalar, the function Providing maximum temperature daily data, the following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{SU35}{Total count of days when daily maximum temperatures exceed - 35°C in the seven months from the start month given (e.g. - from April to October for start month of April).} - \item\code{SU36}{Total count of days when daily maximum temperatures exceed - 36 between June 21st and September 21st} - \item\code{SU40}{Total count of days when daily maximum temperatures exceed - 40 between June 21st and September 21st} - \item\code{Spr32}{Total count of days when daily maximum temperatures exceed - 32 between April 21st and June 21st} + \item{'SU35', Total count of days when daily maximum temperatures exceed + 35°C in the seven months from the start month given (e.g. from April + to October for start month of April).} + \item{'SU36', Total count of days when daily maximum temperatures exceed + 36 between June 21st and September 21st.} + \item{'SU40', Total count of days when daily maximum temperatures exceed + 40 between June 21st and September 21st.} + \item{'Spr32', Total count of days when daily maximum temperatures exceed + 32 between April 21st and June 21st.} } } \examples{ -- GitLab From 33bf9d46dfebed96cba0138430749b6906ec19d2 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Tue, 21 Nov 2023 17:29:09 +0100 Subject: [PATCH 87/87] Correct DESCRIPTION text with adding commas --- DESCRIPTION | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a54bf19..98fecac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,16 +16,16 @@ Description: Set of generalised tools for the flexible computation of climate mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate - service application (agriculture, food security, energy, water management…). + service application (agriculture, food security, energy, water management, ...). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with 'CSTools'. - This package is described in Pérez-Zanón et al. (2023) - and it was developed in the context of - H2020 MED-GOLD (776467) and S2S4E (776787) projects. See Lledó et al. (2019) - and Chou et al., 2023 - for details. + This package is described in 'Pérez-Zanón et al. (2023) + ' and it was developed in the context of + 'H2020 MED-GOLD' (776467) and 'S2S4E' (776787) projects. See 'Lledó et al. (2019) + ' and 'Chou et al., 2023 + ' for details. Depends: R (>= 3.6.0) Imports: -- GitLab