From 95e6464a82a28d40b00fa55c5bf8e2582a32a7e7 Mon Sep 17 00:00:00 2001 From: allabres Date: Mon, 17 Apr 2023 20:13:07 +0200 Subject: [PATCH 01/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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 20d7a12e3b2a3bf489b677f0808a6a3349fb3dee Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 9 Jun 2023 17:21:21 +0200 Subject: [PATCH 08/19] 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 09/19] 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 10/19] 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 11/19] 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 12/19] 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 13/19] 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 14/19] 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 15/19] 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 710f49ed8e21dc0510873066468c50eb0c5e4a88 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 28 Jun 2023 13:17:12 +0200 Subject: [PATCH 16/19] 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 6f95d8e143cbf58ee7db64f2a3082163cb95096a Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Wed, 5 Jul 2023 17:38:31 +0200 Subject: [PATCH 17/19] 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 ee12d2e380366047c3a6a71d5fb83803d83892dd Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 8 Sep 2023 17:48:02 +0200 Subject: [PATCH 18/19] Correct Accumulation function and ad PeriodPET --- NAMESPACE | 2 + R/PeriodPET.R | 409 ++++++++++++++++ R/PeriodSPEI.R | 789 +++++++++++++------------------ man/CST_PeriodPET.Rd | 85 ++++ man/CST_PeriodSPEI.Rd | 84 ++-- man/PeriodPET.Rd | 84 ++++ man/PeriodSPEI.Rd | 88 ++-- tests/testthat/test-PeriodPET.R | 197 ++++++++ tests/testthat/test-PeriodSPEI.R | 167 +++++-- 9 files changed, 1346 insertions(+), 559 deletions(-) create mode 100644 R/PeriodPET.R create mode 100644 man/CST_PeriodPET.Rd create mode 100644 man/PeriodPET.Rd create mode 100644 tests/testthat/test-PeriodPET.R diff --git a/NAMESPACE b/NAMESPACE index 7cfbe75..7bed2f6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(CST_AccumulationExceedingThreshold) export(CST_MergeRefToExp) export(CST_PeriodAccumulation) export(CST_PeriodMean) +export(CST_PeriodPET) export(CST_PeriodSPEI) export(CST_QThreshold) export(CST_SelectPeriodOnData) @@ -18,6 +19,7 @@ export(CST_WindPowerDensity) export(MergeRefToExp) export(PeriodAccumulation) export(PeriodMean) +export(PeriodPET) export(PeriodSPEI) export(QThreshold) export(SelectPeriodOnData) diff --git a/R/PeriodPET.R b/R/PeriodPET.R new file mode 100644 index 0000000..8ca0aa9 --- /dev/null +++ b/R/PeriodPET.R @@ -0,0 +1,409 @@ +#'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. 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. +#' 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', 'tasmin' and 'tasmax'; for +#' 'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' +#' 'tas' is required. 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 +#' '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 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 +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)) + 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) +} + +#'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. 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. +#' 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', 'tasmin' and 'tasmax'; for +#' 'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' +#' 'tas' is required. 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 +#' '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 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..a767279 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 <- 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 { - source_files_exp <- lapply(exp, function(x) {x$attrs$source_files}) + 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 <- .return2list(dates_exp, dates_expcor) + # Compute PeriodSPEI k = 0 spei_res <- NULL @@ -735,238 +763,56 @@ 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[[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$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) + 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) { - 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) - params <- spei$params - pos <- match(names(dim(data[[1]])), names(dim(spei[[1]]))) - spei[[1]] <- aperm(spei[[1]], pos) + na.rm = TRUE, ncores = ncores) - spei_res[[k]] <- spei[[1]] + ref_period <- NULL + params <- spei$params + 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 } + 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) } - 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) - } - 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 +820,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 +855,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,8 +867,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,10 +888,10 @@ 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)) + spei_mod <- array(param_error, dim(data)) # Add this? } else { if (is.null(ref_period)) { ref.start <- NULL @@ -1087,18 +907,15 @@ PeriodSPEI <- function(exp, dates_exp, lat, 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, + 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 +932,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)) { @@ -1245,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/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd new file mode 100644 index 0000000..b7d9087 --- /dev/null +++ b/man/CST_PeriodPET.Rd @@ -0,0 +1,85 @@ +% 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', 'tasmin' and 'tasmax'; for +'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' +'tas' is required. 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{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.} + +\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. 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) + +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/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/PeriodPET.Rd b/man/PeriodPET.Rd new file mode 100644 index 0000000..2878cc6 --- /dev/null +++ b/man/PeriodPET.Rd @@ -0,0 +1,84 @@ +% 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 for each method are: for 'hargreaves', 'tasmin' and 'tasmax'; for +'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' +'tas' is required. 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 +'data'. It must be of class 'Date' or 'POSIXct'.} + +\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: +'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. 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) + +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-PeriodPET.R b/tests/testthat/test-PeriodPET.R new file mode 100644 index 0000000..ed5a9ac --- /dev/null +++ b/tests/testthat/test-PeriodPET.R @@ -0,0 +1,197 @@ +############################################## + +# 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) + +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(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) + +# 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_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 PeriodPET", { + # 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", { + 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), + 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..7df14d6 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( @@ -309,15 +374,22 @@ 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 + # ) + # 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( - res11$exp[1,2,1,1,][1:4], - c(-0.5553128, 0.4689562, -0.4682003, -0.9956847), - tolerance = 0.0001 + !identical(res1[[1]], res_ref), + TRUE ) - # ref_period # 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 cbeec41ba4c04574300b2b0b71ef6ad89d5ebfb9 Mon Sep 17 00:00:00 2001 From: Eva Rifa Date: Fri, 8 Sep 2023 18:18:05 +0200 Subject: [PATCH 19/19] Change units name --- R/PeriodPET.R | 60 ++++++++--------- R/PeriodSPEI.R | 106 +++++++++++++++---------------- man/CST_PeriodPET.Rd | 16 ++--- man/CST_PeriodSPEI.Rd | 36 +++++------ man/PeriodPET.Rd | 16 ++--- man/PeriodSPEI.Rd | 36 +++++------ tests/testthat/test-PeriodPET.R | 28 ++++---- tests/testthat/test-PeriodSPEI.R | 46 +++++++------- 8 files changed, 172 insertions(+), 172 deletions(-) diff --git a/R/PeriodPET.R b/R/PeriodPET.R index 8ca0aa9..f365d39 100644 --- a/R/PeriodPET.R +++ b/R/PeriodPET.R @@ -15,19 +15,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 for each method are: for 'hargreaves', 'tasmin' and 'tasmax'; for -#' 'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' -#' 'tas' is required. 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 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 -#' 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 @@ -53,7 +53,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) #' @@ -123,19 +123,19 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #' 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', 'tasmin' and 'tasmax'; for -#' 'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' -#' 'tas' is required. 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 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 -#' 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 @@ -161,7 +161,7 @@ CST_PeriodPET <- function(data, pet_method = 'hargreaves', #' #'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) #' @@ -204,20 +204,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' @@ -285,17 +285,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/PeriodSPEI.R b/R/PeriodSPEI.R index a767279..c2a04ec 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. @@ -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('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_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) @@ -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 @@ -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('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_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) #' @@ -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 @@ -775,7 +775,7 @@ PeriodSPEI <- function(exp, dates_exp, lat, } # Accumulation - diff_p_pet <- data$prlr - pet[[k]] + diff_p_pet <- data$pr - pet[[k]] dates_monthly <- .datesmask(dates[[k]]) accumulated <- .Accumulation(data = diff_p_pet, dates_monthly = dates_monthly, accum = accum, diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd index b7d9087..10383af 100644 --- a/man/CST_PeriodPET.Rd +++ b/man/CST_PeriodPET.Rd @@ -19,17 +19,17 @@ CST_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 for each method are: for 'hargreaves', 'tasmin' and 'tasmax'; for -'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' -'tas' is required. 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 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 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'.} @@ -78,7 +78,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) diff --git a/man/CST_PeriodSPEI.Rd b/man/CST_PeriodSPEI.Rd index eaa139e..1500a64 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 @@ -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('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_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/PeriodPET.Rd b/man/PeriodPET.Rd index 2878cc6..7ca1073 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 for each method are: for 'hargreaves', 'tasmin' and 'tasmax'; for -'hargreaves_modified' are 'tasmin', 'tasmax' and 'prlr'; for method 'thornthwaite' -'tas' is required. 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 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'.} @@ -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'.} @@ -77,7 +77,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) diff --git a/man/PeriodSPEI.Rd b/man/PeriodSPEI.Rd index fc6c527..049e084 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'.} @@ -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('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_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/tests/testthat/test-PeriodPET.R b/tests/testthat/test-PeriodPET.R index ed5a9ac..647d1e0 100644 --- a/tests/testthat/test-PeriodPET.R +++ b/tests/testthat/test-PeriodPET.R @@ -15,11 +15,11 @@ cube2$coords <- list(lat = 1:2) 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) +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) dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16"))) @@ -27,15 +27,15 @@ 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_tmax, 'tmin' = exp_tmin, 'pr' = exp_pr) # 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) +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) dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), paste0(2010:2015, "-10-16"))) @@ -43,7 +43,7 @@ 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_tmean, 'pr' = exp_pr) # cube4 cube4_exp <- lapply(exp1, function(x) { @@ -93,17 +93,17 @@ test_that("1. Initial checks PeriodPET", { "Parameter 'data' needs to be a named list with the variable names." ) expect_error( - PeriodPET(data = list(tasmax = array(10))), + PeriodPET(data = list(tmax = 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)))), + PeriodPET(data = list(tmax = array(10, c(time = 10)), + tmin = 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)))), + PeriodPET(data = list(tmax = array(10, c(time = 10)), + tmin = array(10, c(ftime = 10)))), "Parameter 'data' variables need to have the same dimensions." ) # lat @@ -112,8 +112,8 @@ test_that("1. Initial checks PeriodPET", { "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), + PeriodPET(data = list(tmax = array(10, c(time = 10)), + tmin = array(10, c(time = 10))), lat = 1:2), "Parameter 'data' must have 'lat_dim' dimension." ) # data (2) diff --git a/tests/testthat/test-PeriodSPEI.R b/tests/testthat/test-PeriodSPEI.R index 7df14d6..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('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_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('tas' = exp_tas, 'prlr' = exp_prlr) -exp_cor2 <- list('tas' = expcor_tas, 'prlr' = 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) { @@ -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." ) -- GitLab