From 7555d7f53e7af0fde12293a7015386ce1001fb57 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 3 Nov 2023 13:18:58 +0100 Subject: [PATCH 01/11] Add test for lint --- .gitlab-ci.yml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8ffc555..8f201fd 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,3 +8,12 @@ build: - R CMD build --resave-data . - R CMD check --as-cran --no-manual --run-donttest s2dv_*.tar.gz - R -e 'covr::package_coverage()' + +lint-check: + stage: test + script: + - module load R/4.1.2-foss-2015a-bare + - module load CDO/1.9.8-foss-2015a + - echo "Run lintr on the package..." + - Rscript -e 'lintr::lint_package(path = ".")' + -- GitLab From 3837e73c7149e403e5123416a6ca5ee2179ea534 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 3 Nov 2023 13:20:32 +0100 Subject: [PATCH 02/11] correct stage --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8f201fd..ca419ca 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,5 +1,6 @@ stages: - build + build: stage: build script: @@ -10,7 +11,7 @@ build: - R -e 'covr::package_coverage()' lint-check: - stage: test + stage: build script: - module load R/4.1.2-foss-2015a-bare - module load CDO/1.9.8-foss-2015a -- GitLab From 97548dcd48054935c3a42b0dd273b6ed56f7e843 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 3 Nov 2023 15:29:36 +0100 Subject: [PATCH 03/11] Move coverage check to lint job --- .gitlab-ci.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ca419ca..a5dc384 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,7 +8,6 @@ build: - module load CDO/1.9.8-foss-2015a - R CMD build --resave-data . - R CMD check --as-cran --no-manual --run-donttest s2dv_*.tar.gz - - R -e 'covr::package_coverage()' lint-check: stage: build @@ -17,4 +16,4 @@ lint-check: - module load CDO/1.9.8-foss-2015a - echo "Run lintr on the package..." - Rscript -e 'lintr::lint_package(path = ".")' - + - R -e 'covr::package_coverage()' -- GitLab From da06f2bf162b0e0f56d6ed782a95e7be93d31530 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 10 Nov 2023 17:01:27 +0100 Subject: [PATCH 04/11] Add lintr config file --- .Rbuildignore | 1 + .lintr | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+) create mode 100644 .lintr diff --git a/.Rbuildignore b/.Rbuildignore index 0a21855..e817c8b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,6 +10,7 @@ README\.md$ \..*\.RData$ vignettes .gitlab-ci.yml +.lintr # unit tests should be ignored when building the package for CRAN ^tests$ # CDO is not in windbuilder, so we can test the unit tests by winbuilder diff --git a/.lintr b/.lintr new file mode 100644 index 0000000..a9eae1f --- /dev/null +++ b/.lintr @@ -0,0 +1,19 @@ +linters: linters_with_tags( + tags = c("package_development", "readability", "best_practices"), + line_length_linter = line_length_linter(100L), + T_and_F_symbol_linter = NULL, + single_quotes_linter = NULL + ) +exclusions: list( + "R/Load.R", + "R/Plot2VarsVsLTime.R", "R/PlotACC.R", "R/PlotAno.R", "R/PlotBoxWhisker.R", + "R/PlotClim.R", "R/PlotEquiMap.R", "R/PlotLayout.R", "R/PlotMatrix.R", + "R/PlotSection.R", "R/PlotStereoMap.R", "R/PlotVsLTime.R", + "R/ConfigApplyMatchingEntries.R", "R/ConfigEditDefinition.R", "R/ConfigEditEntry.R", + "R/ConfigFileOpen.R", "R/ConfigShowSimilarEntries.R", "R/ConfigShowTable.R", + "R/clim.palette.R", + "R/sampleDepthData.R", "R/sampleMap.R", "R/sampleTimeSeries.R", + "R/ToyModel.R", + "R/s2dv-package.R", + "tests/testthat/" + ) -- GitLab From 223deaec8f9e1d251662dfcc31514e83ebc14d08 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 10 Nov 2023 18:09:27 +0100 Subject: [PATCH 05/11] Fix infix_spaces_linter() check --- .lintr | 8 ++++++-- R/ACC.R | 12 ++++++------ R/AbsBiasSS.R | 6 +++--- R/Ano.R | 4 ++-- R/Ano_CrossValid.R | 4 ++-- R/Bias.R | 4 ++-- R/BrierScore.R | 4 ++-- R/CRPS.R | 4 ++-- R/CRPSS.R | 6 +++--- R/Clim.R | 4 ++-- R/Cluster.R | 4 ++-- R/Composite.R | 2 +- R/Consist_Trend.R | 4 ++-- R/Corr.R | 4 ++-- R/EOF.R | 8 ++++---- R/Eno.R | 4 ++-- R/EuroAtlanticTC.R | 4 ++-- R/Filter.R | 2 +- R/MSE.R | 4 ++-- R/MSSS.R | 8 ++++---- R/NAO.R | 2 +- R/ProbBins.R | 4 ++-- R/ProjectField.R | 2 +- R/REOF.R | 6 +++--- R/RMSSS.R | 4 ++-- R/ROCSS.R | 6 +++--- R/RPS.R | 4 ++-- R/RPSS.R | 8 ++++---- R/RatioRMS.R | 6 +++--- R/RatioSDRMS.R | 6 +++--- R/Regression.R | 4 ++-- R/Season.R | 4 ++-- R/Smoothing.R | 2 +- R/Spectrum.R | 2 +- R/Spread.R | 2 +- R/StatSeasAtlHurr.R | 4 ++-- R/Trend.R | 2 +- R/UltimateBrier.R | 4 ++-- R/Utils.R | 14 +++++++------- tests/testthat.R | 4 +--- 40 files changed, 96 insertions(+), 94 deletions(-) diff --git a/.lintr b/.lintr index a9eae1f..7dc9d00 100644 --- a/.lintr +++ b/.lintr @@ -2,11 +2,15 @@ linters: linters_with_tags( tags = c("package_development", "readability", "best_practices"), line_length_linter = line_length_linter(100L), T_and_F_symbol_linter = NULL, - single_quotes_linter = NULL + single_quotes_linter = NULL, + commented_code_linter = NULL, + implicit_integer_linter = NULL, + infix_spaces_linter(exclude_operators = "~") ) exclusions: list( "R/Load.R", - "R/Plot2VarsVsLTime.R", "R/PlotACC.R", "R/PlotAno.R", "R/PlotBoxWhisker.R", + "R/ColorBar.R", + "R/AnimateMap.R", "R/Plot2VarsVsLTime.R", "R/PlotACC.R", "R/PlotAno.R", "R/PlotBoxWhisker.R", "R/PlotClim.R", "R/PlotEquiMap.R", "R/PlotLayout.R", "R/PlotMatrix.R", "R/PlotSection.R", "R/PlotStereoMap.R", "R/PlotVsLTime.R", "R/ConfigApplyMatchingEntries.R", "R/ConfigEditDefinition.R", "R/ConfigEditEntry.R", diff --git a/R/ACC.R b/R/ACC.R index 131d15a..e79f9ef 100644 --- a/R/ACC.R +++ b/R/ACC.R @@ -152,8 +152,8 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', stop(paste0("Parameter 'exp' and 'obs' must have at least dimensions ", "lat_dim and lon_dim.")) } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## dat_dim @@ -413,7 +413,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', ## spatial centralization for each [avg_dim, dat] dim_exp <- dim(exp) dim_obs <- dim(obs) - wt <- cos(lat * pi/180) + wt <- cos(lat * pi / 180) wt <- rep(wt, times = prod(dim_exp[2:length(dim_exp)])) if (is.null(avg_dim) & is.null(dat_dim)) { #[lat, lon] @@ -457,7 +457,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', # ACC top <- sum(exp_sub * obs_sub, na.rm = TRUE) #a number bottom <- sqrt(sum(exp_sub^2, na.rm = TRUE) * sum(obs_sub^2, na.rm = TRUE)) - acc[iexp, iobs] <- top/bottom #a number + acc[iexp, iobs] <- top / bottom #a number # handle bottom = 0 if (is.infinite(acc[iexp, iobs])) acc[iexp, iobs] <- NA @@ -486,7 +486,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', # MACC top <- sum(exp_sub * obs_sub, na.rm = TRUE) #a number bottom <- sqrt(sum(exp_sub^2, na.rm = TRUE) * sum(obs_sub^2, na.rm = TRUE)) - macc[iexp, iobs] <- top/bottom #a number + macc[iexp, iobs] <- top / bottom #a number # handle bottom = 0 if (is.infinite(macc[iexp, iobs])) macc[iexp, iobs] <- NA @@ -497,7 +497,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', obs_sub_i <- obs_sub[, , i] top <- sum(exp_sub_i * obs_sub_i, na.rm = TRUE) #a number bottom <- sqrt(sum(exp_sub_i^2, na.rm = TRUE) * sum(obs_sub_i^2, na.rm = TRUE)) - acc[iexp, iobs, i] <- top/bottom #a number + acc[iexp, iobs, i] <- top / bottom #a number # handle bottom = 0 if (is.infinite(acc[iexp, iobs, i])) acc[iexp, iobs, i] <- NA } diff --git a/R/AbsBiasSS.R b/R/AbsBiasSS.R index e55d3d8..eacac16 100644 --- a/R/AbsBiasSS.R +++ b/R/AbsBiasSS.R @@ -82,14 +82,14 @@ AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, if (!is.array(obs) | !is.numeric(obs)) { stop("Parameter 'obs' must be a numeric array.") } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if (!is.null(ref)) { if (!is.array(ref) | !is.numeric(ref)) stop("Parameter 'ref' must be a numeric array.") - if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } } diff --git a/R/Ano.R b/R/Ano.R index c4c70a3..98f07cf 100644 --- a/R/Ano.R +++ b/R/Ano.R @@ -42,7 +42,7 @@ dim(data) <- c(length(data)) names(dim(data)) <- 'tmp_name' } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## clim @@ -56,7 +56,7 @@ dim(clim) <- c(length(clim)) names(dim(clim)) <- 'tmp_name' } - if (any(is.null(names(dim(clim))))| any(nchar(names(dim(clim))) == 0)) { + if (any(is.null(names(dim(clim)))) | any(nchar(names(dim(clim))) == 0)) { stop("Parameter 'clim' must have dimension names.") } ## data and clim diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index 13f7e97..926695f 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -68,8 +68,8 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', stop(paste0("Parameter 'exp' and 'obs' must have at least dimensions ", "time_dim and dat_dim.")) } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/Bias.R b/R/Bias.R index 0319a0f..3662fb9 100644 --- a/R/Bias.R +++ b/R/Bias.R @@ -56,8 +56,8 @@ Bias <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, stop("Parameter 'exp' must be a numeric array.") if (!is.array(obs) | !is.numeric(obs)) stop("Parameter 'obs' must be a numeric array.") - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/BrierScore.R b/R/BrierScore.R index 22f497d..a925d94 100644 --- a/R/BrierScore.R +++ b/R/BrierScore.R @@ -108,8 +108,8 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd dim(obs) <- c(length(obs)) names(dim(obs)) <- time_dim } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if (any(!obs %in% c(0, 1))) { diff --git a/R/CRPS.R b/R/CRPS.R index 7dedf4f..4e6dd3e 100644 --- a/R/CRPS.R +++ b/R/CRPS.R @@ -54,8 +54,8 @@ CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NU stop("Parameter 'exp' must be a numeric array.") if (!is.array(obs) | !is.numeric(obs)) stop("Parameter 'obs' must be a numeric array.") - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/CRPSS.R b/R/CRPSS.R index 159e2bd..5804051 100644 --- a/R/CRPSS.R +++ b/R/CRPSS.R @@ -90,14 +90,14 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.array(obs) | !is.numeric(obs)) { stop("Parameter 'obs' must be a numeric array.") } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if (!is.null(ref)) { if (!is.array(ref) | !is.numeric(ref)) stop("Parameter 'ref' must be a numeric array.") - if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } } diff --git a/R/Clim.R b/R/Clim.R index c144025..d49c260 100644 --- a/R/Clim.R +++ b/R/Clim.R @@ -89,8 +89,8 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", "containing time_dim and dat_dim.")) } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/Cluster.R b/R/Cluster.R index 2fac687..c330809 100644 --- a/R/Cluster.R +++ b/R/Cluster.R @@ -142,7 +142,7 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } @@ -154,7 +154,7 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, if (is.null(dim(weights))) { #is vector dim(weights) <- c(length(weights)) } - if (any(is.null(names(dim(weights))))| any(nchar(names(dim(weights))) == 0)) { + if (any(is.null(names(dim(weights)))) | any(nchar(names(dim(weights))) == 0)) { stop("Parameter 'weights' must have dimension names.") } if (any(!names(dim(weights)) %in% names(dim(data)) | diff --git a/R/Composite.R b/R/Composite.R index 03f0d58..9b5cd2b 100644 --- a/R/Composite.R +++ b/R/Composite.R @@ -100,7 +100,7 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), if (length(dim(data)) < 3) { stop("Parameter 'data' must have at least three dimensions.") } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## occ diff --git a/R/Consist_Trend.R b/R/Consist_Trend.R index ee95684..e96a9e7 100644 --- a/R/Consist_Trend.R +++ b/R/Consist_Trend.R @@ -93,8 +93,8 @@ Consist_Trend <- function(exp, obs, dat_dim = 'dataset', time_dim = 'sdate', int stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", "containing time_dim and dat_dim.")) } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if(!all(names(dim(exp)) %in% names(dim(obs))) | diff --git a/R/Corr.R b/R/Corr.R index c11fcf6..2d512be 100644 --- a/R/Corr.R +++ b/R/Corr.R @@ -121,8 +121,8 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", "containing time_dim and dat_dim.")) } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/EOF.R b/R/EOF.R index 66e69da..c5e4f19 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -100,7 +100,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## time_dim @@ -158,7 +158,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), # Area weighting. Weights for EOF; needed to compute the # fraction of variance explained by each EOFs space_ind <- sapply(space_dim, function(a) which(names(dim(ano)) == a)) - wght <- array(cos(lat * pi/180), dim = dim(ano)[space_ind]) + wght <- array(cos(lat * pi / 180), dim = dim(ano)[space_ind]) # We want the covariance matrix to be weigthed by the grid # cell area so the anomaly field is weighted by its square @@ -223,7 +223,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), # The use of the correlation matrix is done under the option corr. if (corr == TRUE) { stdv <- apply(ano, c(2, 3), sd, na.rm = T) - ano <- ano/InsertDim(stdv, 1, nt) + ano <- ano / InsertDim(stdv, 1, nt) } # Time/space matrix for SVD @@ -273,7 +273,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), # Computation of the % of variance associated with each mode W <- pca$d[1:neofs] tot.var <- sum(pca$d^2) - var.eof <- 100 * pca$d[1:neofs]^2/tot.var + var.eof <- 100 * pca$d[1:neofs]^2 / tot.var for (e in 1:neofs) { # Set all masked grid points to NA in the EOFs diff --git a/R/Eno.R b/R/Eno.R index e2324de..caa0b33 100644 --- a/R/Eno.R +++ b/R/Eno.R @@ -43,7 +43,7 @@ Eno <- function(data, time_dim = 'sdate', na.action = na.pass, ncores = NULL) { dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -58,7 +58,7 @@ Eno <- function(data, time_dim = 'sdate', na.action = na.pass, ncores = NULL) { as.character(substitute(na.action)) != c("na.fail")) { stop("Parameter 'na.action' must be a function either na.pass or na.fail.") } - if(as.character(substitute(na.action))== c("na.fail") && anyNA(data)) { + if(as.character(substitute(na.action)) == c("na.fail") && anyNA(data)) { stop(paste0("Calculation fails because NA is found in paratemter 'data', ", "which is not accepted when ", "parameter 'na.action' = na.fail.")) diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R index 2860a53..ef5e693 100644 --- a/R/EuroAtlanticTC.R +++ b/R/EuroAtlanticTC.R @@ -75,7 +75,7 @@ EuroAtlanticTC <- function(ano, lat, lon, ntrunc = 30, time_dim = 'sdate', if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## time_dim @@ -178,7 +178,7 @@ EuroAtlanticTC <- function(ano, lat, lon, ntrunc = 30, time_dim = 'sdate', # Area weighting is needed to compute the fraction of variance explained by # each mode space_ind <- sapply(space_dim, function(a) which(names(dim(ano)) == a)) - wght <- array(cos(lat * pi/180), dim = dim(ano)[space_ind]) + wght <- array(cos(lat * pi / 180), dim = dim(ano)[space_ind]) # We want the covariance matrix to be weigthed by the grid # cell area so the anoaly field is weighted by its square diff --git a/R/Filter.R b/R/Filter.R index c4e76bf..8e77a7c 100644 --- a/R/Filter.R +++ b/R/Filter.R @@ -53,7 +53,7 @@ Filter <- function(data, freq, time_dim = 'ftime', ncores = NULL) { dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## freq diff --git a/R/MSE.R b/R/MSE.R index 61cf3bc..781e47a 100644 --- a/R/MSE.R +++ b/R/MSE.R @@ -98,8 +98,8 @@ MSE <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, memb_dim = NULL, stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", "dimensions time_dim and dat_dim, or vector of same length.")) } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/MSSS.R b/R/MSSS.R index a11c50c..2858add 100644 --- a/R/MSSS.R +++ b/R/MSSS.R @@ -112,8 +112,8 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", "dimensions time_dim and dat_dim, or vector of same length.")) } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if (!is.null(ref)) { @@ -121,7 +121,7 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, stop("Parameter 'ref' must be numeric.") } if (is.array(ref)) { - if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } } else if (length(ref) != 1 | any(!ref %in% c(0, 1))) { @@ -382,7 +382,7 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, } } - F.stat <- (eno2 * mse_ref^2 / (eno2 - 1)) / ((eno1 * mse_exp^2 / (eno1- 1))) + F.stat <- (eno2 * mse_ref^2 / (eno2 - 1)) / ((eno1 * mse_exp^2 / (eno1 - 1))) tmp <- !is.na(eno1) & !is.na(eno2) & eno1 > 2 & eno2 > 2 p_val <- 1 - pf(F.stat, eno1 - 1, eno2 - 1) if (sign) signif <- p_val <= alpha diff --git a/R/NAO.R b/R/NAO.R index fb5220c..28c04f4 100644 --- a/R/NAO.R +++ b/R/NAO.R @@ -306,7 +306,7 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', } # wght - wght <- array(sqrt(cos(lat * pi/180)), dim = c(length(lat), length(lon))) + wght <- array(sqrt(cos(lat * pi / 180)), dim = c(length(lat), length(lon))) if (!is.null(exp) & !is.null(obs)) { res <- Apply(list(exp, obs), diff --git a/R/ProbBins.R b/R/ProbBins.R index ef293d9..da7b7a7 100644 --- a/R/ProbBins.R +++ b/R/ProbBins.R @@ -71,7 +71,7 @@ ProbBins <- function(data, thr, fcyr = 'all', time_dim = 'sdate', memb_dim = 'me # dim(data) <- c(length(data)) # names(dim(data)) <- time_dim # } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## thr @@ -201,7 +201,7 @@ counts <- function (dat, nbthr) { thr <- dat[1:nbthr] data <- dat[nbthr + 1:(length(dat) - nbthr)] prob <- array(NA, dim = c(nbthr + 1, length(dat) - nbthr)) - prob[1, ] <- 1*(data <= thr[1]) + prob[1, ] <- 1 * (data <= thr[1]) if (nbthr != 1) { for (ithr in 2:(nbthr)) { prob[ithr, ] <- 1 * ((data > thr[ithr - 1]) & (data <= thr[ithr])) diff --git a/R/ProjectField.R b/R/ProjectField.R index 55e7fd2..236dde1 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -71,7 +71,7 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## eof (1) diff --git a/R/REOF.R b/R/REOF.R index c9c82cf..e0a30b5 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -85,7 +85,7 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## time_dim @@ -154,7 +154,7 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', # Area weighting is needed to compute the fraction of variance explained by # each mode space_ind <- sapply(space_dim, function(a) which(names(dim(ano)) == a)) - wght <- array(cos(lat * pi/180), dim = dim(ano)[space_ind]) + wght <- array(cos(lat * pi / 180), dim = dim(ano)[space_ind]) # We want the covariance matrix to be weigthed by the grid # cell area so the anomaly field is weighted by its square @@ -217,7 +217,7 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', # RPCs <- ano.wght %*% invLoadings # Compute explained variance fraction: - var <- apply(RPCs, 2, function(x) { sum(x*x) } ) * 100 / eofs$tot_var # [mode] + var <- apply(RPCs, 2, function(x) { sum(x * x) } ) * 100 / eofs$tot_var # [mode] dim(var) <- c(mode = length(var)) return(invisible(list(REOFs = REOFs, RPCs = RPCs, var = var))) diff --git a/R/RMSSS.R b/R/RMSSS.R index c33a40e..a0fb688 100644 --- a/R/RMSSS.R +++ b/R/RMSSS.R @@ -131,7 +131,7 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, stop("Parameter 'ref' must be numeric.") } if (is.array(ref)) { - if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } } else if (length(ref) != 1 | any(!ref %in% c(0, 1))) { @@ -396,7 +396,7 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, } } - F.stat <- (eno2 * rms_ref^2 / (eno2 - 1)) / ((eno1 * rms_exp^2 / (eno1- 1))) + F.stat <- (eno2 * rms_ref^2 / (eno2 - 1)) / ((eno1 * rms_exp^2 / (eno1 - 1))) tmp <- !is.na(eno1) & !is.na(eno2) & eno1 > 2 & eno2 > 2 p_val <- 1 - pf(F.stat, eno1 - 1, eno2 - 1) if (sign) signif <- p_val <= alpha diff --git a/R/ROCSS.R b/R/ROCSS.R index 2ca0782..0fe4519 100644 --- a/R/ROCSS.R +++ b/R/ROCSS.R @@ -91,14 +91,14 @@ ROCSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.array(obs) | !is.numeric(obs)) { stop("Parameter 'obs' must be a numeric array.") } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if (!is.null(ref)) { if (!is.array(ref) | !is.numeric(ref)) stop("Parameter 'ref' must be a numeric array.") - if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } } diff --git a/R/RPS.R b/R/RPS.R index c385f10..08c569c 100644 --- a/R/RPS.R +++ b/R/RPS.R @@ -93,8 +93,8 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL stop('Parameter "exp" must be a numeric array.') if (!is.array(obs) | !is.numeric(obs)) stop('Parameter "obs" must be a numeric array.') - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim diff --git a/R/RPSS.R b/R/RPSS.R index 91ca8c2..125bb71 100644 --- a/R/RPSS.R +++ b/R/RPSS.R @@ -139,14 +139,14 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.array(obs) | !is.numeric(obs)) { stop("Parameter 'obs' must be a numeric array.") } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } if (!is.null(ref)) { if (!is.array(ref) | !is.numeric(ref)) stop("Parameter 'ref' must be a numeric array.") - if (any(is.null(names(dim(ref))))| any(nchar(names(dim(ref))) == 0)) { + if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } } @@ -460,7 +460,7 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', for (i in 1:nexp) { for (j in 1:nobs) { for (k in 1:nref) { - if (nref != 1 & k!=i) { # if nref is 1 or equal to nexp, calculate rps + if (nref != 1 & k != i) { # if nref is 1 or equal to nexp, calculate rps next } exp_data <- exp[, , i, drop = F] diff --git a/R/RatioRMS.R b/R/RatioRMS.R index 51f3984..c3bb32b 100644 --- a/R/RatioRMS.R +++ b/R/RatioRMS.R @@ -92,9 +92,9 @@ RatioRMS <- function(exp1, exp2, obs, time_dim = 'sdate', pval = TRUE, ncores = dim(obs) <- c(length(obs)) names(dim(obs)) <- time_dim } - if(any(is.null(names(dim(exp1))))| any(nchar(names(dim(exp1))) == 0) | - any(is.null(names(dim(exp2))))| any(nchar(names(dim(exp2))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp1)))) | any(nchar(names(dim(exp1))) == 0) | + any(is.null(names(dim(exp2)))) | any(nchar(names(dim(exp2))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp1', 'exp2', and 'obs' must have dimension names.") } if(!all(names(dim(exp1)) %in% names(dim(exp2))) | diff --git a/R/RatioSDRMS.R b/R/RatioSDRMS.R index 6040410..1b58eed 100644 --- a/R/RatioSDRMS.R +++ b/R/RatioSDRMS.R @@ -65,8 +65,8 @@ RatioSDRMS <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", "dimensions memb_dim and time_dim.")) } - if (any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## dat_dim @@ -182,7 +182,7 @@ RatioSDRMS <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', dif <- ens_exp[jexp, ] - ens_obs[jobs, ] rms <- mean(dif^2, na.rm = TRUE)^0.5 enorms <- Eno(dif) - ratiosdrms[jexp, jobs] <- std[jexp]/rms + ratiosdrms[jexp, jobs] <- std[jexp] / rms if (pval) { F <- (enosd[jexp] * std[jexp]^2 / (enosd[jexp] - 1)) / (enorms * rms^2 / (enorms - 1)) diff --git a/R/Regression.R b/R/Regression.R index 535f179..dcc447e 100644 --- a/R/Regression.R +++ b/R/Regression.R @@ -108,8 +108,8 @@ Regression <- function(datay, datax, reg_dim = 'sdate', formula = y ~ x, dim(datax) <- c(length(datax)) names(dim(datax)) <- reg_dim } - if(any(is.null(names(dim(datay))))| any(nchar(names(dim(datay))) == 0) | - any(is.null(names(dim(datax))))| any(nchar(names(dim(datax))) == 0)) { + if(any(is.null(names(dim(datay)))) | any(nchar(names(dim(datay))) == 0) | + any(is.null(names(dim(datax)))) | any(nchar(names(dim(datax))) == 0)) { stop("Parameter 'datay' and 'datax' must have dimension names.") } if(!all(names(dim(datay)) %in% names(dim(datax))) | diff --git a/R/Season.R b/R/Season.R index 1425d59..e9dbb75 100644 --- a/R/Season.R +++ b/R/Season.R @@ -53,7 +53,7 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -185,7 +185,7 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, pos2 <- lapply(pos2, function(y) {y[1 : maxyear]}) # Convert to array: pos2 <- unlist(pos2) - dim(pos2) <- c(year = maxyear, month = length(pos2)/maxyear) + dim(pos2) <- c(year = maxyear, month = length(pos2) / maxyear) timeseries <- apply(pos2, 1, function(y) {method(x[y], na.rm = na.rm)}) timeseries <- as.array(timeseries) diff --git a/R/Smoothing.R b/R/Smoothing.R index 1b31e65..311095c 100644 --- a/R/Smoothing.R +++ b/R/Smoothing.R @@ -45,7 +45,7 @@ Smoothing <- function(data, time_dim = 'ftime', runmeanlen = 12, ncores = NULL) dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim diff --git a/R/Spectrum.R b/R/Spectrum.R index a75ead6..72cbd68 100644 --- a/R/Spectrum.R +++ b/R/Spectrum.R @@ -59,7 +59,7 @@ Spectrum <- function(data, time_dim = 'ftime', alpha = 0.05, ncores = NULL) { dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim diff --git a/R/Spread.R b/R/Spread.R index 5fba8ca..1a60181 100644 --- a/R/Spread.R +++ b/R/Spread.R @@ -97,7 +97,7 @@ Spread <- function(data, compute_dim = 'member', na.rm = TRUE, dim(data) <- c(length(data)) names(dim(data)) <- compute_dim[1] } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## compute_dim diff --git a/R/StatSeasAtlHurr.R b/R/StatSeasAtlHurr.R index 764215a..a125f7f 100644 --- a/R/StatSeasAtlHurr.R +++ b/R/StatSeasAtlHurr.R @@ -70,8 +70,8 @@ StatSeasAtlHurr <- function(atlano, tropano, hrvar = "HR", ncores = NULL) { dim(tropano) <- c(length(tropano)) names(dim(tropano)) <- 'dim1' } - if(any(is.null(names(dim(atlano))))| any(nchar(names(dim(atlano))) == 0) | - any(is.null(names(dim(tropano))))| any(nchar(names(dim(tropano))) == 0)) { + if(any(is.null(names(dim(atlano)))) | any(nchar(names(dim(atlano))) == 0) | + any(is.null(names(dim(tropano)))) | any(nchar(names(dim(tropano))) == 0)) { stop("Parameter 'atlano' and 'tropano' must have dimension names.") } if(!all(names(dim(atlano)) %in% names(dim(tropano))) | diff --git a/R/Trend.R b/R/Trend.R index e10fe19..d1af5ed 100644 --- a/R/Trend.R +++ b/R/Trend.R @@ -89,7 +89,7 @@ Trend <- function(data, time_dim = 'ftime', interval = 1, polydeg = 1, alpha = 0 dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim diff --git a/R/UltimateBrier.R b/R/UltimateBrier.R index 44498a3..3a6ca92 100644 --- a/R/UltimateBrier.R +++ b/R/UltimateBrier.R @@ -98,8 +98,8 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di if (!is.numeric(exp) | !is.numeric(obs)) { stop("Parameter 'exp' and 'obs' must be a vector or a numeric array.") } - if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## dat_dim diff --git a/R/Utils.R b/R/Utils.R index 362bdf8..ffee809 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -283,7 +283,7 @@ common_grid_lats <- length(lat) } first_common_grid_lon <- 0 - last_common_grid_lon <- 360 - 360/common_grid_lons + last_common_grid_lon <- 360 - 360 / common_grid_lons ## This is not true for gaussian grids or for some regular grids, but ## is a safe estimation first_common_grid_lat <- -90 @@ -351,14 +351,14 @@ lon_subsetting_requested <- TRUE } } else { - if ((lonmin - lonmax) > 360/common_grid_lons) { + if ((lonmin - lonmax) > 360 / common_grid_lons) { lon_subsetting_requested <- TRUE } else { - gap_width <- floor(lonmin / (360/common_grid_lons)) - - floor(lonmax / (360/common_grid_lons)) + gap_width <- floor(lonmin / (360 / common_grid_lons)) - + floor(lonmax / (360 / common_grid_lons)) if (gap_width > 0) { - if (!(gap_width == 1 && (lonmin %% (360/common_grid_lons) == 0) && - (lonmax %% (360/common_grid_lons) == 0))) { + if (!(gap_width == 1 && (lonmin %% (360 / common_grid_lons) == 0) && + (lonmax %% (360 / common_grid_lons) == 0))) { lon_subsetting_requested <- TRUE } } @@ -1641,7 +1641,7 @@ data <- Season(data = data, time_dim = fmonth_dim, monini = monini, moninf = 1, monsup = 12, method = mean, na.rm = na.rm) - names(dim(data))[which(names(dim(data))==fmonth_dim)] <- fyear_dim + names(dim(data))[which(names(dim(data)) == fmonth_dim)] <- fyear_dim if (identical(indices_for_clim, FALSE)) { ## data is already anomalies diff --git a/tests/testthat.R b/tests/testthat.R index a7dec96..600bd16 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,2 @@ -library(testthat) -library(s2dv) - +#'@importFrom testthat test_check test_check("s2dv") -- GitLab From 38909d3d5a3d8632a8872a89d7534fafed448dab Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 13 Nov 2023 11:49:21 +0100 Subject: [PATCH 06/11] Recover loading testthat package and ignore it in lintr check --- .lintr | 3 ++- tests/testthat.R | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.lintr b/.lintr index 7dc9d00..4557e70 100644 --- a/.lintr +++ b/.lintr @@ -19,5 +19,6 @@ exclusions: list( "R/sampleDepthData.R", "R/sampleMap.R", "R/sampleTimeSeries.R", "R/ToyModel.R", "R/s2dv-package.R", - "tests/testthat/" + "tests/testthat/", + "tests/testthat.R" ) diff --git a/tests/testthat.R b/tests/testthat.R index 600bd16..9a6a709 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,2 +1,2 @@ -#'@importFrom testthat test_check +library(testthat) test_check("s2dv") -- GitLab From 67bf9d2d03028d0d5e95f2df9b9146dfd980c247 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 13 Nov 2023 17:43:50 +0100 Subject: [PATCH 07/11] Fix lintr findings --- .lintr | 18 +- R/ACC.R | 52 +++--- R/AMV.R | 38 ++-- R/AbsBiasSS.R | 23 ++- R/Ano.R | 4 +- R/Ano_CrossValid.R | 38 ++-- R/Bias.R | 8 +- R/BrierScore.R | 32 ++-- R/CDORemap.R | 145 ++++++++------ R/CRPS.R | 17 +- R/CRPSS.R | 36 ++-- R/Clim.R | 50 ++--- R/Cluster.R | 13 +- R/Composite.R | 6 +- R/Consist_Trend.R | 20 +- R/Corr.R | 37 ++-- R/DiffCorr.R | 40 ++-- R/EOF.R | 12 +- R/Eno.R | 14 +- R/EuroAtlanticTC.R | 12 +- R/Filter.R | 6 +- R/GMST.R | 37 ++-- R/GSAT.R | 38 ++-- R/GetProbs.R | 49 +++-- R/Histo2Hindcast.R | 30 +-- R/MSE.R | 27 +-- R/MSSS.R | 35 ++-- R/MeanDims.R | 2 +- R/NAO.R | 54 +++--- R/Persistence.R | 84 ++++----- R/ProbBins.R | 17 +- R/ProjectField.R | 30 +-- R/REOF.R | 28 +-- R/RMS.R | 27 +-- R/RMSSS.R | 35 ++-- R/ROCSS.R | 35 ++-- R/RPS.R | 48 ++--- R/RPSS.R | 84 ++++++--- R/RandomWalkTest.R | 4 +- R/RatioPredictableComponents.R | 8 +- R/RatioRMS.R | 29 +-- R/RatioSDRMS.R | 8 +- R/Regression.R | 24 +-- R/Reorder.R | 6 +- R/ResidualCorr.R | 23 +-- R/SPOD.R | 40 ++-- R/Season.R | 24 ++- R/SignalNoiseRatio.R | 7 +- R/Smoothing.R | 10 +- R/Spectrum.R | 4 +- R/Spread.R | 4 +- R/StatSeasAtlHurr.R | 12 +- R/TPI.R | 37 ++-- R/Trend.R | 6 +- R/UltimateBrier.R | 44 +++-- R/Utils.R | 332 ++++++++++++++++++++++----------- man/ACC.Rd | 3 +- man/Clim.Rd | 3 +- man/Corr.Rd | 3 +- man/MSE.Rd | 3 +- man/Persistence.Rd | 8 +- man/RatioRMS.Rd | 6 +- man/Season.Rd | 10 +- 63 files changed, 1112 insertions(+), 827 deletions(-) diff --git a/.lintr b/.lintr index 4557e70..239b922 100644 --- a/.lintr +++ b/.lintr @@ -5,7 +5,11 @@ linters: linters_with_tags( single_quotes_linter = NULL, commented_code_linter = NULL, implicit_integer_linter = NULL, - infix_spaces_linter(exclude_operators = "~") + vector_logic_linter = NULL, + infix_spaces_linter = NULL, + extraction_operator_linter = NULL, + function_left_parentheses_linter = NULL, + semicolon_linter = NULL ) exclusions: list( "R/Load.R", @@ -20,5 +24,15 @@ exclusions: list( "R/ToyModel.R", "R/s2dv-package.R", "tests/testthat/", - "tests/testthat.R" + "tests/testthat.R", + "R/CDORemap.R" = list( + function_argument_linter = NULL, + nonportable_path_linter = NULL + ), + "R/NAO.R" = list( + function_argument_linter = NULL + ), + "R/Utils.R" = list( + function_argument_linter = NULL + ) ) diff --git a/R/ACC.R b/R/ACC.R index e79f9ef..6865834 100644 --- a/R/ACC.R +++ b/R/ACC.R @@ -1,4 +1,5 @@ -#'Compute the spatial anomaly correlation coefficient between the forecast and corresponding observation +#'Compute the spatial anomaly correlation coefficient between the forecast and +#'corresponding observation #' #'Calculate the spatial anomaly correlation coefficient (ACC) for the ensemble #'mean of each model and the corresponding references over a spatial domain. It @@ -149,11 +150,11 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', stop("Parameter 'exp' and 'obs' must be a numeric array.") } if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must have at least dimensions ", - "lat_dim and lon_dim.")) + stop("Parameter 'exp' and 'obs' must have at least dimensions ", + "lat_dim and lon_dim.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## dat_dim @@ -213,14 +214,14 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', stop("Parameter 'lat' cannot be NULL. It is required for area weighting.") } if (!is.numeric(lat) | length(lat) != dim(exp)[lat_dim]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'exp' and 'obs'.")) + stop("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'exp' and 'obs'.") } ## lon if (!is.null(lon)) { if (!is.numeric(lon) | length(lon) != dim(exp)[lon_dim]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'exp' and 'obs'.")) + stop("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'exp' and 'obs'.") } } ## lonlatbox @@ -270,7 +271,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) - if(!all(name_exp %in% name_obs) | !all(name_obs %in% name_exp)) { + if (!all(name_exp %in% name_obs) | !all(name_obs %in% name_exp)) { stop("Parameter 'exp' and 'obs' must have same dimension names.") } if (!is.null(dat_dim)) { @@ -282,8 +283,8 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', name_obs <- name_obs[-which(name_obs == memb_dim)] } if (!identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all the dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all the dimensions except 'dat_dim' and 'memb_dim'.") } #----------------------------------------------------------------- @@ -329,7 +330,8 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', if (is.null(avg_dim)) { target_dims <- list(c(lat_dim, lon_dim, dat_dim), c(lat_dim, lon_dim, dat_dim)) } else { - target_dims <- list(c(lat_dim, lon_dim, avg_dim, dat_dim), c(lat_dim, lon_dim, avg_dim, dat_dim)) + target_dims <- list(c(lat_dim, lon_dim, avg_dim, dat_dim), + c(lat_dim, lon_dim, avg_dim, dat_dim)) } res <- Apply(list(exp, obs), target_dims = target_dims, @@ -367,7 +369,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', return(res) } -.ACC <- function(exp, obs, dat_dim = NULL, avg_dim = 'sdate', lat, alpha = 0.05, +.ACC <- function(exp, obs, lat, dat_dim = NULL, avg_dim = 'sdate', alpha = 0.05, pval = TRUE, sign = FALSE, conf = TRUE, conftype = "parametric") { # .ACC() should use all the spatial points to calculate ACC. It returns [nexp, nobs]. # If dat_dim = NULL, it returns a number. @@ -474,8 +476,10 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', if (sign) signif[iexp, iobs] <- !is.na(p.value) & p.value <= alpha } if (conf) { - conf.upper[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + qnorm(1 - alpha / 2) / sqrt(eno - 3)) - conf.lower[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + qnorm(alpha / 2) / sqrt(eno - 3)) + conf.upper[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + + qnorm(1 - alpha / 2) / sqrt(eno - 3)) + conf.lower[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + + qnorm(alpha / 2) / sqrt(eno - 3)) } } } @@ -492,7 +496,7 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', if (is.infinite(macc[iexp, iobs])) macc[iexp, iobs] <- NA # ACC - for (i in 1:dim(acc)[3]) { + for (i in seq_len(dim(acc)[3])) { exp_sub_i <- exp_sub[, , i] obs_sub_i <- obs_sub[, , i] top <- sum(exp_sub_i * obs_sub_i, na.rm = TRUE) #a number @@ -569,8 +573,8 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', } -.ACC_bootstrap <- function(exp, obs, dat_dim = NULL, - avg_dim = 'sdate', memb_dim = NULL, lat, alpha = 0.05, +.ACC_bootstrap <- function(exp, obs, lat, dat_dim = NULL, + avg_dim = 'sdate', memb_dim = NULL, alpha = 0.05, pval = TRUE, sign = FALSE, conf = TRUE, conftype = "parametric") { # if (is.null(avg_dim)) # exp: [memb_exp, (dat_exp), lat, lon] @@ -605,10 +609,12 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', for (jdraw in 1:ndraw) { #choose a randomly member index for each point of the matrix - indexp <- array(sample(nmembexp, size = prod(dim(exp)[-c(length(dim(exp)) - 1, length(dim(exp)))]), + indexp <- array(sample(nmembexp, + size = prod(dim(exp)[-c(length(dim(exp)) - 1, length(dim(exp)))]), replace = TRUE), dim = dim(exp)) - indobs <- array(sample(nmembobs, size = prod(dim(obs)[-c(length(dim(obs)) - 1, length(dim(obs)))]), + indobs <- array(sample(nmembobs, + size = prod(dim(obs)[-c(length(dim(obs)) - 1, length(dim(obs)))]), replace = TRUE), dim = dim(obs)) @@ -620,10 +626,10 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', # if (is.null(avg_dim)) { drawexp <- array( - apply(varindexp, c(2:length(dim(exp))), function(x) x[,1][x[,2]] ), + apply(varindexp, 2:length(dim(exp)), function(x) x[, 1][x[, 2]]), dim = dim(exp)) drawobs <- array( - apply(varindobs, c(2:length(dim(obs))), function(x) x[,1][x[,2]] ), + apply(varindobs, 2:length(dim(obs)), function(x) x[, 1][x[, 2]]), dim = dim(obs)) # ensemble mean before .ACC diff --git a/R/AMV.R b/R/AMV.R index 9167628..4c9324e 100644 --- a/R/AMV.R +++ b/R/AMV.R @@ -123,13 +123,13 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo stop("Parameter 'lon_dim' is not found in 'data' dimension.") } # data_lats and data_lons part2 - if (dim(data)[lat_dim] != length(data_lats)){ - stop(paste0("The latitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lats'.")) + if (dim(data)[lat_dim] != length(data_lats)) { + stop("The latitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lats'.") } - if (dim(data)[lon_dim] != length(data_lons)){ - stop(paste0("The longitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lons'.")) + if (dim(data)[lon_dim] != length(data_lons)) { + stop("The longitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lons'.") } # ncores if (!is.null(ncores)) { @@ -140,7 +140,7 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } # mask if (!is.null(mask)) { - if (is.array(mask) & identical(names(dim(mask)), c(lat_dim,lon_dim)) & + if (is.array(mask) & identical(names(dim(mask)), c(lat_dim, lon_dim)) & identical(as.integer(dim(mask)), c(length(data_lats), length(data_lons)))) { ## To mask those grid point that are missing in the observations mask <- s2dv::Reorder(data = mask, order = c(lat_dim, lon_dim)) @@ -151,9 +151,9 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo data <- multiApply::Apply(data = data, target_dims = c(lat_dim, lon_dim), fun = fun_mask, mask = mask, ncores = ncores)$output1 } else { - stop(paste0("Parameter 'mask' must be NULL (no mask) or a numerical array ", - "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", - "points that have to be masked.")) + stop("Parameter 'mask' must be NULL (no mask) or a numerical array ", + "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", + "points that have to be masked.") } } # monini @@ -183,11 +183,11 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } # indices_for_clim if (!is.null(indices_for_clim)) { - if (!class(indices_for_clim) %in% c('numeric', 'integer') - & !(is.logical(indices_for_clim) & !any(indices_for_clim))) { - stop(paste0("The parameter 'indices_for_clim' must be a numeric vector ", - "or NULL to compute the anomalies based on the whole period, ", - "or FALSE if data are already anomalies")) + if (!(is(indices_for_clim, "numeric") || is(indices_for_clim, "integer")) & + !(is.logical(indices_for_clim) & !any(indices_for_clim))) { + stop("The parameter 'indices_for_clim' must be a numeric vector ", + "or NULL to compute the anomalies based on the whole period, ", + "or FALSE if data are already anomalies") } } # year_dim @@ -209,7 +209,7 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } } # na.rm - if (!na.rm %in% c(TRUE,FALSE)) { + if (!na.rm %in% c(TRUE, FALSE)) { stop("Parameter 'na.rm' must be TRUE or FALSE") } @@ -230,12 +230,12 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo region = regions$reg2, londim = lon_dim, latdim = lat_dim) - data <- ClimProjDiags::CombineIndices(indices = list(mean_1,mean_2), weights = NULL, + data <- ClimProjDiags::CombineIndices(indices = list(mean_1, mean_2), weights = NULL, operation = 'subtract') # (mean_1 - mean_2) - if (type == 'dcpp'){ + if (type == 'dcpp') { target_dims <- c(sdate_dim, fmonth_dim) - } else if (type %in% c('hist','obs')){ + } else if (type %in% c('hist', 'obs')) { target_dims <- c(year_dim, month_dim) } diff --git a/R/AbsBiasSS.R b/R/AbsBiasSS.R index eacac16..84215bc 100644 --- a/R/AbsBiasSS.R +++ b/R/AbsBiasSS.R @@ -142,8 +142,8 @@ AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.") } if (!is.null(ref)) { name_ref <- sort(names(dim(ref))) @@ -153,17 +153,17 @@ AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, if (!is.null(dat_dim)) { if (dat_dim %in% name_ref) { if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { - stop(paste0("If parameter 'ref' has dataset dimension, it must be", - " equal to dataset dimension of 'exp'.")) + stop("If parameter 'ref' has dataset dimension, it must be", + " equal to dataset dimension of 'exp'.") } name_ref <- name_ref[-which(name_ref == dat_dim)] } } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", - "all dimensions except 'memb_dim' and 'dat_dim' if there is ", - "only one reference dataset.")) + stop("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.") } } ## na.rm @@ -177,7 +177,8 @@ AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, ## sig_method.type #NOTE: These are the types of RandomWalkTest() if (!sig_method.type %in% c('two.sided.approx', 'two.sided', 'greater', 'less')) { - stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', 'greater', or 'less'.") + stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', ", + "'greater', or 'less'.") } if (sig_method.type == 'two.sided.approx') { if (alpha != 0.05) { @@ -283,12 +284,14 @@ AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, } ## Bias of the exp - bias_exp <- .Bias(exp = exp_data, obs = obs_data, na.rm = na.rm, absolute = TRUE, time_mean = FALSE) + bias_exp <- .Bias(exp = exp_data, obs = obs_data, na.rm = na.rm, + absolute = TRUE, time_mean = FALSE) ## Bias of the ref if (is.null(ref)) { ## Climatological forecast ref_data <- rep(mean(obs_data, na.rm = na.rm), length(obs_data)) } - bias_ref <- .Bias(exp = ref_data, obs = obs_data, na.rm = na.rm, absolute = TRUE, time_mean = FALSE) + bias_ref <- .Bias(exp = ref_data, obs = obs_data, na.rm = na.rm, + absolute = TRUE, time_mean = FALSE) ## Skill score and significance biasSS[i, j] <- 1 - mean(bias_exp) / mean(bias_ref) sign[i, j] <- .RandomWalkTest(skill_A = bias_exp, skill_B = bias_ref, diff --git a/R/Ano.R b/R/Ano.R index 98f07cf..c9ca5c1 100644 --- a/R/Ano.R +++ b/R/Ano.R @@ -42,7 +42,7 @@ dim(data) <- c(length(data)) names(dim(data)) <- 'tmp_name' } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## clim @@ -94,7 +94,7 @@ res <- data - clim } else { target_dims_ind <- match(names(dim(clim)), names(dim(data))) - margin_dims_ind <- c(1:length(dim(data)))[-target_dims_ind] + margin_dims_ind <- seq_along(dim(data))[-target_dims_ind] res <- apply(data, margin_dims_ind, .Ano, clim) res <- array(res, dim = dim(data)[c(target_dims_ind, margin_dims_ind)]) } diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index 926695f..b915f1e 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -65,11 +65,11 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', stop("Parameter 'exp' and 'obs' must be a numeric array.") } if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must have at least dimensions ", - "time_dim and dat_dim.")) + stop("Parameter 'exp' and 'obs' must have at least dimensions ", + "time_dim and dat_dim.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim @@ -114,14 +114,14 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', " Set it as NULL if there is no dataset dimension.") } # If dat_dim is not in obs, add it in - if (any(!dat_dim %in% names(dim(obs)))) { + if (!all(dat_dim %in% names(dim(obs)))) { reset_obs_dim <- TRUE ori_obs_dim <- dim(obs) dim(obs) <- c(dim(obs), rep(1, length(dat_dim[which(!dat_dim %in% names(dim(obs)))]))) names(dim(obs)) <- c(names(ori_obs_dim), dat_dim[which(!dat_dim %in% names(dim(obs)))]) } # If dat_dim is not in obs, add it in - if (any(!dat_dim %in% names(dim(exp)))) { + if (!all(dat_dim %in% names(dim(exp)))) { reset_exp_dim <- TRUE ori_exp_dim <- dim(exp) dim(exp) <- c(dim(exp), rep(1, length(dat_dim[which(!dat_dim %in% names(dim(exp)))]))) @@ -146,14 +146,14 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) if (!is.null(dat_dim)) { - for (i in 1:length(dat_dim)) { + for (i in seq_along(dat_dim)) { name_exp <- name_exp[-which(name_exp == dat_dim[i])] name_obs <- name_obs[-which(name_obs == dat_dim[i])] } } if (!identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have the same length of ", - "all dimensions except 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have the same length of ", + "all dimensions except 'dat_dim'.") } ############################### @@ -166,10 +166,11 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', } #----------------------------------- - # Per-paired method: If any sdate along dat_dim is NA, turn all sdate points along dat_dim into NA. + # Per-paired method: If any sdate along dat_dim is NA, turn all sdate points + # along dat_dim into NA. if (!is.null(dat_dim)) { pos <- rep(0, length(dat_dim)) # dat_dim: [dataset, member] - for (i in 1:length(dat_dim)) { + for (i in seq_along(dat_dim)) { pos[i] <- which(names(dim(obs)) == dat_dim[i]) } outrows_exp <- MeanDims(exp, pos, na.rm = FALSE) + @@ -226,8 +227,6 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', if (is.null(dat_dim)) { ini_dims_exp <- dim(exp) ini_dims_obs <- dim(obs) - ini_dims_exp_for_clim <- dim(exp) - ini_dims_obs_for_clim <- dim(exp) exp <- InsertDim(exp, posdim = 2, lendim = 1, name = 'dataset') exp_for_clim <- InsertDim(exp_for_clim, posdim = 2, lendim = 1, name = 'dataset') obs <- InsertDim(obs, posdim = 2, lendim = 1, name = 'dataset') @@ -239,12 +238,13 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', ano_exp_list <- vector('list', length = dim(exp)[1]) #length: [sdate] ano_obs_list <- vector('list', length = dim(obs)[1]) - for (tt in 1:dim(exp)[1]) { #[sdate] + for (tt in seq_len(dim(exp)[1])) { #[sdate] # calculate clim - exp_sub <- ClimProjDiags::Subset(exp_for_clim, 1, c(1:dim(exp)[1])[-tt]) - obs_sub <- ClimProjDiags::Subset(obs_for_clim, 1, c(1:dim(obs)[1])[-tt]) - clim_exp <- apply(exp_sub, c(1:length(dim(exp)))[-1], mean, na.rm = TRUE) # average out time_dim -> [dat, memb] - clim_obs <- apply(obs_sub, c(1:length(dim(obs)))[-1], mean, na.rm = TRUE) + exp_sub <- ClimProjDiags::Subset(exp_for_clim, 1, seq_len(dim(exp)[1])[-tt]) + obs_sub <- ClimProjDiags::Subset(obs_for_clim, 1, seq_len(dim(obs)[1])[-tt]) + # Average out time_dim -> [dat, memb] + clim_exp <- apply(exp_sub, seq_along(dim(exp))[-1], mean, na.rm = TRUE) + clim_obs <- apply(obs_sub, seq_along(dim(obs))[-1], mean, na.rm = TRUE) # ensemble mean if (!memb) { @@ -253,7 +253,7 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', clim_obs <- mean(clim_obs, na.rm = TRUE) } else { pos <- which(names(dim(clim_exp)) == memb_dim) - pos <- c(1:length(dim(clim_exp)))[-pos] + pos <- seq_along(dim(clim_exp))[-pos] dim_name <- names(dim(clim_exp)) dim_exp_ori <- dim(clim_exp) dim_obs_ori <- dim(clim_obs) diff --git a/R/Bias.R b/R/Bias.R index 3662fb9..5ec8d0f 100644 --- a/R/Bias.R +++ b/R/Bias.R @@ -56,8 +56,8 @@ Bias <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, stop("Parameter 'exp' must be a numeric array.") if (!is.array(obs) | !is.numeric(obs)) stop("Parameter 'obs' must be a numeric array.") - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim @@ -105,8 +105,8 @@ Bias <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.") } ## na.rm if (!is.logical(na.rm) | length(na.rm) > 1) { diff --git a/R/BrierScore.R b/R/BrierScore.R index a925d94..682cdb1 100644 --- a/R/BrierScore.R +++ b/R/BrierScore.R @@ -108,11 +108,11 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd dim(obs) <- c(length(obs)) names(dim(obs)) <- time_dim } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } - if (any(!obs %in% c(0, 1))) { + if (!all(obs %in% c(0, 1))) { stop("Parameter 'obs' must be binary events (0 or 1).") } ## thresholds @@ -158,7 +158,7 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd stop("Parameter 'exp' must be within [0, 1] range.") } } else { - if (any(!exp %in% c(0, 1))) { + if (!all(exp %in% c(0, 1))) { stop("Parameter 'exp' must be 0 or 1 if it has memb_dim.") } } @@ -174,13 +174,13 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd name_exp <- name_exp[-which(name_exp == dat_dim)] name_obs <- name_obs[-which(name_obs == dat_dim)] } - if (any(!name_exp %in% name_obs) | any(!name_obs %in% name_exp)) { - stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions except 'dat_dim' and 'memb_dim'.")) + if (!all(name_exp %in% name_obs) | !all(name_obs %in% name_exp)) { + stop("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions except 'dat_dim' and 'memb_dim'.") } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions except 'dat_dim' and 'memb_dim'.") } ## ncores if (!is.null(ncores)) { @@ -281,7 +281,8 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd ressum <- ressum + nk[i] * (okbar[i] - obar)^2 for (j in 1:nk[i]) { term1 <- term1 + (exp[bins[[i]][[1]][j]] - fkbar[i])^2 - term2 <- term2 + (exp[bins[[i]][[1]][j]] - fkbar[i]) * (obs[bins[[i]][[1]][j]] - okbar[i]) + term2 <- term2 + (exp[bins[[i]][[1]][j]] - + fkbar[i]) * (obs[bins[[i]][[1]][j]] - okbar[i]) } } } @@ -306,18 +307,15 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd rel_bias_corrected <- rel - term_a gres_bias_corrected <- gres - term_a + term_b if (rel_bias_corrected < 0 || gres_bias_corrected < 0) { - rel_bias_corrected2 <- max(rel_bias_corrected, rel_bias_corrected - gres_bias_corrected, 0) - gres_bias_corrected2 <- max(gres_bias_corrected, gres_bias_corrected - rel_bias_corrected, 0) + rel_bias_corrected2 <- max(rel_bias_corrected, + rel_bias_corrected - gres_bias_corrected, 0) + gres_bias_corrected2 <- max(gres_bias_corrected, + gres_bias_corrected - rel_bias_corrected, 0) rel_bias_corrected <- rel_bias_corrected2 gres_bias_corrected <- gres_bias_corrected2 } unc_bias_corrected <- unc + term_b bss_bias_corrected <- (gres_bias_corrected - rel_bias_corrected) / unc_bias_corrected - - #if (round(bs, 8) == round(bs_check_gres, 8) & round(bs_check_gres, 8) == round((rel_bias_corrected - gres_bias_corrected + unc_bias_corrected), 8)) { - # cat("No error found \ n") - # cat("BS = REL - GRES + UNC = REL_lessbias - GRES_lessbias + UNC_lessbias \ n") - #} # Add name for nk, fkbar, okbar names(dim(nk)) <- 'bin' diff --git a/R/CDORemap.R b/R/CDORemap.R index b4f1545..402a2b6 100644 --- a/R/CDORemap.R +++ b/R/CDORemap.R @@ -420,7 +420,9 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } else if (method %in% 'con2') { method <- 'con2' } else { - stop("Unsupported CDO remap method. Only 'bilinear', 'bicubic', 'conservative', 'distance-weighted', 'nn', 'laf', and 'con2' are supported.") + stop("Unsupported CDO remap method. Only 'bilinear', ", + "'bicubic', 'conservative', 'distance-weighted', 'nn', ", + "'laf', and 'con2' are supported.") } # Check avoid_writes if (!is.logical(avoid_writes)) { @@ -432,7 +434,8 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, if (crop == 'tight') { crop_tight <- TRUE } else if (crop != 'preserve') { - stop("Parameter 'crop' can only take the values 'tight' or 'preserve' if specified as a character string.") + stop("Parameter 'crop' can only take the values 'tight' or 'preserve' ", + "if specified as a character string.") } crop <- TRUE } @@ -456,9 +459,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, tmp_lon <- lons } else { min_pos <- which(lons == min(lons), arr.ind = TRUE)[1, ] - tmp_lon <- Subset(lons, lat_dim, min_pos[which(names(dim(lons)) == lat_dim)], drop = 'selected') + tmp_lon <- Subset(lons, lat_dim, + min_pos[which(names(dim(lons)) == lat_dim)], + drop = 'selected') } - i <- 1:length(tmp_lon) + i <- seq_along(tmp_lon) degree <- min(3, length(i) - 1) lon_model <- lm(tmp_lon ~ poly(i, degree)) lon_extremes <- c(NA, NA) @@ -485,12 +490,14 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, # or from -180 to 180 when the extremes of the cropped window are contiguous. if (right_is_max) { if (lon_extremes[1] < -180) { - if (!((lon_extremes[2] < 180) && !((180 - lon_extremes[2]) <= last_lon_cell_width / 2))) { + if (!((lon_extremes[2] < 180) && + !((180 - lon_extremes[2]) <= last_lon_cell_width / 2))) { lon_extremes[1] <- -180 lon_extremes[2] <- 180 } } else if (lon_extremes[1] < 0) { - if (!((lon_extremes[2] < 360) && !((360 - lon_extremes[2]) <= last_lon_cell_width / 2))) { + if (!((lon_extremes[2] < 360) && + !((360 - lon_extremes[2]) <= last_lon_cell_width / 2))) { lon_extremes[1] <- 0 lon_extremes[2] <- 360 } @@ -498,12 +505,14 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } if (left_is_min) { if (lon_extremes[2] > 360) { - if (!((lon_extremes[1] > 0) && !(lon_extremes[1] <= first_lon_cell_width / 2))) { + if (!((lon_extremes[1] > 0) && + !(lon_extremes[1] <= first_lon_cell_width / 2))) { lon_extremes[1] <- 0 lon_extremes[2] <- 360 } } else if (lon_extremes[2] > 180) { - if (!((lon_extremes[1] > -180) && !((180 + lon_extremes[1]) <= first_lon_cell_width / 2))) { + if (!((lon_extremes[1] > -180) && + !((180 + lon_extremes[1]) <= first_lon_cell_width / 2))) { lon_extremes[1] <- -180 lon_extremes[2] <- 180 } @@ -516,9 +525,10 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, tmp_lat <- lats } else { min_pos <- which(lats == min(lats), arr.ind = TRUE)[1, ] - tmp_lat <- Subset(lats, lon_dim, min_pos[which(names(dim(lats)) == lon_dim)], drop = 'selected') + tmp_lat <- Subset(lats, lon_dim, min_pos[which(names(dim(lats)) == lon_dim)], + drop = 'selected') } - i <- 1:length(tmp_lat) + i <- seq_along(tmp_lat) degree <- min(3, length(i) - 1) lat_model <- lm(tmp_lat ~ poly(i, degree)) lat_extremes <- c(NA, NA) @@ -551,7 +561,8 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } } else if (is.numeric(crop)) { if (length(crop) != 4) { - stop("Paramrter 'crop' must be a logical value or a numeric vector of length 4: c(western border, eastern border, southern border, northern border.") + stop("Paramrter 'crop' must be a logical value or a numeric vector of length 4: ", + "c(western border, eastern border, southern border, northern border.") } else { lon_extremes <- crop[1:2] lat_extremes <- crop[3:4] @@ -679,7 +690,8 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, unlimited_dim <- NULL dims_to_iterate <- NULL total_slices <- 1 - other_dims_per_chunk <- ifelse(is_irregular, 1, 2) # 4 (the maximum accepted by CDO) - 2 (lon, lat) = 2. + # Explanation for below: 4 (the maximum accepted by CDO) - 2 (lon, lat) = 2 + other_dims_per_chunk <- ifelse(is_irregular, 1, 2) if (length(other_dims) > 1 || (length(other_dims) > 0 && (is_irregular))) { # If lat/lon is the last dimension OR the largest other_dims is not the last one, # reorder the largest other dimension to the last as unlimited dim. @@ -690,7 +702,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, dims_mod[which(names(dim(data_array)) %in% c(lon_dim, lat_dim))] <- 0 dim_to_move <- which.max(dims_mod) - permutation <- (1:length(dim(data_array)))[-dim_to_move] + permutation <- seq_along(dim(data_array))[-dim_to_move] permutation <- c(permutation, dim_to_move) permutation_back <- sort(permutation, index.return = TRUE)$ix # dim_backup <- dim(data_array) @@ -703,8 +715,10 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, other_dims_per_chunk <- 1 } } - other_dims_ordered_by_size <- other_dims[sort(dim(data_array)[other_dims], index.return = TRUE)$ix] - dims_to_iterate <- sort(head(other_dims_ordered_by_size, length(other_dims) - other_dims_per_chunk)) + other_dims_ordered_by_size <- other_dims[sort(dim(data_array)[other_dims], + index.return = TRUE)$ix] + dims_to_iterate <- sort(head(other_dims_ordered_by_size, length(other_dims) - + other_dims_per_chunk)) if (length(dims_to_iterate) == 0) { dims_to_iterate <- NULL } else { @@ -727,13 +741,15 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, dim_backup <- dim(data_array) attributes(data_array) <- NULL dim(data_array) <- dim_backup - names(dim(data_array)) <- paste0('dim', 1:length(dim(data_array))) + names(dim(data_array)) <- paste0('dim', seq_along(dim(data_array))) names(dim(data_array))[c(lon_pos, lat_pos)] <- c(lon_dim, lat_dim) if (!is.null(unlimited_dim)) { # This will make ArrayToNc create this dim as unlimited. names(dim(data_array))[unlimited_dim] <- 'time' - # create time variable. The value is random since CDORemap() doesn't support time remapping now and we just want to avoid cdo warning - time_attr <- array(c(1:dim(data_array)[unlimited_dim]), dim = c(dim(data_array)[unlimited_dim])) + # create time variable. The value is random since CDORemap() doesn't support + #time remapping now and we just want to avoid cdo warning + time_attr <- array(seq_len(dim(data_array)[unlimited_dim]), + dim = c(dim(data_array)[unlimited_dim])) } if (length(dim(lons)) == 1) { names(dim(lons)) <- lon_dim @@ -780,7 +796,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, pos_lat_dim_in_lons <- which(names(dim(lons)) == lat_dim) if ((pos_lon > pos_lat && pos_lon_dim_in_lons < pos_lat_dim_in_lons) || (pos_lon < pos_lat && pos_lon_dim_in_lons > pos_lat_dim_in_lons)) { - new_pos <- 1:length(dim(subset)) + new_pos <- seq_along(dim(subset)) new_pos[pos_lon] <- pos_lat new_pos[pos_lat] <- pos_lon subset <- .aperm2(subset, new_pos) @@ -796,9 +812,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, # dims_before_crop <- dim(subset) # Make sure subset goes along with metadata if (is.null(unlimited_dim)) { - easyNCDF::ArrayToNc(setNames(list(subset, lons, lats), c('var', lon_var_name, lat_var_name)), tmp_file) + easyNCDF::ArrayToNc(setNames(list(subset, lons, lats), + c('var', lon_var_name, lat_var_name)), tmp_file) } else { - easyNCDF::ArrayToNc(setNames(list(subset, lons, lats, time_attr), c('var', lon_var_name, lat_var_name, 'time')), tmp_file) + easyNCDF::ArrayToNc(setNames(list(subset, lons, lats, time_attr), + c('var', lon_var_name, lat_var_name, 'time')), tmp_file) } } else { if (is_irregular) { @@ -808,7 +826,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, pos_lat_dim_in_lons <- which(names(dim(lons)) == lat_dim) if ((pos_lon > pos_lat && pos_lon_dim_in_lons < pos_lat_dim_in_lons) || (pos_lon < pos_lat && pos_lon_dim_in_lons > pos_lat_dim_in_lons)) { - new_pos <- 1:length(dim(data_array)) + new_pos <- seq_along(dim(data_array)) new_pos[pos_lon] <- pos_lat new_pos[pos_lat] <- pos_lon data_array <- .aperm2(data_array, new_pos) @@ -816,9 +834,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } # dims_before_crop <- dim(data_array) if (is.null(unlimited_dim)) { - easyNCDF::ArrayToNc(setNames(list(data_array, lons, lats), c('var', lon_var_name, lat_var_name)), tmp_file) + easyNCDF::ArrayToNc(setNames(list(data_array, lons, lats), + c('var', lon_var_name, lat_var_name)), tmp_file) } else { - easyNCDF::ArrayToNc(setNames(list(data_array, lons, lats, time_attr), c('var', lon_var_name, lat_var_name, 'time')), tmp_file) + easyNCDF::ArrayToNc(setNames(list(data_array, lons, lats, time_attr), + c('var', lon_var_name, lat_var_name, 'time')), tmp_file) } } sellonlatbox <- '' @@ -831,12 +851,14 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, if (is.null(ncores)) { err <- try({ system(paste0("cdo -s ", sellonlatbox, "remap", method, ",", grid, " ", - tmp_file, " ", tmp_file2), ignore.stdout = !print_sys_msg, ignore.stderr = !print_sys_msg) + tmp_file, " ", tmp_file2), + ignore.stdout = !print_sys_msg, ignore.stderr = !print_sys_msg) }) } else { err <- try({ - system(paste0("cdo -P ", ncores," -s ", sellonlatbox, "remap", method, ",", - grid, " ", tmp_file, " ", tmp_file2), ignore.stdout = !print_sys_msg, ignore.stderr = !print_sys_msg) + system(paste0("cdo -P ", ncores, " -s ", sellonlatbox, "remap", method, ",", + grid, " ", tmp_file, " ", tmp_file2), + ignore.stdout = !print_sys_msg, ignore.stderr = !print_sys_msg) }) } file.remove(tmp_file) @@ -920,7 +942,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, # If is irregular, lat and lon position need to be checked: if (is_irregular) { if (lon_pos > lat_pos) { - new_pos <- 1:length(new_dims) + new_pos <- seq_along(new_dims) new_pos[lon_pos] <- lat_pos new_pos[lat_pos] <- lon_pos new_dims <- new_dims[new_pos] @@ -932,7 +954,8 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } if (return_array) { store_indices[dims_to_iterate] <- as.list(slice_indices) - # If is irregular, the order of dimenesions in result_array and file may be different and need to be checked before reading the temporal file: + # If is irregular, the order of dimenesions in result_array and file may be + # different and need to be checked before reading the temporal file: if (is_irregular) { test_dims <- dim(ncvar_get(ncdf_remapped, 'var', collapse_degen = FALSE)) @@ -940,7 +963,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, pos_test_dims <- match(dim(result_array), test_dims) if (is.unsorted(pos_test_dims, na.rm = TRUE)) { # pos_new_dims is used later in the code. Don't overwrite - pos_new_dims <- 1:length(dim(result_array)) + pos_new_dims <- seq_along(dim(result_array)) pos_new_dims[which(!is.na(pos_test_dims))] <- match(test_dims, dim(result_array)) backup_result_array_dims <- dim(result_array) @@ -948,7 +971,8 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } } result_array <- do.call('[<-', c(list(x = result_array), store_indices, - list(value = ncvar_get(ncdf_remapped, 'var', collapse_degen = FALSE)))) + list(value = ncvar_get(ncdf_remapped, 'var', + collapse_degen = FALSE)))) } } else { new_dims <- dim(data_array) @@ -957,7 +981,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, lon_pos <- which(names(new_dims) == lon_dim) lat_pos <- which(names(new_dims) == lat_dim) if (lon_pos > lat_pos) { - new_pos <- 1:length(new_dims) + new_pos <- seq_along(new_dims) new_pos[lon_pos] <- lat_pos new_pos[lat_pos] <- lon_pos new_dims <- new_dims[new_pos] @@ -990,14 +1014,17 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, if (length(dim(found_lats)) > 1 && length(dim(found_lons)) > 1) { result_is_irregular <- TRUE } - attribute_backup[['dim']][which(names(dim(result_array)) == lon_dim)] <- dim(result_array)[lon_dim] - attribute_backup[['dim']][which(names(dim(result_array)) == lat_dim)] <- dim(result_array)[lat_dim] + attribute_backup[['dim']][which(names(dim(result_array)) == lon_dim)] <- + dim(result_array)[lon_dim] + attribute_backup[['dim']][which(names(dim(result_array)) == lat_dim)] <- + dim(result_array)[lat_dim] names(attribute_backup[['dim']])[which(names(dim(result_array)) == lon_dim)] <- new_lon_name names(attribute_backup[['dim']])[which(names(dim(result_array)) == lat_dim)] <- new_lat_name - if (!is.null(attribute_backup[['variables']]) && (length(attribute_backup[['variables']]) > 0)) { - for (var in 1:length(attribute_backup[['variables']])) { + if (!is.null(attribute_backup[['variables']]) && + (length(attribute_backup[['variables']]) > 0)) { + for (var in seq_along(attribute_backup[['variables']])) { if (length(attribute_backup[['variables']][[var]][['dim']]) > 0) { - for (dim in 1:length(attribute_backup[['variables']][[var]][['dim']])) { + for (dim in seq_along(attribute_backup[['variables']][[var]][['dim']])) { dim_name <- NULL if ('name' %in% names(attribute_backup[['variables']][[var]][['dim']][[dim]])) { dim_name <- attribute_backup[['variables']][[var]][['dim']][[dim]][['name']] @@ -1012,9 +1039,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, dim_name <- names(attribute_backup[['variables']][[var]][['dim']])[dim] if (dim_name %in% c(lon_dim, lat_dim)) { if (dim_name == lon_dim) { - names(attribute_backup[['variables']][[var]][['dim']])[which(names(attribute_backup[['variables']][[var]][['dim']]) == lon_dim)] <- new_lon_name + tmp <- which(names(attribute_backup[['variables']][[var]][['dim']]) == lon_dim) + names(attribute_backup[['variables']][[var]][['dim']])[tmp] <- new_lon_name } else { - names(attribute_backup[['variables']][[var]][['dim']])[which(names(attribute_backup[['variables']][[var]][['dim']]) == lat_dim)] <- new_lat_name + tmp <- which(names(attribute_backup[['variables']][[var]][['dim']]) == lat_dim) + names(attribute_backup[['variables']][[var]][['dim']])[tmp] <- new_lat_name } } } @@ -1026,13 +1055,15 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, new_vals <- found_lats[TRUE] } if (!is.null(attribute_backup[['variables']][[var]][['dim']][[dim]][['len']])) { - attribute_backup[['variables']][[var]][['dim']][[dim]][['len']] <- length(new_vals) + attribute_backup[['variables']][[var]][['dim']][[dim]][['len']] <- + length(new_vals) } if (!is.null(attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']])) { if (!result_is_irregular) { attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']] <- new_vals } else { - attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']] <- 1:length(new_vals) + attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']] <- + seq_along(new_vals) } } } @@ -1049,10 +1080,10 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, attributes(result_array) <- attribute_backup lons_attr_bk[['dim']] <- dim(found_lons) if (!is.null(lons_attr_bk[['variables']]) && (length(lons_attr_bk[['variables']]) > 0)) { - for (var in 1:length(lons_attr_bk[['variables']])) { + for (var in seq_along(lons_attr_bk[['variables']])) { if (length(lons_attr_bk[['variables']][[var]][['dim']]) > 0) { dims_to_remove <- NULL - for (dim in 1:length(lons_attr_bk[['variables']][[var]][['dim']])) { + for (dim in seq_along(lons_attr_bk[['variables']][[var]][['dim']])) { dim_name <- NULL if ('name' %in% names(lons_attr_bk[['variables']][[var]][['dim']][[dim]])) { dim_name <- lons_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] @@ -1067,9 +1098,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, dim_name <- names(lons_attr_bk[['variables']][[var]][['dim']])[dim] if (dim_name %in% c(lon_dim, lat_dim)) { if (dim_name == lon_dim) { - names(lons_attr_bk[['variables']][[var]][['dim']])[which(names(lons_attr_bk[['variables']][[var]][['dim']]) == lon_dim)] <- new_lon_name + tmp <- which(names(lons_attr_bk[['variables']][[var]][['dim']]) == lon_dim) + names(lons_attr_bk[['variables']][[var]][['dim']])[tmp] <- new_lon_name } else { - names(lons_attr_bk[['variables']][[var]][['dim']])[which(names(lons_attr_bk[['variables']][[var]][['dim']]) == lat_dim)] <- new_lat_name + tmp <- which(names(lons_attr_bk[['variables']][[var]][['dim']]) == lat_dim) + names(lons_attr_bk[['variables']][[var]][['dim']])[tmp] <- new_lat_name } } } @@ -1090,14 +1123,16 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, if (!result_is_irregular) { lons_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- new_vals } else { - lons_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- 1:length(new_vals) + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- + seq_along(new_vals) } } } } } if (length(dims_to_remove) > 1) { - lons_attr_bk[['variables']][[var]][['dim']] <- lons_attr_bk[['variables']][[var]][['dim']][[-dims_to_remove]] + lons_attr_bk[['variables']][[var]][['dim']] <- + lons_attr_bk[['variables']][[var]][['dim']][[-dims_to_remove]] } } } @@ -1107,10 +1142,10 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, attributes(found_lons) <- lons_attr_bk lats_attr_bk[['dim']] <- dim(found_lats) if (!is.null(lats_attr_bk[['variables']]) && (length(lats_attr_bk[['variables']]) > 0)) { - for (var in 1:length(lats_attr_bk[['variables']])) { + for (var in seq_along(lats_attr_bk[['variables']])) { if (length(lats_attr_bk[['variables']][[var]][['dim']]) > 0) { dims_to_remove <- NULL - for (dim in 1:length(lats_attr_bk[['variables']][[var]][['dim']])) { + for (dim in seq_along(lats_attr_bk[['variables']][[var]][['dim']])) { dim_name <- NULL if ('name' %in% names(lats_attr_bk[['variables']][[var]][['dim']][[dim]])) { dim_name <- lats_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] @@ -1125,9 +1160,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, dim_name <- names(lats_attr_bk[['variables']][[var]][['dim']])[dim] if (dim_name %in% c(lon_dim, lat_dim)) { if (dim_name == lon_dim) { - names(lats_attr_bk[['variables']][[var]][['dim']])[which(names(lats_attr_bk[['variables']][[var]][['dim']]) == lon_dim)] <- new_lon_name + tmp <- which(names(lats_attr_bk[['variables']][[var]][['dim']]) == lon_dim) + names(lats_attr_bk[['variables']][[var]][['dim']])[tmp] <- new_lon_name } else { - names(lats_attr_bk[['variables']][[var]][['dim']])[which(names(lats_attr_bk[['variables']][[var]][['dim']]) == lat_dim)] <- new_lat_name + tmp <- which(names(lats_attr_bk[['variables']][[var]][['dim']]) == lat_dim) + names(lats_attr_bk[['variables']][[var]][['dim']])[tmp] <- new_lat_name } } } @@ -1148,14 +1185,16 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, if (!result_is_irregular) { lats_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- new_vals } else { - lats_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- 1:length(new_vals) + lats_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- + seq_along(new_vals) } } } } } if (length(dims_to_remove) > 1) { - lats_attr_bk[['variables']][[var]][['dim']] <- lats_attr_bk[['variables']][[var]][['dim']][[-dims_to_remove]] + lats_attr_bk[['variables']][[var]][['dim']] <- + lats_attr_bk[['variables']][[var]][['dim']][[-dims_to_remove]] } } } diff --git a/R/CRPS.R b/R/CRPS.R index 4e6dd3e..6524bee 100644 --- a/R/CRPS.R +++ b/R/CRPS.R @@ -54,8 +54,8 @@ CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NU stop("Parameter 'exp' must be a numeric array.") if (!is.array(obs) | !is.numeric(obs)) stop("Parameter 'obs' must be a numeric array.") - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim @@ -86,7 +86,8 @@ CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NU if (identical(as.numeric(dim(obs)[memb_dim]), 1)) { obs <- ClimProjDiags::Subset(x = obs, along = memb_dim, indices = 1, drop = 'selected') } else { - stop("Not implemented for observations with members ('obs' can have 'memb_dim', but it should be of length = 1).") + stop("Not implemented for observations with members ", + "('obs' can have 'memb_dim', but it should be of length = 1).") } } name_exp <- sort(names(dim(exp))) @@ -98,8 +99,8 @@ CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NU } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.") } ## Fair if (!is.logical(Fair) | length(Fair) > 1) { @@ -152,14 +153,14 @@ CRPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', dat_dim = NU for (i in 1:nexp) { for (j in 1:nobs) { - exp_data <- exp[ , , i] - obs_data <- obs[ , j] + exp_data <- exp[, , i] + obs_data <- obs[, j] if (is.null(dim(exp_data))) dim(exp_data) <- c(dim(exp)[1:2]) if (is.null(dim(obs_data))) dim(obs_data) <- c(dim(obs)[1]) crps <- SpecsVerification::enscrps_cpp(ens = exp_data, obs = obs_data, R_new = R_new) - CRPS[ , i, j] <- crps + CRPS[, i, j] <- crps } } diff --git a/R/CRPSS.R b/R/CRPSS.R index 5804051..894b361 100644 --- a/R/CRPSS.R +++ b/R/CRPSS.R @@ -158,17 +158,17 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.null(dat_dim)) { if (dat_dim %in% name_ref) { if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { - stop(paste0("If parameter 'ref' has dataset dimension it must be", - " equal to dataset dimension of 'exp'.")) + stop("If parameter 'ref' has dataset dimension it must be", + " equal to dataset dimension of 'exp'.") } name_ref <- name_ref[-which(name_ref == dat_dim)] } } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'ref' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim' if there is ", - "only one reference dataset.")) + stop("Parameter 'exp' and 'ref' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.") } } ## Fair @@ -186,7 +186,8 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', ## sig_method.type #NOTE: These are the types of RandomWalkTest() if (!sig_method.type %in% c('two.sided.approx', 'two.sided', 'greater', 'less')) { - stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', 'greater', or 'less'.") + stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', ", + "'greater', or 'less'.") } if (sig_method.type == 'two.sided.approx') { if (alpha != 0.05) { @@ -264,7 +265,8 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (isFALSE(clim.cross.val)) { ## Without cross-validation ref <- array(data = rep(obs, each = obs_time_len), dim = c(obs_time_len, obs_time_len)) - } else if (isTRUE(clim.cross.val)) { ## With cross-validation (excluding the value of that year to create ref for that year) + } else if (isTRUE(clim.cross.val)) { + # With cross-validation (excluding the value of that year to create ref for that year) ref <- array(data = NA, dim = c(obs_time_len, obs_time_len - 1)) for (i in 1:obs_time_len) { ref[i, ] <- obs[-i] @@ -283,8 +285,10 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', for (i_obs in 1:nobs) { if (isFALSE(clim.cross.val)) { ## Without cross-validation - ref <- array(data = rep(obs[, i_obs], each = obs_time_len), dim = c(obs_time_len, obs_time_len)) - } else if (isTRUE(clim.cross.val)) { ## With cross-validation (excluding the value of that year to create ref for that year) + ref <- array(data = rep(obs[, i_obs], each = obs_time_len), + dim = c(obs_time_len, obs_time_len)) + } else if (isTRUE(clim.cross.val)) { + # With cross-validation (excluding the value of that year to create ref for that year) ref <- array(data = NA, dim = c(obs_time_len, obs_time_len - 1)) for (i in 1:obs_time_len) { ref[i, ] <- obs[-i, i_obs] @@ -292,8 +296,10 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } names(dim(ref)) <- c(time_dim, memb_dim) - crps_ref[, i_obs] <- .CRPS(exp = ref, obs = ClimProjDiags::Subset(obs, dat_dim, i_obs, drop = 'selected'), - time_dim = time_dim, memb_dim = memb_dim, dat_dim = NULL, Fair = Fair) + crps_ref[, i_obs] <- + .CRPS(exp = ref, + obs = ClimProjDiags::Subset(obs, dat_dim, i_obs, drop = 'selected'), + time_dim = time_dim, memb_dim = memb_dim, dat_dim = NULL, Fair = Fair) } # crps_ref should be [sdate, nobs] } @@ -301,7 +307,7 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } else { # ref is not NULL if (!is.null(dat_dim) && (!dat_dim %in% names(dim(ref)))) { remove_dat_dim <- TRUE - ref <- InsertDim(data = ref, posdim = length(dim(ref)) + 1 , lendim = 1, name = dat_dim) + ref <- InsertDim(data = ref, posdim = length(dim(ref)) + 1, lendim = 1, name = dat_dim) } else { remove_dat_dim <- FALSE } @@ -318,7 +324,8 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', #----- CRPSS if (!is.null(dat_dim)) { - # If ref != NULL & ref has dat_dim, crps_ref = [sdate, nexp, nobs]; else, crps_ref = [sdate, nobs] + # If ref != NULL & ref has dat_dim, crps_ref = [sdate, nexp, nobs]; + # else, crps_ref = [sdate, nobs] crps_exp_mean <- MeanDims(crps_exp, time_dim, na.rm = FALSE) crps_ref_mean <- MeanDims(crps_ref, time_dim, na.rm = FALSE) @@ -338,7 +345,8 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', for (i in 1:nexp) { for (j in 1:nobs) { crpss[i, j] <- 1 - crps_exp_mean[i, j] / crps_ref_mean[i, j] - sign[i, j] <- .RandomWalkTest(skill_A = crps_exp_mean[i, j], skill_B = crps_ref_mean[i, j], + sign[i, j] <- .RandomWalkTest(skill_A = crps_exp_mean[i, j], + skill_B = crps_ref_mean[i, j], test.type = sig_method.type, alpha = alpha, sign = T, pval = F)$sign } diff --git a/R/Clim.R b/R/Clim.R index d49c260..38e6964 100644 --- a/R/Clim.R +++ b/R/Clim.R @@ -3,7 +3,8 @@ #'This function computes per-pair climatologies for the experimental #'and observational data using one of the following methods: #'\enumerate{ -#' \item{per-pair method (Garcia-Serrano and Doblas-Reyes, CD, 2012 https://doi.org/10.1007/s00382-012-1413-1)} +#' \item{per-pair method (Garcia-Serrano and Doblas-Reyes, CD, 2012 +#' https://doi.org/10.1007/s00382-012-1413-1)} #' \item{Kharin method (Kharin et al, GRL, 2012 https://doi.org/10.1029/2012GL052647)} #' \item{Fuckar method (Fuckar et al, GRL, 2014 https://doi.org/10.1002/2014GL060815)} #'} @@ -86,8 +87,8 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), stop("Parameter 'exp' and 'obs' must be a numeric array.") } if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", - "containing time_dim and dat_dim.")) + stop("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and dat_dim.") } if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { @@ -110,7 +111,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), stop("Parameter 'dat_dim' is not found in 'exp' dimensions.") } # If dat_dim is not in obs, add it in - if (any(!dat_dim %in% names(dim(obs)))) { + if (!all(dat_dim %in% names(dim(obs)))) { reset_obs_dim <- TRUE ori_obs_dim <- dim(obs) dim(obs) <- c(dim(obs), rep(1, length(dat_dim[which(!dat_dim %in% names(dim(obs)))]))) @@ -166,14 +167,14 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) if (!is.null(dat_dim)) { - for (i in 1:length(dat_dim)) { + for (i in seq_along(dat_dim)) { name_exp <- name_exp[-which(name_exp == dat_dim[i])] name_obs <- name_obs[-which(name_obs == dat_dim[i])] } } - if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have the same dimensions ", - "except 'dat_dim'.")) + if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + stop("Parameter 'exp' and 'obs' must have the same dimensions ", + "except 'dat_dim'.") } ############################### @@ -191,7 +192,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), # Per-pair: Remove all sdate if not complete along dat_dim if (!is.null(dat_dim)) { pos <- rep(0, length(dat_dim)) - for (i in 1:length(dat_dim)) { #[dat, sdate] + for (i in seq_along(dat_dim)) { #[dat, sdate] ## dat_dim: [dataset, member] pos[i] <- which(names(dim(obs)) == dat_dim[i]) } @@ -199,7 +200,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), MeanDims(obs, pos, na.rm = FALSE) outrows_obs <- outrows_exp - for (i in 1:length(pos)) { + for (i in seq_along(pos)) { outrows_exp <- InsertDim(outrows_exp, pos[i], dim(exp)[pos[i]]) outrows_obs <- InsertDim(outrows_obs, pos[i], dim(obs)[pos[i]]) } @@ -283,7 +284,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), clim_obs <- mean(clim_obs, na.rm = TRUE) } else { dim_name <- names(dim(clim_exp)) - pos <- c(1:length(dim(clim_exp)))[-which(dim_name == memb_dim)] + pos <- c(seq_along(dim(clim_exp)))[-which(dim_name == memb_dim)] clim_exp <- apply(clim_exp, pos, mean, na.rm = TRUE) clim_obs <- apply(clim_obs, pos, mean, na.rm = TRUE) if (is.null(dim(clim_exp))) { @@ -337,7 +338,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), } trend_exp <- list() trend_obs <- list() - for (jdate in 1:dim(exp)[time_dim]) { + for (jdate in seq_len(dim(exp)[time_dim])) { trend_exp[[jdate]] <- intercept_exp + jdate * slope_exp trend_obs[[jdate]] <- intercept_obs + jdate * slope_obs } @@ -361,8 +362,8 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), ## member mean if (!memb) { - pos_exp <- c(1:length(dim(clim_exp)))[-which(names(dim(clim_exp)) == memb_dim)] - pos_obs <- c(1:length(dim(clim_obs)))[-which(names(dim(clim_obs)) == memb_dim)] + pos_exp <- c(seq_along(dim(clim_exp)))[-which(names(dim(clim_exp)) == memb_dim)] + pos_obs <- c(seq_along(dim(clim_obs)))[-which(names(dim(clim_obs)) == memb_dim)] tmp_dim_exp <- dim(clim_exp) tmp_dim_obs <- dim(clim_obs) clim_exp <- apply(clim_exp, pos_exp, mean, na.rm = TRUE) @@ -418,26 +419,31 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), na.action = na.omit, pval = FALSE, conf = FALSE, ncores = ncores_input)$regression #tmp_: [stats = 2, dat_dim, ftime] - tmp_obs_mean <- apply(tmp_obs, c(1, length(dim(tmp_obs))), mean) #average out dat_dim (dat and member) + #average out dat_dim (dat and member) + tmp_obs_mean <- apply(tmp_obs, c(1, length(dim(tmp_obs))), mean) #tmp_obs_mean: [stats = 2, ftime] - ini_obs_mean <- apply(ini_obs, c(1, length(dim(ini_obs))), mean) #average out dat_dim + #average out dat_dim + ini_obs_mean <- apply(ini_obs, c(1, length(dim(ini_obs))), mean) #ini_obs_mean: [sdate, ftime] # Find intercept and slope intercept_exp <- Subset(tmp_exp, 1, 1, drop = 'selected') #[dat_dim, ftime] slope_exp <- Subset(tmp_exp, 1, 2, drop = 'selected') #[dat_dim, ftime] - intercept_obs <- array(tmp_obs_mean[1, ], dim = c(dim_ftime, dim_dat)) #[ftime, dat_dim] exp + intercept_obs <- array(tmp_obs_mean[1, ], + dim = c(dim_ftime, dim_dat)) #[ftime, dat_dim] exp if (!is.null(dat_dim)) { - intercept_obs <- Reorder(intercept_obs, c(2:length(dim(intercept_obs)), 1)) #[dat_dim, ftime] exp + intercept_obs <- Reorder(intercept_obs, + c(2:length(dim(intercept_obs)), 1)) #[dat_dim, ftime] exp } slope_obs <- array(tmp_obs_mean[2, ], dim = c(dim_ftime, dim_dat)) #[ftime, dat_dim] exp if (!is.null(dat_dim)) { - slope_obs <- Reorder(slope_obs, c(2:length(dim(slope_obs)), 1)) #[dat_dim, ftime] exp + slope_obs <- Reorder(slope_obs, + c(2:length(dim(slope_obs)), 1)) #[dat_dim, ftime] exp } trend_exp <- list() trend_obs <- list() - for (jdate in 1:dim(exp)[time_dim]) { + for (jdate in seq_len(dim(exp)[time_dim])) { tmp <- Subset(ini_exp, time_dim, jdate, drop = 'selected') #[dat_dim, ftime] trend_exp[[jdate]] <- intercept_exp + tmp * slope_exp #[dat_dim, ftime] @@ -470,8 +476,8 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), ## member mean if (!memb) { - pos_exp <- c(1:length(dim(clim_exp)))[-which(names(dim(clim_exp)) == memb_dim)] - pos_obs <- c(1:length(dim(clim_obs)))[-which(names(dim(clim_obs)) == memb_dim)] + pos_exp <- c(seq_along(dim(clim_exp)))[-which(names(dim(clim_exp)) == memb_dim)] + pos_obs <- c(seq_along(dim(clim_obs)))[-which(names(dim(clim_obs)) == memb_dim)] tmp_dim_exp <- dim(clim_exp) tmp_dim_obs <- dim(clim_obs) diff --git a/R/Cluster.R b/R/Cluster.R index c330809..e428b2b 100644 --- a/R/Cluster.R +++ b/R/Cluster.R @@ -142,7 +142,7 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } @@ -174,7 +174,7 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, if (!is.character(space_dim)) { stop("Parameter 'space_dim' must be a character vector.") } - if (any(!space_dim %in% names(dim(data)))) { + if (!all(space_dim %in% names(dim(data)))) { stop("Parameter 'space_dim' is not found in 'data' dimensions.") } if (!is.null(weights)) { @@ -202,7 +202,8 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, ## index if (!is.character(index) | length(index) > 1) { - stop("Parameter 'index' should be a character strings accepted as 'index' by the function NbClust::NbClust.") + stop("Parameter 'index' should be a character strings accepted as 'index' ", + "by the function NbClust::NbClust.") } ## ncores @@ -240,7 +241,7 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, return(output) } -.Cluster <- function(data, weights = NULL, nclusters, index = 'sdindex') { +.Cluster <- function(data, nclusters, weights = NULL, index = 'sdindex') { # data: [time, (lat, lon)] dat_dim <- dim(data) @@ -252,7 +253,9 @@ Cluster <- function(data, weights = NULL, time_dim = 'sdate', space_dim = NULL, if (!is.null(weights)) { dim(weights) <- prod(dim(weights)) # a vector data_list <- lapply(1:dat_dim[1], - function(x) { data[x, ] * weights }) + function(x) { + data[x, ] * weights + }) data <- do.call(abind::abind, c(data_list, along = 0)) } } diff --git a/R/Composite.R b/R/Composite.R index 9b5cd2b..71010b0 100644 --- a/R/Composite.R +++ b/R/Composite.R @@ -100,7 +100,7 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), if (length(dim(data)) < 3) { stop("Parameter 'data' must have at least three dimensions.") } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## occ @@ -118,8 +118,8 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), stop("Parameter 'time_dim' is not found in 'data' dimension.") } if (dim(data)[time_dim] != length(occ)) { - stop(paste0("The length of time_dim dimension in parameter 'data' is not ", - "equal to length of parameter 'occ'.")) + stop("The length of time_dim dimension in parameter 'data' is not ", + "equal to length of parameter 'occ'.") } ## space_dim if (!is.character(space_dim) | length(space_dim) != 2) { diff --git a/R/Consist_Trend.R b/R/Consist_Trend.R index e96a9e7..d2f5fbd 100644 --- a/R/Consist_Trend.R +++ b/R/Consist_Trend.R @@ -90,15 +90,15 @@ Consist_Trend <- function(exp, obs, dat_dim = 'dataset', time_dim = 'sdate', int stop("Parameter 'exp' and 'obs' must be a numeric array.") } if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", - "containing time_dim and dat_dim.")) + stop("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and dat_dim.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } - if(!all(names(dim(exp)) %in% names(dim(obs))) | - !all(names(dim(obs)) %in% names(dim(exp)))) { + if (!all(names(dim(exp)) %in% names(dim(obs))) | + !all(names(dim(obs)) %in% names(dim(exp)))) { stop("Parameter 'exp' and 'obs' must have the same dimension names.") } ## time_dim @@ -118,13 +118,13 @@ Consist_Trend <- function(exp, obs, dat_dim = 'dataset', time_dim = 'sdate', int ## exp and obs (2) name_exp <- sort(names(dim(exp))) name_obs <- sort(names(dim(obs))) - for (i in 1:length(dat_dim)) { + for (i in seq_along(dat_dim)) { name_exp <- name_exp[-which(name_exp == dat_dim[i])] name_obs <- name_obs[-which(name_obs == dat_dim[i])] } - if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension except 'dat_dim'.")) + if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimension except 'dat_dim'.") } ## interval if (!is.numeric(interval) | interval <= 0 | length(interval) > 1) { diff --git a/R/Corr.R b/R/Corr.R index 2d512be..5e8fa72 100644 --- a/R/Corr.R +++ b/R/Corr.R @@ -1,4 +1,5 @@ -#'Compute the correlation coefficient between an array of forecast and their corresponding observation +#'Compute the correlation coefficient between an array of forecast and their +#'corresponding observation #' #'Calculate the correlation coefficient (Pearson, Kendall or Spearman) for #'an array of forecast and an array of observation. The correlations are @@ -118,11 +119,11 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, stop("Parameter 'exp' and 'obs' must be a numeric array.") } if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", - "containing time_dim and dat_dim.")) + stop("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and dat_dim.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim @@ -158,8 +159,8 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, } if (!is.numeric(limits) | any(limits %% 1 != 0) | any(limits < 0) | length(limits) != 2 | any(limits > dim(exp)[comp_dim])) { - stop(paste0("Parameter 'limits' must be a vector of two positive ", - "integers smaller than the length of paramter 'comp_dim'.")) + stop("Parameter 'limits' must be a vector of two positive ", + "integers smaller than the length of paramter 'comp_dim'.") } } ## method @@ -172,7 +173,8 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, stop("Parameter 'memb_dim' must be a character string.") } if (!memb_dim %in% names(dim(exp)) & !memb_dim %in% names(dim(obs))) { - stop("Parameter 'memb_dim' is not found in 'exp' nor 'obs' dimension. Set it as NULL if there is no member dimension.") + stop("Parameter 'memb_dim' is not found in 'exp' nor 'obs' dimension. ", + "Set it as NULL if there is no member dimension.") } # Add [member = 1] if (memb_dim %in% names(dim(exp)) & !memb_dim %in% names(dim(obs))) { @@ -223,8 +225,8 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, name_obs <- name_obs[-which(name_obs == memb_dim)] } if (!identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimension except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimension except 'dat_dim' and 'memb_dim'.") } if (dim(exp)[time_dim] < 3) { stop("The length of time_dim must be at least 3 to compute correlation.") @@ -289,7 +291,7 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, nexp <- 1 nobs <- 1 CORR <- array(dim = c(nexp = nexp, nobs = nobs)) - if (any(!is.na(exp)) && sum(!is.na(obs)) > 2) { + if (!all(is.na(exp)) && sum(!is.na(obs)) > 2) { CORR <- cor(exp, obs, use = "pairwise.complete.obs", method = method) } } else { @@ -300,7 +302,7 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, CORR <- array(dim = c(nexp = nexp, nobs = nobs)) for (j in 1:nobs) { for (y in 1:nexp) { - if (any(!is.na(exp[, y])) && sum(!is.na(obs[, j])) > 2) { + if (!all(is.na(exp[, y])) && sum(!is.na(obs[, j])) > 2) { CORR[y, j] <- cor(exp[, y], obs[, j], use = "pairwise.complete.obs", method = method) @@ -338,7 +340,7 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, for (j in 1:obs_memb) { for (y in 1:exp_memb) { - if (any(!is.na(exp[,y])) && sum(!is.na(obs[, j])) > 2) { + if (!all(is.na(exp[, y])) && sum(!is.na(obs[, j])) > 2) { CORR[, , y, j] <- cor(exp[, y], obs[, j], use = "pairwise.complete.obs", method = method) @@ -358,7 +360,7 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, for (y in 1:exp_memb) { CORR[, , y, j] <- sapply(1:nobs, function(i) { sapply(1:nexp, function (x) { - if (any(!is.na(exp[, x, y])) && sum(!is.na(obs[, i, j])) > 2) { + if (!all(is.na(exp[, x, y])) && sum(!is.na(obs[, i, j])) > 2) { cor(exp[, x, y], obs[, i, j], use = "pairwise.complete.obs", method = method) @@ -390,7 +392,9 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, if (pval || conf || sign) { if (method == "kendall" | method == "spearman") { if (!is.null(dat_dim) | !is.null(memb_dim)) { - tmp <- apply(obs, c(1:length(dim(obs)))[-1], rank) # for memb_dim = NULL, 2; for memb_dim, c(2, 3) + tmp <- apply(obs, + c(seq_along(dim(obs)))[-1], + rank) # for memb_dim = NULL, 2; for memb_dim, c(2, 3) names(dim(tmp))[1] <- time_dim eno <- Eno(tmp, time_dim) } else { @@ -409,7 +413,8 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, eno_expand[i, ] <- eno } } else { #member - eno_expand <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) + eno_expand <- array(dim = c(nexp = nexp, nobs = nobs, + exp_memb = exp_memb, obs_memb = obs_memb)) for (i in 1:nexp) { for (j in 1:exp_memb) { eno_expand[i, , j, ] <- eno diff --git a/R/DiffCorr.R b/R/DiffCorr.R index d42dfc2..3148e6f 100644 --- a/R/DiffCorr.R +++ b/R/DiffCorr.R @@ -100,12 +100,12 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', if (!is.numeric(N.eff)) stop("Parameter 'N.eff' must be numeric.") if (!all(names(dim(N.eff)) %in% names(dim(obs))) | any(dim(obs)[match(names(dim(N.eff)), names(dim(obs)))] != dim(N.eff))) { - stop(paste0('If parameter "N.eff" is provided with an array, it must ', - 'have the same dimensions as "obs" except "time_dim".')) + stop('If parameter "N.eff" is provided with an array, it must ', + 'have the same dimensions as "obs" except "time_dim".') } } else if (any((!is.na(N.eff) & !is.numeric(N.eff)) | length(N.eff) != 1)) { - stop(paste0('Parameter "N.eff" must be NA, a numeric, or an array with ', - 'the same dimensions as "obs" except "time_dim".')) + stop('Parameter "N.eff" must be NA, a numeric, or an array with ', + 'the same dimensions as "obs" except "time_dim".') } ## time_dim if (!is.character(time_dim) | length(time_dim) != 1) @@ -132,9 +132,10 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', name_ref <- name_ref[-which(name_ref == memb_dim)] } if (length(name_exp) != length(name_obs) | length(name_exp) != length(name_ref) | - !identical(dim(exp)[name_exp], dim(obs)[name_obs]) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp', 'obs', and 'ref' must have same length of ", - "all dimensions except 'memb_dim'.")) + !identical(dim(exp)[name_exp], dim(obs)[name_obs]) | + !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { + stop("Parameter 'exp', 'obs', and 'ref' must have same length of ", + "all dimensions except 'memb_dim'.") } ## method if (!method %in% c("pearson", "spearman")) { @@ -175,13 +176,12 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', # Calculate ensemble means dim_exp <- dim(exp) dim_ref <- dim(ref) - dim_obs <- dim(obs) if (!is.null(memb_dim)) { exp_memb_dim_ind <- which(names(dim_exp) == memb_dim) ref_memb_dim_ind <- which(names(dim_ref) == memb_dim) - exp <- apply(exp, c(1:length(dim_exp))[-exp_memb_dim_ind], mean, na.rm = FALSE) - ref <- apply(ref, c(1:length(dim_ref))[-ref_memb_dim_ind], mean, na.rm = FALSE) + exp <- apply(exp, c(seq_along(dim_exp))[-exp_memb_dim_ind], mean, na.rm = FALSE) + ref <- apply(ref, c(seq_along(dim_ref))[-ref_memb_dim_ind], mean, na.rm = FALSE) if (is.null(dim(exp))) exp <- array(exp, dim = c(dim_exp[time_dim])) if (is.null(dim(ref))) ref <- array(ref, dim = c(dim_ref[time_dim])) } @@ -232,12 +232,16 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', N.eff <- .Eno(x = obs, na.action = na.pass) ## effective degrees of freedom } - # Significance with one-sided or two-sided test for equality of dependent correlation coefficients (Steiger, 1980) + # Significance with one-sided or two-sided test for equality of dependent + # correlation coefficients (Steiger, 1980) r12 <- cor.exp r13 <- cor.ref r23 <- cor(exp, ref) R <- (1 - r12 * r12 - r13 * r13 - r23 * r23) + 2 * r12 * r13 * r23 - t <- (r12 - r13) * sqrt((N.eff - 1) * (1 + r23) / (2 * ((N.eff - 1) / (N.eff - 3)) * R + 0.25 * (r12 + r13)^2 * (1 - r23)^3)) + t <- (r12 - r13) * + sqrt((N.eff - 1) * (1 + r23) / + (2 * ((N.eff - 1) / (N.eff - 3)) * R + + 0.25 * (r12 + r13)^2 * (1 - r23)^3)) if (test.type == 'one-sided') { @@ -251,7 +255,8 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', output$p.val <- p.value } if (sign) { - output$sign <- ifelse(!is.na(p.value) & p.value <= alpha & output$diff.corr > 0, TRUE, FALSE) + output$sign <- ifelse(!is.na(p.value) & p.value <= alpha & output$diff.corr > 0, + TRUE, FALSE) } } else if (test.type == 'two-sided') { @@ -266,7 +271,8 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', output$p.val <- p.value } if (sign) { - output$sign <- ifelse(!is.na(p.value) & p.value <= alpha / 2, TRUE, FALSE) + output$sign <- ifelse(!is.na(p.value) & p.value <= alpha / 2, + TRUE, FALSE) } } else { @@ -288,7 +294,8 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', ref <- ref[!nna] output <- .diff.corr(exp = exp, obs = obs, ref = ref, method = method, - N.eff = N.eff, alpha = alpha, pval = pval, sign = sign, test.type = test.type) + N.eff = N.eff, alpha = alpha, pval = pval, sign = sign, + test.type = test.type) } else if (handle.na == 'return.na') { # Data contain NA, return NAs directly without passing to .diff.corr @@ -303,7 +310,8 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', } else { ## There is no NA output <- .diff.corr(exp = exp, obs = obs, ref = ref, method = method, - N.eff = N.eff, alpha = alpha, pval = pval, sign = sign, test.type = test.type) + N.eff = N.eff, alpha = alpha, pval = pval, sign = sign, + test.type = test.type) } return(output) diff --git a/R/EOF.R b/R/EOF.R index c5e4f19..fde52a2 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -100,7 +100,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { + if (any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## time_dim @@ -114,21 +114,21 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), if (!is.character(space_dim) | length(space_dim) != 2) { stop("Parameter 'space_dim' must be a character vector of 2.") } - if (any(!space_dim %in% names(dim(ano)))) { + if (!all(space_dim %in% names(dim(ano)))) { stop("Parameter 'space_dim' is not found in 'ano' dimension.") } ## lat if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'ano'.")) + stop("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") } if (any(lat > 90 | lat < -90)) { stop("Parameter 'lat' must contain values within the range [-90, 90].") } ## lon if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'ano'.")) + stop("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") } if (any(lon > 360 | lon < -360)) { .warning("Some 'lon' is out of the range [-360, 360].") diff --git a/R/Eno.R b/R/Eno.R index caa0b33..cb92760 100644 --- a/R/Eno.R +++ b/R/Eno.R @@ -43,7 +43,7 @@ Eno <- function(data, time_dim = 'sdate', na.action = na.pass, ncores = NULL) { dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -54,14 +54,14 @@ Eno <- function(data, time_dim = 'sdate', na.action = na.pass, ncores = NULL) { stop("Parameter 'time_dim' is not found in 'data' dimension.") } ## na.action - if (as.character(substitute(na.action)) != c("na.pass") & - as.character(substitute(na.action)) != c("na.fail")) { + if (as.character(substitute(na.action)) != "na.pass" & + as.character(substitute(na.action)) != "na.fail") { stop("Parameter 'na.action' must be a function either na.pass or na.fail.") } - if(as.character(substitute(na.action)) == c("na.fail") && anyNA(data)) { - stop(paste0("Calculation fails because NA is found in paratemter 'data', ", - "which is not accepted when ", - "parameter 'na.action' = na.fail.")) + if (as.character(substitute(na.action)) == "na.fail" && anyNA(data)) { + stop("Calculation fails because NA is found in paratemter 'data', ", + "which is not accepted when ", + "parameter 'na.action' = na.fail.") } ## ncores if (!is.null(ncores)) { diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R index ef5e693..a18e6fb 100644 --- a/R/EuroAtlanticTC.R +++ b/R/EuroAtlanticTC.R @@ -75,7 +75,7 @@ EuroAtlanticTC <- function(ano, lat, lon, ntrunc = 30, time_dim = 'sdate', if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { + if (any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## time_dim @@ -89,20 +89,20 @@ EuroAtlanticTC <- function(ano, lat, lon, ntrunc = 30, time_dim = 'sdate', if (!is.character(space_dim) | length(space_dim) != 2) { stop("Parameter 'space_dim' must be a character vector of 2.") } - if (any(!space_dim %in% names(dim(ano)))) { + if (!all(space_dim %in% names(dim(ano)))) { stop("Parameter 'space_dim' is not found in 'ano' dimension.") } ## lat and lon if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'ano'.")) + stop("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") } if (any(lat > 90 | lat < -90)) { stop("Parameter 'lat' must contain values within the range [-90, 90].") } if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'ano'.")) + stop("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") } if (all(lon >= 0)) { if (any(lon > 360 | lon < 0)) { diff --git a/R/Filter.R b/R/Filter.R index 8e77a7c..3dbd2e3 100644 --- a/R/Filter.R +++ b/R/Filter.R @@ -53,7 +53,7 @@ Filter <- function(data, freq, time_dim = 'ftime', ncores = NULL) { dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## freq @@ -102,7 +102,7 @@ Filter <- function(data, freq, time_dim = 'ftime', ncores = NULL) { for (jfreq in seq(freq - 0.5 / ndat2, freq + 0.5 / ndat2, 0.1 / (ndat2 * fac1))) { for (phase in seq(0, pi, (pi / (10 * fac2)))) { - xtest <- cos(phase + c(1:ndat) * jfreq * 2 * pi) + xtest <- cos(phase + 1:ndat * jfreq * 2 * pi) test <- lm(data[is.na(data) == FALSE] ~ xtest[ is.na(data) == FALSE])$fitted.values if (sum(test ^ 2) > maxi) { @@ -112,7 +112,7 @@ Filter <- function(data, freq, time_dim = 'ftime', ncores = NULL) { maxi <- max(sum(test ^ 2), maxi) } } - xend <- cos(endphase + c(1:ndat) * endfreq * 2 * pi) + xend <- cos(endphase + 1:ndat * endfreq * 2 * pi) data[is.na(data) == FALSE] <- data[is.na(data) == FALSE] - lm( data[is.na(data) == FALSE] ~ xend[is.na(data) == FALSE] )$fitted.values diff --git a/R/GMST.R b/R/GMST.R index 92109ea..65e21e9 100644 --- a/R/GMST.R +++ b/R/GMST.R @@ -148,13 +148,13 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va # data_lats and data_lons part2 if (dim(data_tas)[lat_dim] != length(data_lats) | dim(data_tos)[lat_dim] != length(data_lats)) { - stop(paste0("The latitude dimension of parameter 'data_tas' and 'data_tos'", - " must be the same length of parameter 'data_lats'.")) + stop("The latitude dimension of parameter 'data_tas' and 'data_tos'", + " must be the same length of parameter 'data_lats'.") } if (dim(data_tas)[lon_dim] != length(data_lons) | dim(data_tos)[lon_dim] != length(data_lons)) { - stop(paste0("The longitude dimension of parameter 'data_tas' and 'data_tos'", - " must be the same length of parameter 'data_lons'.")) + stop("The longitude dimension of parameter 'data_tas' and 'data_tos'", + " must be the same length of parameter 'data_lons'.") } # sea_value if (!is.numeric(sea_value) | length(sea_value) != 1) { @@ -167,7 +167,8 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va stop("Parameter 'mask_sea_land' must be an array with dimensions [lat_dim, lon_dim].") } else if (!identical(as.integer(dim(mask_sea_land)), c(length(data_lats), length(data_lons)))) { - stop("Parameter 'mask_sea_land' dimensions must be equal to the length of 'data_lats' and 'data_lons'.") + stop("Parameter 'mask_sea_land' dimensions must be equal to the length of ", + "'data_lats' and 'data_lons'.") } # type if (!type %in% c('dcpp', 'hist', 'obs')) { @@ -175,11 +176,11 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va } # mask if (!is.null(mask)) { - if (!is.array(mask) | !identical(names(dim(mask)), c(lat_dim,lon_dim)) | + if (!is.array(mask) | !identical(names(dim(mask)), c(lat_dim, lon_dim)) | !identical(as.integer(dim(mask)), c(length(data_lats), length(data_lons)))) { - stop(paste0("Parameter 'mask' must be NULL (no mask) or a numerical array ", - "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", - "points that have to be masked.")) + stop("Parameter 'mask' must be NULL (no mask) or a numerical array ", + "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", + "points that have to be masked.") } } # monini @@ -209,11 +210,11 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va } # indices_for_clim if (!is.null(indices_for_clim)) { - if (!class(indices_for_clim) %in% c('numeric', 'integer') - & !(is.logical(indices_for_clim) & !any(indices_for_clim))) { - stop(paste0("The parameter 'indices_for_clim' must be a numeric vector ", - "or NULL to compute the anomalies based on the whole period, ", - "or FALSE if data are already anomalies")) + if (!(is(indices_for_clim, "numeric") || is(indices_for_clim, "integer")) & + !(is.logical(indices_for_clim) & !any(indices_for_clim))) { + stop("The parameter 'indices_for_clim' must be a numeric vector ", + "or NULL to compute the anomalies based on the whole period, ", + "or FALSE if data are already anomalies") } } # year_dim @@ -235,7 +236,7 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va } } # na.rm - if (!na.rm %in% c(TRUE,FALSE)) { + if (!na.rm %in% c(TRUE, FALSE)) { stop("Parameter 'na.rm' must be TRUE or FALSE") } # ncores @@ -252,7 +253,7 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va data[mask_sea_land == sea_value] <- data_tos[mask_sea_land == sea_value] return(data) } - mask_sea_land <- s2dv::Reorder(data = mask_sea_land, order = c(lat_dim,lon_dim)) + mask_sea_land <- s2dv::Reorder(data = mask_sea_land, order = c(lat_dim, lon_dim)) data <- multiApply::Apply(data = list(data_tas, data_tos), target_dims = c(lat_dim, lon_dim), fun = mask_tas_tos, mask_sea_land = mask_sea_land, @@ -276,9 +277,9 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va londim = lon_dim, latdim = lat_dim) - if (type == 'dcpp'){ + if (type == 'dcpp') { target_dims <- c(sdate_dim, fmonth_dim) - } else if (type %in% c('hist','obs')){ + } else if (type %in% c('hist', 'obs')) { target_dims <- c(year_dim, month_dim) } diff --git a/R/GSAT.R b/R/GSAT.R index 0cde94a..c70f590 100644 --- a/R/GSAT.R +++ b/R/GSAT.R @@ -119,13 +119,13 @@ GSAT <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l stop("Parameter 'lon_dim' is not found in 'data' dimension.") } # data_lats and data_lons part2 - if (dim(data)[lat_dim] != length(data_lats)){ - stop(paste0("The latitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lats'.")) + if (dim(data)[lat_dim] != length(data_lats)) { + stop("The latitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lats'.") } - if (dim(data)[lon_dim] != length(data_lons)){ - stop(paste0("The longitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lons'.")) + if (dim(data)[lon_dim] != length(data_lons)) { + stop("The longitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lons'.") } # ncores if (!is.null(ncores)) { @@ -136,20 +136,20 @@ GSAT <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } # mask if (!is.null(mask)) { - if (is.array(mask) & identical(names(dim(mask)), c(lat_dim,lon_dim)) & + if (is.array(mask) & identical(names(dim(mask)), c(lat_dim, lon_dim)) & identical(as.integer(dim(mask)), c(length(data_lats), length(data_lons)))) { ## To mask those grid point that are missing in the observations mask <- s2dv::Reorder(data = mask, order = c(lat_dim, lon_dim)) - fun_mask <- function(data, mask){ + fun_mask <- function(data, mask) { data[mask == 0] <- NA return(data) } data <- multiApply::Apply(data = data, target_dims = c(lat_dim, lon_dim), fun = fun_mask, mask = mask, ncores = ncores)$output1 } else { - stop(paste0("Parameter 'mask' must be NULL (no mask) or a numerical array ", - "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", - "points that have to be masked.")) + stop("Parameter 'mask' must be NULL (no mask) or a numerical array ", + "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", + "points that have to be masked.") } } # monini @@ -179,11 +179,11 @@ GSAT <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } # indices_for_clim if (!is.null(indices_for_clim)) { - if (!class(indices_for_clim) %in% c('numeric', 'integer') - & !(is.logical(indices_for_clim) & !any(indices_for_clim))) { - stop(paste0("The parameter 'indices_for_clim' must be a numeric vector ", - "or NULL to compute the anomalies based on the whole period, ", - "or FALSE if data are already anomalies")) + if (!(is(indices_for_clim, "numeric") || is(indices_for_clim, "integer")) & + !(is.logical(indices_for_clim) & !any(indices_for_clim))) { + stop("The parameter 'indices_for_clim' must be a numeric vector ", + "or NULL to compute the anomalies based on the whole period, ", + "or FALSE if data are already anomalies") } } # year_dim @@ -205,7 +205,7 @@ GSAT <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } } # na.rm - if (!na.rm %in% c(TRUE,FALSE)) { + if (!na.rm %in% c(TRUE, FALSE)) { stop("Parameter 'na.rm' must be TRUE or FALSE") } @@ -214,9 +214,9 @@ GSAT <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l londim = lon_dim, latdim = lat_dim) - if (type == 'dcpp'){ + if (type == 'dcpp') { target_dims <- c(sdate_dim, fmonth_dim) - } else if (type %in% c('hist','obs')){ + } else if (type %in% c('hist', 'obs')) { target_dims <- c(year_dim, month_dim) } diff --git a/R/GetProbs.R b/R/GetProbs.R index 1ca34d8..8a56007 100644 --- a/R/GetProbs.R +++ b/R/GetProbs.R @@ -121,7 +121,7 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', } ## indices_for_quantiles if (is.null(indices_for_quantiles)) { - indices_for_quantiles <- 1:dim(data)[time_dim] + indices_for_quantiles <- seq_len(dim(data)[time_dim]) } else { if (!is.numeric(indices_for_quantiles) | !is.vector(indices_for_quantiles)) { stop("Parameter 'indices_for_quantiles' must be NULL or a numeric vector.") @@ -146,7 +146,7 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', stop("Parameter abs_thresholds' cannot have member dimension.") } dim_name_abs <- names(dim(abs_thresholds))[which(names(dim(abs_thresholds)) != bin_dim_abs)] - if (any(!dim_name_abs %in% names(dim(data)))) { + if (!all(dim_name_abs %in% names(dim(data)))) { stop("Parameter 'abs_thresholds' dimensions except 'bin_dim_abs' must be in 'data' as well.") } else { if (any(dim(abs_thresholds)[dim_name_abs] != dim(data)[dim_name_abs])) { @@ -177,19 +177,21 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', namesdim_weights <- c(time_dim) } if (length(dim(weights)) != lendim_weights | - any(!names(dim(weights)) %in% namesdim_weights)) { - stop(paste0("Parameter 'weights' must have dimension ", - paste0(namesdim_weights, collapse = ' and '), ".")) + !all(names(dim(weights)) %in% namesdim_weights)) { + stop("Parameter 'weights' must have dimension ", + paste0(namesdim_weights, collapse = ' and '), ".") } if (any(dim(weights)[namesdim_weights] != dim(data)[namesdim_weights])) { - stop(paste0("Parameter 'weights' must have the same dimension length as ", - paste0(namesdim_weights, collapse = ' and '), " dimension in 'data'.")) + stop("Parameter 'weights' must have the same dimension length as ", + paste0(namesdim_weights, collapse = ' and '), " dimension in 'data'.") } weights <- Reorder(weights, namesdim_weights) # } else { -# if (length(dim(weights)) != 3 | any(!names(dim(weights)) %in% c(memb_dim, time_dim, dat_dim))) -# stop("Parameter 'weights' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") +# if (length(dim(weights)) != 3 | +# any(!names(dim(weights)) %in% c(memb_dim, time_dim, dat_dim))) +# stop("Parameter 'weights' must have three dimensions with the names of ", +# "'memb_dim', 'time_dim' and 'dat_dim'.") # if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | # dim(weights)[time_dim] != dim(exp)[time_dim] | # dim(weights)[dat_dim] != dim(exp)[dat_dim]) { @@ -253,17 +255,22 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', if (is.null(abs_thresholds)) { if (cross.val) { quantiles <- array(NA, dim = c(bin = length(prob_thresholds), sdate = dim(data)[1])) - for (i_time in 1:dim(data)[1]) { + for (i_time in seq_len(dim(data)[1])) { if (is.null(weights)) { - quantiles[, i_time] <- quantile(x = as.vector(data[indices_for_quantiles[which(indices_for_quantiles != i_time)], ]), - probs = prob_thresholds, type = 8, na.rm = TRUE) + tmp <- which(indices_for_quantiles != i_time) + quantiles[, i_time] <- + quantile(x = as.vector(data[indices_for_quantiles[tmp], ]), + probs = prob_thresholds, type = 8, na.rm = TRUE) } else { # weights: [sdate, memb] - sorted_arrays <- .sorted_distributions(data[indices_for_quantiles[which(indices_for_quantiles != i_time)], ], - weights[indices_for_quantiles[which(indices_for_quantiles != i_time)], ]) + tmp <- which(indices_for_quantiles != i_time) + sorted_arrays <- + .sorted_distributions(data[indices_for_quantiles[tmp], ], + weights[indices_for_quantiles[tmp], ]) sorted_data <- sorted_arrays$data cumulative_weights <- sorted_arrays$cumulative_weights - quantiles[, i_time] <- approx(cumulative_weights, sorted_data, prob_thresholds, "linear")$y + quantiles[, i_time] <- approx(cumulative_weights, sorted_data, + prob_thresholds, "linear")$y } } @@ -294,7 +301,7 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', # Probabilities probs <- array(dim = c(dim(quantiles)[1] + 1, dim(data)[1])) # [bin, sdate] - for (i_time in 1:dim(data)[1]) { + for (i_time in seq_len(dim(data)[1])) { if (anyNA(data[i_time, ])) { probs[, i_time] <- rep(NA, dim = dim(quantiles)[1] + 1) } else { @@ -307,7 +314,7 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', cumulative_weights <- sorted_arrays$cumulative_weights # find any quantiles that are outside the data range integrated_probs <- array(dim = dim(quantiles)) - for (i_quant in 1:dim(quantiles)[1]) { + for (i_quant in seq_len(dim(quantiles)[1])) { # for thresholds falling under the distribution if (quantiles[i_quant, i_time] < min(sorted_data)) { integrated_probs[i_quant, i_time] <- 0 @@ -319,9 +326,10 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', quantiles[i_quant, i_time], "linear")$y } } - probs[, i_time] <- append(integrated_probs[, i_time], 1) - append(0, integrated_probs[, i_time]) + probs[, i_time] <- append(integrated_probs[, i_time], 1) - + append(0, integrated_probs[, i_time]) if (min(probs[, i_time]) < 0 | max(probs[, i_time]) > 1) { - stop(paste0("Probability in i_time = ", i_time, " is out of [0, 1].")) + stop("Probability in i_time = ", i_time, " is out of [0, 1].") } } } @@ -338,7 +346,8 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', sorted_weights <- weights_vector[sorter] cumulative_weights <- cumsum(sorted_weights) - 0.5 * sorted_weights cumulative_weights <- cumulative_weights - cumulative_weights[1] # fix the 0 - cumulative_weights <- cumulative_weights / cumulative_weights[length(cumulative_weights)] # fix the 1 + cumulative_weights <- cumulative_weights / + cumulative_weights[length(cumulative_weights)] # fix the 1 return(list("data" = data_vector[sorter], "cumulative_weights" = cumulative_weights)) } diff --git a/R/Histo2Hindcast.R b/R/Histo2Hindcast.R index f910a9a..95112f7 100644 --- a/R/Histo2Hindcast.R +++ b/R/Histo2Hindcast.R @@ -67,22 +67,22 @@ Histo2Hindcast <- function(data, sdatesin, sdatesout, nleadtimesout, stop("Parameter 'sdatesin' cannot be NULL.") } if (!is.character(sdatesin) || length(sdatesin) > 1) { - stop(paste0("Parameter 'sdatesin' must be a character string in the format", - " 'YYYYMMDD' or 'YYYYMM'.")) + stop("Parameter 'sdatesin' must be a character string in the format", + " 'YYYYMMDD' or 'YYYYMM'.") } else if (!nchar(sdatesin) %in% c(6, 8) | is.na(as.numeric(sdatesin))) { - stop(paste0("Parameter 'sdatesin' must be a character string in the format", - " 'YYYYMMDD' or 'YYYYMM'.")) + stop("Parameter 'sdatesin' must be a character string in the format", + " 'YYYYMMDD' or 'YYYYMM'.") } # sdatesout if (is.null(sdatesout)) { stop("Parameter 'sdatesout' cannot be NULL.") } if (!is.character(sdatesout) | !is.vector(sdatesout)) { - stop(paste0("Parameter 'sdatesout' must be a vector of character in the ", - "format 'YYYYMMDD' or 'YYYYMM'.")) + stop("Parameter 'sdatesout' must be a vector of character in the ", + "format 'YYYYMMDD' or 'YYYYMM'.") } else if (!all(nchar(sdatesout) %in% c(6, 8)) | anyNA(as.numeric(sdatesin))) { - stop(paste0("Parameter 'sdatesout' must be a vector of character in the ", - "format 'YYYYMMDD' or 'YYYYMM'.")) + stop("Parameter 'sdatesout' must be a vector of character in the ", + "format 'YYYYMMDD' or 'YYYYMM'.") } # nleadtimesout if (is.null(nleadtimesout)) { @@ -122,13 +122,13 @@ Histo2Hindcast <- function(data, sdatesin, sdatesout, nleadtimesout, yrout <- as.numeric(substr(sdatesout, 1, 4)) mthin <- as.numeric(substr(sdatesin, 5, 6)) if (mthin > 12) { - stop(paste0("Parameter 'sdatesin' must be in the format 'YYYYMMDD' or ", - "'YYYYMM'. Found the month is over 12.")) + stop("Parameter 'sdatesin' must be in the format 'YYYYMMDD' or ", + "'YYYYMM'. Found the month is over 12.") } mthout <- as.numeric(substr(sdatesout, 5, 6)) if (any(mthout > 12)) { - stop(paste0("Parameter 'sdatesout' must be a vector of character in the ", - "format 'YYYYMMDD' or 'YYYYMM'. Found certain month is over 12.")) + stop("Parameter 'sdatesout' must be a vector of character in the ", + "format 'YYYYMMDD' or 'YYYYMM'. Found certain month is over 12.") } res <- Apply(data, @@ -144,16 +144,16 @@ Histo2Hindcast <- function(data, sdatesin, sdatesout, nleadtimesout, } -.Histo2Hindcast <- function(data, yrin = yrin, yrout = yrout, mthin = mthin, mthout = mthout, nleadtimesout) { +.Histo2Hindcast <- function(data, yrin, yrout, mthin, mthout, nleadtimesout) { # data: [sdate = 1, ftime] res <- array(dim = c(sdate = length(yrout), ftime = nleadtimesout)) diff_mth <- (yrout - yrin) * 12 + (mthout - mthin) - for (i in 1:length(diff_mth)) { + for (i in seq_along(diff_mth)) { if (diff_mth[i] < dim(data)[2]) { ftime_ind <- max(1 + diff_mth[i], 1):min(nleadtimesout + diff_mth[i], dim(data)[2]) - res[i, 1:length(ftime_ind)] <- data[1, ftime_ind] + res[i, seq_along(ftime_ind)] <- data[1, ftime_ind] } } diff --git a/R/MSE.R b/R/MSE.R index 781e47a..5c502ba 100644 --- a/R/MSE.R +++ b/R/MSE.R @@ -10,7 +10,8 @@ #'all leadtimes.\cr #'The confidence interval is computed by the chi2 distribution.\cr #' -#'@param exp A named numeric array of experimental data, with at least #' 'time_dim' dimension. It can also be a vector with the same length as 'obs'. +#'@param exp A named numeric array of experimental data, with at least +#' 'time_dim' dimension. It can also be a vector with the same length as 'obs'. #'@param obs A named numeric array of observational data, same dimensions as #' parameter 'exp' except along 'dat_dim' and 'memb_dim'. It can also be a #' vector with the same length as 'exp'. @@ -91,15 +92,15 @@ MSE <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, memb_dim = NULL, obs <- array(obs, dim = c(length(obs))) names(dim(obs)) <- c(time_dim) } else { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } } else if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim @@ -144,8 +145,8 @@ MSE <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, memb_dim = NULL, } if (!is.numeric(limits) | any(limits %% 1 != 0) | any(limits < 0) | length(limits) != 2 | any(limits > dim(exp)[comp_dim])) { - stop(paste0("Parameter 'limits' must be a vector of two positive ", - "integers smaller than the length of paramter 'comp_dim'.")) + stop("Parameter 'limits' must be a vector of two positive ", + "integers smaller than the length of paramter 'comp_dim'.") } } ## conf @@ -182,8 +183,8 @@ MSE <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, memb_dim = NULL, stop("Parameter 'exp' and 'obs' must have the same dimension names.") } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'dat_dim' and 'memb_dim'.") } if (dim(exp)[time_dim] < 2) { stop("The length of time_dim must be at least 2 to compute MSE.") @@ -261,7 +262,9 @@ MSE <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, memb_dim = NULL, # dif for (i in 1:nobs) { - dif[, , i] <- sapply(1:nexp, function(x) {exp[, x] - obs[, i]}) + dif[, , i] <- sapply(1:nexp, function(x) { + exp[, x] - obs[, i] + }) } mse <- colMeans(dif^2, na.rm = TRUE) # array(dim = c(nexp, nobs)) diff --git a/R/MSSS.R b/R/MSSS.R index 2858add..f97d91f 100644 --- a/R/MSSS.R +++ b/R/MSSS.R @@ -105,12 +105,12 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, obs <- array(obs, dim = c(length(obs))) names(dim(obs)) <- c(time_dim) } else { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } } else if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { @@ -124,7 +124,7 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } - } else if (length(ref) != 1 | any(!ref %in% c(0, 1))) { + } else if (length(ref) != 1 | !all(ref %in% c(0, 1))) { stop("Parameter 'ref' must be a numeric array or number 0 or 1.") } } else { @@ -184,7 +184,8 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, sig_method.type <- "two.sided" } if (!any(sig_method.type %in% c('two.sided.approx', 'two.sided', 'greater', 'less'))) { - stop("Parameter 'sig_method.type' must be a method accepted by RandomWalkTest() parameter 'test.type'.") + stop("Parameter 'sig_method.type' must be a method accepted by RandomWalkTest() ", + "parameter 'test.type'.") } if (sig_method.type == 'two.sided.approx' & pval == T) { .warning("p-value cannot be calculated by Random Walk 'two.sided.approx' method.") @@ -221,8 +222,8 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, stop("Parameter 'exp' and 'obs' must have the same dimension names.") } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'dat_dim' and 'memb_dim'.") } name_ref <- sort(names(dim(ref))) @@ -232,17 +233,17 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, if (!is.null(dat_dim)) { if (dat_dim %in% name_ref) { if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { - stop(paste0("If parameter 'ref' has dataset dimension, it must be ", - "equal to dataset dimension of 'exp'.")) + stop("If parameter 'ref' has dataset dimension, it must be ", + "equal to dataset dimension of 'exp'.") } name_ref <- name_ref[-which(name_ref == dat_dim)] } } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", - "all dimensions except 'memb_dim' and 'dat_dim' if there is ", - "only one reference dataset.")) + stop("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.") } if (dim(exp)[time_dim] <= 2) { @@ -343,7 +344,9 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, names(dim(dif1)) <- c(time_dim, 'nexp', 'nobs') for (i in 1:nobs) { - dif1[, , i] <- sapply(1:nexp, function(x) {exp[, x] - obs[, i]}) + dif1[, , i] <- sapply(1:nexp, function(x) { + exp[, x] - obs[, i] + }) } mse_exp <- colMeans(dif1^2, na.rm = TRUE) # [nexp, nobs] @@ -352,7 +355,9 @@ MSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, dif2 <- array(dim = c(nsdate, nref, nobs)) names(dim(dif2)) <- c(time_dim, 'nexp', 'nobs') for (i in 1:nobs) { - dif2[, , i] <- sapply(1:nref, function(x) {ref[, x] - obs[, i]}) + dif2[, , i] <- sapply(1:nref, function(x) { + ref[, x] - obs[, i] + }) } mse_ref <- colMeans(dif2^2, na.rm = TRUE) # [nref, nobs] if (nexp != nref) { diff --git a/R/MeanDims.R b/R/MeanDims.R index 56a304d..588f514 100644 --- a/R/MeanDims.R +++ b/R/MeanDims.R @@ -80,7 +80,7 @@ MeanDims <- function(data, dims, na.rm = FALSE, drop = TRUE) { if (is.character(dims)) { dims <- which(names(dim_data) %in% dims) } - data <- aperm(data, c(dims, (1:length(dim_data))[-dims])) + data <- aperm(data, c(dims, (seq_along(dim_data))[-dims])) data <- colMeans(data, dims = length(dims), na.rm = na.rm) # If data is vector diff --git a/R/NAO.R b/R/NAO.R index 28c04f4..6cb4976 100644 --- a/R/NAO.R +++ b/R/NAO.R @@ -99,10 +99,10 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', stop("Parameter 'exp' must be a numeric array.") } if (is.null(dim(exp))) { - stop(paste0("Parameter 'exp' must have at least dimensions ", - "time_dim, memb_dim, space_dim, and ftime_dim.")) + stop("Parameter 'exp' must have at least dimensions ", + "time_dim, memb_dim, space_dim, and ftime_dim.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0)) { stop("Parameter 'exp' must have dimension names.") } } @@ -111,10 +111,10 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', stop("Parameter 'obs' must be a numeric array.") } if (is.null(dim(obs))) { - stop(paste0("Parameter 'obs' must have at least dimensions ", - "time_dim, space_dim, and ftime_dim.")) + stop("Parameter 'obs' must have at least dimensions ", + "time_dim, space_dim, and ftime_dim.") } - if(any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'obs' must have dimension names.") } } @@ -158,12 +158,12 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', stop("Parameter 'space_dim' must be a character vector of 2.") } if (!is.null(exp)) { - if (any(!space_dim %in% names(dim(exp)))) { + if (!all(space_dim %in% names(dim(exp)))) { stop("Parameter 'space_dim' is not found in 'exp' or 'obs' dimension.") } } if (!is.null(obs)) { - if (any(!space_dim %in% names(dim(obs)))) { + if (!all(space_dim %in% names(dim(obs)))) { stop("Parameter 'space_dim' is not found in 'exp' or 'obs' dimension.") } } @@ -191,12 +191,12 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', throw_error <- TRUE } else if (any(name_exp != name_obs)) { throw_error <- TRUE - } else if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + } else if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { throw_error <- TRUE } if (throw_error) { - stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions except 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions except 'memb_dim'.") } } ## ftime_avg @@ -227,21 +227,21 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', ## lat and lon if (!is.null(exp)) { if (!is.numeric(lat) | length(lat) != dim(exp)[space_dim[1]]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'exp' and 'obs'.")) + stop("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'exp' and 'obs'.") } if (!is.numeric(lon) | length(lon) != dim(exp)[space_dim[2]]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'exp' and 'obs'.")) + stop("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'exp' and 'obs'.") } } else { if (!is.numeric(lat) | length(lat) != dim(obs)[space_dim[1]]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'exp' and 'obs'.")) + stop("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'exp' and 'obs'.") } if (!is.numeric(lon) | length(lon) != dim(obs)[space_dim[2]]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'exp' and 'obs'.")) + stop("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'exp' and 'obs'.") } } stop_needed <- FALSE @@ -268,8 +268,8 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', } } if (stop_needed) { - stop(paste0("The typical domain used to compute the NAO is 20N-80N, ", - "80W-40E. 'lat' or 'lon' is out of range.")) + stop("The typical domain used to compute the NAO is 20N-80N, ", + "80W-40E. 'lat' or 'lon' is out of range.") } ## obsproj if (!is.logical(obsproj) | length(obsproj) > 1) { @@ -363,7 +363,7 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', if (!is.null(obs)) { ## Calculate observation EOF. Excluding one forecast start year. - obs_sub <- obs[c(1:ntime)[-tt], , , drop = FALSE] + obs_sub <- obs[(1:ntime)[-tt], , , drop = FALSE] obs_EOF <- .EOF(obs_sub, neofs = 1, wght = wght) # $EOFs: [mode, lat, lon] ## Correct polarity of pattern. @@ -380,7 +380,7 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', if (!is.null(exp)) { if (!obsproj) { - exp_sub <- exp[, c(1:ntime)[-tt], , , drop = FALSE] + exp_sub <- exp[, (1:ntime)[-tt], , , drop = FALSE] # Combine 'memb' and 'sdate' to calculate EOF dim(exp_sub) <- c(nmemb_exp * (ntime - 1), nlat, nlon) exp_EOF <- .EOF(exp_sub, neofs = 1, wght = wght) # $EOFs: [mode, lat, lon] @@ -397,13 +397,17 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', ### ProjectField() only on the year of interest... (though this is ### not vital). Lauriane for (imemb in 1:nmemb_exp) { - PF <- .ProjectField(exp[imemb, , , ], eof_mode = exp_EOF$EOFs[1, , ], wght = wght) # [sdate, memb] + PF <- .ProjectField(exp[imemb, , , ], + eof_mode = exp_EOF$EOFs[1, , ], + wght = wght) # [sdate, memb] NAOF.ver[tt, imemb] <- PF[tt] } } else { ## Project forecast anomalies on obs EOF for (imemb in 1:nmemb_exp) { - PF <- .ProjectField(exp[imemb, , , ], eof_mode = obs_EOF$EOFs[1, , ], wght = wght) # [sdate] + PF <- .ProjectField(exp[imemb, , , ], + eof_mode = obs_EOF$EOFs[1, , ], + wght = wght) # [sdate] NAOF.ver[tt, imemb] <- PF[tt] } } diff --git a/R/Persistence.R b/R/Persistence.R index 9895f47..b822c8c 100644 --- a/R/Persistence.R +++ b/R/Persistence.R @@ -10,8 +10,6 @@ #' 'start'. #'@param dates A sequence of 4-digit integers (YYYY) or string (YYYY-MM-DD) #' in class 'Date' indicating the dates available in the observations. -#'@param time_dim A character string indicating the dimension along which to -#' compute the autoregression. The default value is 'time'. #'@param start A 4-digit integer (YYYY) or a string (YYYY-MM-DD) in class 'Date' #' indicating the first start date of the persistence forecast. It must be #' between 1850 and 2020. @@ -25,6 +23,8 @@ #' average forecast times for which persistence should be calculated in the #' case of a multi-timestep average persistence. The default value is #' 'ft_start'. +#'@param time_dim A character string indicating the dimension along which to +#' compute the autoregression. The default value is 'time'. #'@param max_ft An integer indicating the maximum forecast time possible for #' 'data'. For example, for decadal prediction 'max_ft' would correspond to 10 #' (years). The default value is 10. @@ -90,8 +90,8 @@ #' #'@import multiApply #'@export -Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, - ft_end = ft_start, max_ft = 10, nmemb = 1, na.action = 10, +Persistence <- function(data, dates, start, end, ft_start, ft_end = ft_start, + time_dim = 'time', max_ft = 10, nmemb = 1, na.action = 10, ncores = NULL) { # Check inputs @@ -106,7 +106,7 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -119,76 +119,76 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, ## dates if (is.numeric(dates)) { #(YYYY) if (any(nchar(dates) != 4) | any(dates %% 1 != 0) | any(dates <= 0)) { - stop(paste0("Parameter 'dates' must be a sequence of integer (YYYY) or ", - "string (YYYY-MM-DD) in class 'Date'.")) + stop("Parameter 'dates' must be a sequence of integer (YYYY) or ", + "string (YYYY-MM-DD) in class 'Date'.") } } else if (inherits(dates, 'Date')) { #(YYYY-MM-DD) } else { - stop(paste0("Parameter 'dates' must be a sequence of integer (YYYY) or ", - "string (YYYY-MM-DD) in class 'Date'.")) + stop("Parameter 'dates' must be a sequence of integer (YYYY) or ", + "string (YYYY-MM-DD) in class 'Date'.") } if (length(dates) != dim(data)[time_dim]) { stop("Parameter 'dates' must have the same length as in 'time_dim'.") } ## dates, start, and end - if (!all(sapply(list(class(dates), class(start)), function(x) x == class(end)))) { + if (!all(sapply(list(dates, start), function(x) is(x, class(end))))) { stop("Parameter 'dates', 'start', and 'end' should be the same format.") } ## start if (is.numeric(start)) { #(YYYY) if (length(start) > 1 | any(start %% 1 != 0) | any(start < 1850) | any(start > 2020)) { - stop(paste0("Parameter 'start' must be an integer or a string in class ", - "'Date' between 1850 and 2020.")) + stop("Parameter 'start' must be an integer or a string in class ", + "'Date' between 1850 and 2020.") } if (is.na(match(start, dates))) { stop("Parameter 'start' must be one of the values of 'dates'.") } if (start < dates[1] + 40) { - stop(paste0("Parameter 'start' must start at least 40 time steps after ", - "the first 'dates'.")) + stop("Parameter 'start' must start at least 40 time steps after ", + "the first 'dates'.") } } else if (inherits(start, 'Date')) { if (length(start) > 1 | any(start < as.Date(ISOdate(1850, 1, 1))) | any(start > as.Date(ISOdate(2021, 1, 1)))) { - stop(paste0("Parameter 'start' must be an integer or a string in class ", - "'Date' between 1850 and 2020.")) + stop("Parameter 'start' must be an integer or a string in class ", + "'Date' between 1850 and 2020.") } if (is.na(match(start, dates))) { stop("Parameter 'start' must be one of the values of 'dates'.") } if (start < dates[1] + 40) { - stop(paste0("Parameter 'start' must start at least 40 time steps after ", - "the first 'dates'.")) + stop("Parameter 'start' must start at least 40 time steps after ", + "the first 'dates'.") } } else { - stop(paste0("Parameter 'start' must be an integer or a string in class ", - "'Date' between 1850 and 2020.")) + stop("Parameter 'start' must be an integer or a string in class ", + "'Date' between 1850 and 2020.") } ## end if (is.numeric(end)) { #(YYYY) if (length(end) > 1 | any(end %% 1 != 0) | any(end < 1850) | any(end > 2020)) { - stop(paste0("Parameter 'end' must be an integer or a string in class ", - "'Date' between 1850 and 2020.")) + stop("Parameter 'end' must be an integer or a string in class ", + "'Date' between 1850 and 2020.") } if (end > dates[length(dates)] + 1) { - stop(paste0("Parameter 'end' must end at most 1 time steps after ", - "the last 'dates'.")) + stop("Parameter 'end' must end at most 1 time steps after ", + "the last 'dates'.") } } else if (inherits(end, 'Date')) { if (length(end) > 1 | any(end < as.Date(ISOdate(1850, 1, 1))) | any(end > as.Date(ISOdate(2020, 12, 31)))) { - stop(paste0("Parameter 'end' must be an integer or a string in class ", - "'Date' between 1850 and 2020.")) + stop("Parameter 'end' must be an integer or a string in class ", + "'Date' between 1850 and 2020.") } if (end > dates[length(dates)] + 1) { - stop(paste0("Parameter 'end' must end at most 1 time steps after ", - "the last 'dates'.")) + stop("Parameter 'end' must end at most 1 time steps after ", + "the last 'dates'.") } } else { - stop(paste0("Parameter 'end' must be an integer or a string in class ", - "'Date' between 1850 and 2020.")) + stop("Parameter 'end' must be an integer or a string in class ", + "'Date' between 1850 and 2020.") } ## ft_start if (!is.numeric(ft_start) | ft_start %% 1 != 0 | ft_start < 0 | @@ -212,15 +212,15 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, } ## na.action if (!is.function(na.action) & !is.numeric(na.action)) { - stop(paste0("Parameter 'na.action' must be a function for NA values or ", - "a numeric indicating the number of NA values allowed ", - "before returning NA.")) + stop("Parameter 'na.action' must be a function for NA values or ", + "a numeric indicating the number of NA values allowed ", + "before returning NA.") } if (is.numeric(na.action)) { if (any(na.action %% 1 != 0) | any(na.action < 0) | length(na.action) > 1) { - stop(paste0("Parameter 'na.action' must be a function for NA values or ", - "a numeric indicating the number of NA values allowed ", - "before returning NA.")) + stop("Parameter 'na.action' must be a function for NA values or ", + "a numeric indicating the number of NA values allowed ", + "before returning NA.") } } ## ncores @@ -233,8 +233,6 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, ############################### # Calculate Persistence - dim_names <- names(dim(data)) - output <- Apply(list(data), target_dims = time_dim, @@ -256,8 +254,8 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, # x could be a vector timeseries # start/end is a year (4-digit numeric) or a date (ISOdate) # ft_start/ft_end are indices -.Persistence <- function(x, dates, time_dim = 'time', start, end, ft_start = 1, - ft_end = 1, max_ft = 10, nmemb = 1, na.action = 10) { +.Persistence <- function(x, dates, start, end, ft_start = 1, ft_end = 1, + time_dim = 'time', max_ft = 10, nmemb = 1, na.action = 10) { tm <- end - start + 1 max_date <- match(start, dates) interval <- ft_end - ft_start @@ -272,11 +270,9 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, min_x = max_ft # for extreme case: ex. forecast years 1-10, interval = 9 max_x = max_date + sdate - 2 - ft_start - regdates = max_y - min_y + 1 - for (val_x in min_x:max_x) { tmp_x <- mean(x[(val_x - interval):val_x]) - if (val_x == min_x){ + if (val_x == min_x) { obs_x <- tmp_x } else { obs_x <- c(obs_x, tmp_x) @@ -307,7 +303,7 @@ Persistence <- function(data, dates, time_dim = 'time', start, end, ft_start, AR.intercept[sdate] <- b AR.lowCI[sdate] <- reg$conf.lower[2] AR.highCI[sdate] <- reg$conf.upper[2] - persistence[ , sdate] <- rnorm(n = nmemb, mean = persistence.mean[sdate], + persistence[, sdate] <- rnorm(n = nmemb, mean = persistence.mean[sdate], sd = persistence.predint[sdate]) } diff --git a/R/ProbBins.R b/R/ProbBins.R index da7b7a7..444ef28 100644 --- a/R/ProbBins.R +++ b/R/ProbBins.R @@ -71,7 +71,7 @@ ProbBins <- function(data, thr, fcyr = 'all', time_dim = 'sdate', memb_dim = 'me # dim(data) <- c(length(data)) # names(dim(data)) <- time_dim # } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## thr @@ -104,19 +104,21 @@ ProbBins <- function(data, thr, fcyr = 'all', time_dim = 'sdate', memb_dim = 'me if (!is.numeric(fcyr) | !is.vector(fcyr)) { stop("Parameter 'fcyr' must be a numeric vector or 'all'.") } else if (any(fcyr %% 1 != 0) | min(fcyr) < 1 | max(fcyr) > dim(data)[time_dim]) { - stop(paste0("Parameter 'fcyr' must be the indices of 'time_dim' within ", - "the range [1, ", dim(data)[time_dim], "].")) + stop("Parameter 'fcyr' must be the indices of 'time_dim' within ", + "the range [1, ", dim(data)[time_dim], "].") } } else { - fcyr <- 1:dim(data)[time_dim] + fcyr <- seq_len(dim(data)[time_dim]) } ## quantile if (!is.logical(quantile) | length(quantile) > 1) { stop("Parameter 'quantile' must be one logical value.") } ## compPeriod - if (length(compPeriod) != 1 | any(!compPeriod %in% c('Full period', 'Without fcyr', 'Cross-validation'))) { - stop("Parameter 'compPeriod' must be either 'Full period', 'Without fcyr', or 'Cross-validation'.") + if (length(compPeriod) != 1 | + !all(compPeriod %in% c('Full period', 'Without fcyr', 'Cross-validation'))) { + stop("Parameter 'compPeriod' must be either 'Full period', 'Without fcyr', ", + "or 'Cross-validation'.") } ## ncores if (!is.null(ncores)) { @@ -140,7 +142,8 @@ ProbBins <- function(data, thr, fcyr = 'all', time_dim = 'sdate', memb_dim = 'me return(res) } -.ProbBins <- function(data, thr = thr, fcyr = 'all', quantile, compPeriod = "Full period") { +.ProbBins <- function(data, thr, fcyr = 'all', quantile = TRUE, + compPeriod = "Full period") { # data: [sdate, member] diff --git a/R/ProjectField.R b/R/ProjectField.R index 236dde1..9a10095 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -71,7 +71,7 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { + if (any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## eof (1) @@ -88,12 +88,12 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon } else if ('patterns' %in% names(eof)) { EOFs <- "patterns" } else { - stop(paste0("Parameter 'eof' must be a list that contains 'EOFs', 'REOFs', ", - "or 'patterns'. It can be generated by EOF(), REOF(), or EuroAtlanticTC().")) + stop("Parameter 'eof' must be a list that contains 'EOFs', 'REOFs', ", + "or 'patterns'. It can be generated by EOF(), REOF(), or EuroAtlanticTC().") } if (!'wght' %in% names(eof)) { - stop(paste0("Parameter 'eof' must be a list that contains 'wght'. ", - "It can be generated by EOF() or REOF().")) + stop("Parameter 'eof' must be a list that contains 'wght'. ", + "It can be generated by EOF() or REOF().") } if (!is.numeric(eof[[EOFs]]) || !is.array(eof[[EOFs]])) { stop("The component 'EOFs' or 'REOFs' of parameter 'eof' must be a numeric array.") @@ -112,7 +112,7 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon if (!is.character(space_dim) | length(space_dim) != 2) { stop("Parameter 'space_dim' must be a character vector of 2.") } - if (any(!space_dim %in% names(dim(ano)))) { + if (!all(space_dim %in% names(dim(ano)))) { stop("Parameter 'space_dim' is not found in 'ano' dimension.") } ## ano (2) @@ -127,8 +127,8 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon "with dimensions named as parameter 'space_dim' and 'mode'.")) } if (length(dim(eof$wght)) != 2 | !all(names(dim(eof$wght)) %in% space_dim)) { - stop(paste0("The component 'wght' of parameter 'eof' must be an array ", - "with dimensions named as parameter 'space_dim'.")) + stop("The component 'wght' of parameter 'eof' must be an array ", + "with dimensions named as parameter 'space_dim'.") } ## mode if (!is.null(mode)) { @@ -136,8 +136,8 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon stop("Parameter 'mode' must be NULL or a positive integer.") } if (mode > dim(eof[[EOFs]])['mode']) { - stop(paste0("Parameter 'mode' is greater than the number of available ", - "modes in 'eof'.")) + stop("Parameter 'mode' is greater than the number of available ", + "modes in 'eof'.") } } ## ncores @@ -182,15 +182,15 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon } else { if (!all(dimnames_without_mode %in% names(dim(ano)))) { - stop(paste0("The array 'EOF' in parameter 'eof' has dimension not in parameter ", - "'ano'. Check if 'ano' and 'eof' are compatible.")) + stop("The array 'EOF' in parameter 'eof' has dimension not in parameter ", + "'ano'. Check if 'ano' and 'eof' are compatible.") } common_dim_ano <- dim(ano)[which(names(dim(ano)) %in% dimnames_without_mode)] if (any(common_dim_ano[match(dimnames_without_mode, names(common_dim_ano))] != dim(eof_mode)[dimnames_without_mode])) { - stop(paste0("Found paramter 'ano' and 'EOF' in parameter 'eof' have common dimensions ", - "with different length. Check if 'ano' and 'eof' are compatible.")) + stop("Found paramter 'ano' and 'EOF' in parameter 'eof' have common dimensions ", + "with different length. Check if 'ano' and 'eof' are compatible.") } # Enlarge eof/ano is needed. The margin_dims of Apply() must be consistent @@ -198,7 +198,7 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon additional_dims <- dim(ano)[-which(names(dim(ano)) %in% names(dim(eof_mode)))] additional_dims <- additional_dims[-which(names(additional_dims) == time_dim)] if (length(additional_dims) != 0) { - for (i in 1:length(additional_dims)) { + for (i in seq_along(additional_dims)) { eof_mode <- InsertDim(eof_mode, posdim = (length(dim(eof_mode)) + 1), lendim = additional_dims[i], name = names(additional_dims)[i]) } diff --git a/R/REOF.R b/R/REOF.R index e0a30b5..1135332 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -85,7 +85,7 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', if (!is.numeric(ano)) { stop("Parameter 'ano' must be a numeric array.") } - if(any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { + if (any(is.null(names(dim(ano)))) | any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } ## time_dim @@ -99,21 +99,21 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', if (!is.character(space_dim) | length(space_dim) != 2) { stop("Parameter 'space_dim' must be a character vector of 2.") } - if (any(!space_dim %in% names(dim(ano)))) { + if (!all(space_dim %in% names(dim(ano)))) { stop("Parameter 'space_dim' is not found in 'ano' dimension.") } ## lat if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'ano'.")) + stop("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") } if (any(lat > 90 | lat < -90)) { stop("Parameter 'lat' must contain values within the range [-90, 90].") } ## lon if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'ano'.")) + stop("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") } if (all(lon >= 0)) { if (any(lon > 360 | lon < 0)) { @@ -180,12 +180,12 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', # ano: [sdate, lat, lon] # Dimensions - nt <- dim(ano)[1] ny <- dim(ano)[2] nx <- dim(ano)[3] # Get the first ntrunc EOFs: - eofs <- .EOF(ano = ano, neofs = ntrunc, corr = corr, wght = wght) #list(EOFs = EOF, PCs = PC, var = var.eof, mask = mask) + eofs <- .EOF(ano = ano, neofs = ntrunc, corr = corr, wght = wght) + #list(EOFs = EOF, PCs = PC, var = var.eof, mask = mask) # Recover loadings (with norm 1), weight the EOFs by the weigths # eofs$EOFs: [mode, lat, lon] @@ -211,13 +211,17 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', RPCs <- t(ano.wght) %*% varim_loadings # [sdate, mode] ## Alternative methods suggested here: - ## https://stats.stackexchange.com/questions/59213/how-to-compute-varimax-rotated-principal-components-in-r/137003#137003 - ## gives same results as pinv is just transpose in this case, as loadings are ortonormal! - # invLoadings <- t(pracma::pinv(varim$loadings)) ## invert and traspose the rotated loadings. pinv uses a SVD again (!) + ##https://stats.stackexchange.com/questions/59213/ + ##how-to-compute-varimax-rotated-principal-components-in-r/137003#137003 + ##gives same results as pinv is just transpose in this case, as loadings are ortonormal! + # invLoadings <- t(pracma::pinv(varim$loadings)) + ## invert and traspose the rotated loadings. pinv uses a SVD again (!) # RPCs <- ano.wght %*% invLoadings # Compute explained variance fraction: - var <- apply(RPCs, 2, function(x) { sum(x * x) } ) * 100 / eofs$tot_var # [mode] + var <- apply(RPCs, 2, function(x) { + sum(x * x) + }) * 100 / eofs$tot_var # [mode] dim(var) <- c(mode = length(var)) return(invisible(list(REOFs = REOFs, RPCs = RPCs, var = var))) diff --git a/R/RMS.R b/R/RMS.R index 8f7e58b..a08af12 100644 --- a/R/RMS.R +++ b/R/RMS.R @@ -94,12 +94,12 @@ RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, obs <- array(obs, dim = c(length(obs))) names(dim(obs)) <- c(time_dim) } else { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } } else if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { @@ -147,8 +147,8 @@ RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, } if (!is.numeric(limits) | any(limits %% 1 != 0) | any(limits < 0) | length(limits) != 2 | any(limits > dim(exp)[comp_dim])) { - stop(paste0("Parameter 'limits' must be a vector of two positive ", - "integers smaller than the length of paramter 'comp_dim'.")) + stop("Parameter 'limits' must be a vector of two positive ", + "integers smaller than the length of paramter 'comp_dim'.") } } ## conf @@ -186,8 +186,8 @@ RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, stop("Parameter 'exp' and 'obs' must have the same dimension names.") } if (!identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'dat_dim' and 'memb_dim'.") } if (dim(exp)[time_dim] < 2) { stop("The length of time_dim must be at least 2 to compute RMS.") @@ -264,7 +264,9 @@ RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, # dif for (i in 1:nobs) { - dif[, , i] <- sapply(1:nexp, function(x) {exp[, x] - obs[, i]}) + dif[, , i] <- sapply(1:nexp, function(x) { + exp[, x] - obs[, i] + }) } rms <- colMeans(dif^2, na.rm = TRUE)^0.5 # [nexp, nobs] @@ -280,18 +282,19 @@ RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = NULL, dat_dim = NULL, } # conf.lower chi <- sapply(1:nobs, function(i) { - qchisq(confhigh, eno[, i] - 1) + qchisq(confhigh, eno[, i] - 1) }) conf.lower <- (eno * rms ** 2 / chi) ** 0.5 # conf.upper chi <- sapply(1:nobs, function(i) { - qchisq(conflow, eno[, i] - 1) + qchisq(conflow, eno[, i] - 1) }) conf.upper <- (eno * rms ** 2 / chi) ** 0.5 } -#NOTE: Not sure if the calculation is correct. p_val is reasonable compared to the chi-square chart though. +#NOTE: Not sure if the calculation is correct. p_val is reasonable compared to +# the chi-square chart though. # if (pval | sign) { # chi <- array(dim = c(nexp = nexp, nobs = nobs)) # for (i in 1:nobs) { diff --git a/R/RMSSS.R b/R/RMSSS.R index a0fb688..c322c7f 100644 --- a/R/RMSSS.R +++ b/R/RMSSS.R @@ -115,12 +115,12 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, obs <- array(obs, dim = c(length(obs))) names(dim(obs)) <- c(time_dim) } else { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } } else if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions time_dim and dat_dim, or vector of same length.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions time_dim and dat_dim, or vector of same length.") } if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { @@ -134,7 +134,7 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, if (any(is.null(names(dim(ref)))) | any(nchar(names(dim(ref))) == 0)) { stop("Parameter 'ref' must have dimension names.") } - } else if (length(ref) != 1 | any(!ref %in% c(0, 1))) { + } else if (length(ref) != 1 | !all(ref %in% c(0, 1))) { stop("Parameter 'ref' must be a numeric array or number 0 or 1.") } } else { @@ -197,7 +197,8 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, sig_method.type <- "two.sided" } if (!any(sig_method.type %in% c('two.sided.approx', 'two.sided', 'greater', 'less'))) { - stop("Parameter 'sig_method.type' must be a method accepted by RandomWalkTest() parameter 'test.type'.") + stop("Parameter 'sig_method.type' must be a method accepted by RandomWalkTest() ", + "parameter 'test.type'.") } if (sig_method.type == 'two.sided.approx' & pval == T) { .warning("p-value cannot be calculated by Random Walk 'two.sided.approx' method.") @@ -234,8 +235,8 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, stop("Parameter 'exp' and 'obs' must have the same dimension names.") } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'dat_dim' and 'memb_dim'.") } name_ref <- sort(names(dim(ref))) @@ -245,17 +246,17 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, if (!is.null(dat_dim)) { if (dat_dim %in% name_ref) { if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { - stop(paste0("If parameter 'ref' has dataset dimension, it must be ", - "equal to dataset dimension of 'exp'.")) + stop("If parameter 'ref' has dataset dimension, it must be ", + "equal to dataset dimension of 'exp'.") } name_ref <- name_ref[-which(name_ref == dat_dim)] } } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", - "all dimensions except 'memb_dim' and 'dat_dim' if there is ", - "only one reference dataset.")) + stop("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.") } if (dim(exp)[time_dim] <= 2) { @@ -357,7 +358,9 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, names(dim(dif1)) <- c(time_dim, 'nexp', 'nobs') for (i in 1:nobs) { - dif1[, , i] <- sapply(1:nexp, function(x) {exp[, x] - obs[, i]}) + dif1[, , i] <- sapply(1:nexp, function(x) { + exp[, x] - obs[, i] + }) } rms_exp <- colMeans(dif1^2, na.rm = TRUE)^0.5 # [nexp, nobs] @@ -366,7 +369,9 @@ RMSSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', dat_dim = NULL, dif2 <- array(dim = c(nsdate, nref, nobs)) names(dim(dif2)) <- c(time_dim, 'nexp', 'nobs') for (i in 1:nobs) { - dif2[, , i] <- sapply(1:nref, function(x) {ref[, x] - obs[, i]}) + dif2[, , i] <- sapply(1:nref, function(x) { + ref[, x] - obs[, i] + }) } rms_ref <- colMeans(dif2^2, na.rm = TRUE)^0.5 # [nref, nobs] if (nexp != nref) { diff --git a/R/ROCSS.R b/R/ROCSS.R index 0fe4519..dcddeb2 100644 --- a/R/ROCSS.R +++ b/R/ROCSS.R @@ -163,8 +163,8 @@ ROCSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.") } if (!is.null(ref)) { name_ref <- sort(names(dim(ref))) @@ -174,17 +174,17 @@ ROCSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.null(dat_dim)) { if (dat_dim %in% name_ref) { if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { - stop(paste0("If parameter 'ref' has dataset dimension, it must be", - " equal to dataset dimension of 'exp'.")) + stop("If parameter 'ref' has dataset dimension, it must be", + " equal to dataset dimension of 'exp'.") } name_ref <- name_ref[-which(name_ref == dat_dim)] } } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'", - " if there is only one reference dataset.")) + stop("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'", + " if there is only one reference dataset.") } } ## prob_thresholds @@ -194,7 +194,7 @@ ROCSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } ## indices_for_clim if (is.null(indices_for_clim)) { - indices_for_clim <- 1:dim(obs)[time_dim] + indices_for_clim <- seq_len(dim(obs)[time_dim]) } else { if (!is.numeric(indices_for_clim) | !is.vector(indices_for_clim)) { stop("Parameter 'indices_for_clim' must be NULL or a numeric vector.") @@ -324,10 +324,12 @@ ROCSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', # Input dim for .GetProbs ## if exp: [sdate, memb] ## if obs: [sdate, (memb)] - exp_probs <- .GetProbs(data = ClimProjDiags::Subset(exp, dat_dim, exp_i, drop = 'selected'), + exp_probs <- .GetProbs(data = ClimProjDiags::Subset(exp, dat_dim, exp_i, + drop = 'selected'), indices_for_quantiles = indices_for_clim, prob_thresholds = prob_thresholds, cross.val = cross.val) - obs_probs <- .GetProbs(data = ClimProjDiags::Subset(obs, dat_dim, obs_i, drop = 'selected'), + obs_probs <- .GetProbs(data = ClimProjDiags::Subset(obs, dat_dim, obs_i, + drop = 'selected'), indices_for_quantiles = indices_for_clim, prob_thresholds = prob_thresholds, cross.val = cross.val) ## exp_probs and obs_probs: [bin, sdate] @@ -337,19 +339,22 @@ ROCSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } ## ROCS (exp) - rocs_exp[exp_i, obs_i, ] <- unlist(EnsRoca(ens = Reorder(exp_probs, c(time_dim, 'bin')), - obs = Reorder(obs_probs, c(time_dim, 'bin')))[1:ncats]) + rocs_exp[exp_i, obs_i, ] <- + unlist(EnsRoca(ens = Reorder(exp_probs, c(time_dim, 'bin')), + obs = Reorder(obs_probs, c(time_dim, 'bin')))[1:ncats]) if (!is.null(ref)) { if (is.null(cat_dim)) { # calculate probs - ref_probs <- .GetProbs(ClimProjDiags::Subset(ref, dat_dim, exp_i, drop = 'selected'), + ref_probs <- .GetProbs(ClimProjDiags::Subset(ref, dat_dim, exp_i, + drop = 'selected'), indices_for_quantiles = indices_for_clim, prob_thresholds = prob_thresholds, cross.val = cross.val) } else { ref_probs <- ref[, , exp_i] } - rocs_ref[exp_i, obs_i, ] <- unlist(EnsRoca(ens = Reorder(ref_probs, c(time_dim, 'bin')), - obs = Reorder(obs_probs, c(time_dim, 'bin')))[1:ncats]) + rocs_ref[exp_i, obs_i, ] <- + unlist(EnsRoca(ens = Reorder(ref_probs, c(time_dim, 'bin')), + obs = Reorder(obs_probs, c(time_dim, 'bin')))[1:ncats]) } } } diff --git a/R/RPS.R b/R/RPS.R index 08c569c..17c98c4 100644 --- a/R/RPS.R +++ b/R/RPS.R @@ -93,8 +93,8 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL stop('Parameter "exp" must be a numeric array.') if (!is.array(obs) | !is.numeric(obs)) stop('Parameter "obs" must be a numeric array.') - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## time_dim @@ -150,8 +150,8 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.") } ## prob_thresholds if (!is.numeric(prob_thresholds) | !is.vector(prob_thresholds) | @@ -160,7 +160,7 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL } ## indices_for_clim if (is.null(indices_for_clim)) { - indices_for_clim <- 1:dim(obs)[time_dim] + indices_for_clim <- seq_len(dim(obs)[time_dim]) } else { if (!is.numeric(indices_for_clim) | !is.vector(indices_for_clim)) { stop("Parameter 'indices_for_clim' must be NULL or a numeric vector.") @@ -183,23 +183,25 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL if (!is.array(weights) | !is.numeric(weights)) stop("Parameter 'weights' must be a named numeric array.") if (is.null(dat_dim)) { - if (length(dim(weights)) != 2 | any(!names(dim(weights)) %in% c(memb_dim, time_dim))) - stop("Parameter 'weights' must have two dimensions with the names of 'memb_dim' and 'time_dim'.") + if (length(dim(weights)) != 2 | !all(names(dim(weights)) %in% c(memb_dim, time_dim))) + stop("Parameter 'weights' must have two dimensions with the names of ", + "'memb_dim' and 'time_dim'.") if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | dim(weights)[time_dim] != dim(exp)[time_dim]) { - stop(paste0("Parameter 'weights' must have the same dimension lengths ", - "as 'memb_dim' and 'time_dim' in 'exp'.")) + stop("Parameter 'weights' must have the same dimension lengths ", + "as 'memb_dim' and 'time_dim' in 'exp'.") } weights <- Reorder(weights, c(time_dim, memb_dim)) } else { - if (length(dim(weights)) != 3 | any(!names(dim(weights)) %in% c(memb_dim, time_dim, dat_dim))) - stop("Parameter 'weights' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") + if (length(dim(weights)) != 3 | !all(names(dim(weights)) %in% c(memb_dim, time_dim, dat_dim))) + stop("Parameter 'weights' must have three dimensions with the names of ", + "'memb_dim', 'time_dim' and 'dat_dim'.") if (dim(weights)[memb_dim] != dim(exp)[memb_dim] | dim(weights)[time_dim] != dim(exp)[time_dim] | dim(weights)[dat_dim] != dim(exp)[dat_dim]) { - stop(paste0("Parameter 'weights' must have the same dimension lengths ", - "as 'memb_dim', 'time_dim' and 'dat_dim' in 'exp'.")) + stop("Parameter 'weights' must have the same dimension lengths ", + "as 'memb_dim', 'time_dim' and 'dat_dim' in 'exp'.") } weights <- Reorder(weights, c(time_dim, memb_dim, dat_dim)) @@ -288,8 +290,8 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL for (i in 1:nexp) { for (j in 1:nobs) { - exp_data <- exp[ , , i] - obs_data <- obs[ , , j] + exp_data <- exp[, , i] + obs_data <- obs[, , j] if (is.null(dim(exp_data))) dim(exp_data) <- c(dim(exp)[1:2]) if (is.null(dim(obs_data))) dim(obs_data) <- c(dim(obs)[1:2]) @@ -316,7 +318,7 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL # If the data inputs are forecast/observation, calculate probabilities if (is.null(cat_dim)) { if (!is.null(weights)) { - weights_data <- weights[which(good_values) , , i] + weights_data <- weights[which(good_values), , i] if (is.null(dim(weights_data))) dim(weights_data) <- c(dim(weights)[1:2]) } else { weights_data <- weights #NULL @@ -327,10 +329,12 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL good_indices_for_clim <- dum[!is.na(dum)] exp_probs <- .GetProbs(data = exp_data, indices_for_quantiles = good_indices_for_clim, - prob_thresholds = prob_thresholds, weights = weights_data, cross.val = cross.val) + prob_thresholds = prob_thresholds, weights = weights_data, + cross.val = cross.val) # exp_probs: [bin, sdate] obs_probs <- .GetProbs(data = obs_data, indices_for_quantiles = good_indices_for_clim, - prob_thresholds = prob_thresholds, weights = NULL, cross.val = cross.val) + prob_thresholds = prob_thresholds, weights = NULL, + cross.val = cross.val) # obs_probs: [bin, sdate] } else { # inputs are probabilities already @@ -345,17 +349,17 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL rps [good_values, i, j] <- colSums((probs_exp_cumsum - probs_obs_cumsum)^2) if (Fair) { # FairRPS - ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps] + ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) + ## [formula taken from SpecsVerification::EnsRps] R <- dim(exp)[2] #memb - R_new <- Inf adjustment <- (-1) / (R - 1) * probs_exp_cumsum * (1 - probs_exp_cumsum) adjustment <- colSums(adjustment) - rps[ , i, j] <- rps[ , i, j] + adjustment + rps[, i, j] <- rps[, i, j] + adjustment } } else { ## not enough values different from NA - rps[ , i, j] <- as.numeric(NA) + rps[, i, j] <- as.numeric(NA) } diff --git a/R/RPSS.R b/R/RPSS.R index 125bb71..c6d3a12 100644 --- a/R/RPSS.R +++ b/R/RPSS.R @@ -211,8 +211,8 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all dimensions except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all dimensions except 'memb_dim' and 'dat_dim'.") } if (!is.null(ref)) { name_ref <- sort(names(dim(ref))) @@ -222,17 +222,17 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!is.null(dat_dim)) { if (dat_dim %in% name_ref) { if (!identical(dim(exp)[dat_dim], dim(ref)[dat_dim])) { - stop(paste0("If parameter 'ref' has dataset dimension, it must be", - " equal to dataset dimension of 'exp'.")) + stop("If parameter 'ref' has dataset dimension, it must be", + " equal to dataset dimension of 'exp'.") } name_ref <- name_ref[-which(name_ref == dat_dim)] } } if (!identical(length(name_exp), length(name_ref)) | !identical(dim(exp)[name_exp], dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp' and 'ref' must have the same length of ", - "all dimensions except 'memb_dim' and 'dat_dim' if there is ", - "only one reference dataset.")) + stop("Parameter 'exp' and 'ref' must have the same length of ", + "all dimensions except 'memb_dim' and 'dat_dim' if there is ", + "only one reference dataset.") } } ## prob_thresholds @@ -242,7 +242,7 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } ## indices_for_clim if (is.null(indices_for_clim)) { - indices_for_clim <- 1:dim(obs)[time_dim] + indices_for_clim <- seq_len(dim(obs)[time_dim]) } else { if (!is.numeric(indices_for_clim) | !is.vector(indices_for_clim)) { stop("Parameter 'indices_for_clim' must be NULL or a numeric vector.") @@ -266,22 +266,29 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', stop("Parameter 'weights_exp' must be a named numeric array.") if (is.null(dat_dim)) { - if (length(dim(weights_exp)) != 2 | any(!names(dim(weights_exp)) %in% c(memb_dim, time_dim))) - stop("Parameter 'weights_exp' must have two dimensions with the names of 'memb_dim' and 'time_dim'.") + if (length(dim(weights_exp)) != 2 | + !all(names(dim(weights_exp)) %in% c(memb_dim, time_dim))) { + stop("Parameter 'weights_exp' must have two dimensions with the names of ", + "'memb_dim' and 'time_dim'.") + } if (dim(weights_exp)[memb_dim] != dim(exp)[memb_dim] | dim(weights_exp)[time_dim] != dim(exp)[time_dim]) { - stop("Parameter 'weights_exp' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'exp'.") + stop("Parameter 'weights_exp' must have the same dimension lengths as ", + "'memb_dim' and 'time_dim' in 'exp'.") } weights_exp <- Reorder(weights_exp, c(time_dim, memb_dim)) } else { - if (length(dim(weights_exp)) != 3 | any(!names(dim(weights_exp)) %in% c(memb_dim, time_dim, dat_dim))) - stop("Parameter 'weights_exp' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") + if (length(dim(weights_exp)) != 3 | + !all(names(dim(weights_exp)) %in% c(memb_dim, time_dim, dat_dim))) { + stop("Parameter 'weights_exp' must have three dimensions with the names of ", + "'memb_dim', 'time_dim' and 'dat_dim'.") + } if (dim(weights_exp)[memb_dim] != dim(exp)[memb_dim] | dim(weights_exp)[time_dim] != dim(exp)[time_dim] | dim(weights_exp)[dat_dim] != dim(exp)[dat_dim]) { - stop(paste0("Parameter 'weights_exp' must have the same dimension lengths ", - "as 'memb_dim', 'time_dim' and 'dat_dim' in 'exp'.")) + stop("Parameter 'weights_exp' must have the same dimension lengths ", + "as 'memb_dim', 'time_dim' and 'dat_dim' in 'exp'.") } weights_exp <- Reorder(weights_exp, c(time_dim, memb_dim, dat_dim)) } @@ -296,22 +303,29 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', stop("Parameter 'weights_ref' must be a named numeric array.") if (is.null(dat_dim) | ((!is.null(dat_dim)) && (!dat_dim %in% names(dim(ref))))) { - if (length(dim(weights_ref)) != 2 | any(!names(dim(weights_ref)) %in% c(memb_dim, time_dim))) - stop("Parameter 'weights_ref' must have two dimensions with the names of 'memb_dim' and 'time_dim'.") + if (length(dim(weights_ref)) != 2 | + !all(names(dim(weights_ref)) %in% c(memb_dim, time_dim))) { + stop("Parameter 'weights_ref' must have two dimensions with the names of ", + "'memb_dim' and 'time_dim'.") + } if (dim(weights_ref)[memb_dim] != dim(exp)[memb_dim] | dim(weights_ref)[time_dim] != dim(exp)[time_dim]) { - stop("Parameter 'weights_ref' must have the same dimension lengths as 'memb_dim' and 'time_dim' in 'ref'.") + stop("Parameter 'weights_ref' must have the same dimension lengths as ", + "'memb_dim' and 'time_dim' in 'ref'.") } weights_ref <- Reorder(weights_ref, c(time_dim, memb_dim)) } else { - if (length(dim(weights_ref)) != 3 | any(!names(dim(weights_ref)) %in% c(memb_dim, time_dim, dat_dim))) - stop("Parameter 'weights_ref' must have three dimensions with the names of 'memb_dim', 'time_dim' and 'dat_dim'.") + if (length(dim(weights_ref)) != 3 | + !all(names(dim(weights_ref)) %in% c(memb_dim, time_dim, dat_dim))) { + stop("Parameter 'weights_ref' must have three dimensions with the names of ", + "'memb_dim', 'time_dim' and 'dat_dim'.") + } if (dim(weights_ref)[memb_dim] != dim(ref)[memb_dim] | dim(weights_ref)[time_dim] != dim(ref)[time_dim] | dim(weights_ref)[dat_dim] != dim(ref)[dat_dim]) { - stop(paste0("Parameter 'weights_ref' must have the same dimension lengths ", - "as 'memb_dim', 'time_dim' and 'dat_dim' in 'ref'.")) + stop("Parameter 'weights_ref' must have the same dimension lengths ", + "as 'memb_dim', 'time_dim' and 'dat_dim' in 'ref'.") } weights_ref <- Reorder(weights_ref, c(time_dim, memb_dim, dat_dim)) } @@ -331,7 +345,8 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', ## sig_method.type #NOTE: These are the types of RandomWalkTest() if (!sig_method.type %in% c('two.sided.approx', 'two.sided', 'greater', 'less')) { - stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', 'greater', or 'less'.") + stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', ", + "'greater', or 'less'.") } if (sig_method.type == 'two.sided.approx') { if (alpha != 0.05) { @@ -474,14 +489,16 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', good_indices_for_clim <- dum[!is.na(dum)] if (f_NAs <= sum(good_values) / length(good_values)) { - rps_exp[good_values,i,j] <- .RPS(exp = exp[good_values, , i], obs = obs[good_values, , j], + rps_exp[good_values, i, j] <- .RPS(exp = exp[good_values, , i], + obs = obs[good_values, , j], time_dim = time_dim, memb_dim = memb_dim, cat_dim = cat_dim, dat_dim = NULL, prob_thresholds = prob_thresholds, indices_for_clim = good_indices_for_clim, Fair = Fair, weights = weights_exp[good_values, , i], cross.val = cross.val, na.rm = na.rm) - rps_ref[good_values,i,j] <- .RPS(exp = ref[good_values, , k], obs = obs[good_values, , j], + rps_ref[good_values, i, j] <- .RPS(exp = ref[good_values, , k], + obs = obs[good_values, , j], time_dim = time_dim, memb_dim = memb_dim, cat_dim = cat_dim, dat_dim = NULL, prob_thresholds = prob_thresholds, @@ -526,8 +543,10 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', # Subset indices_for_clim dum <- match(indices_for_clim, which(good_values)) good_indices_for_clim <- dum[!is.na(dum)] - obs_probs <- .GetProbs(data = obs_data, indices_for_quantiles = good_indices_for_clim, - prob_thresholds = prob_thresholds, weights = NULL, cross.val = cross.val) + obs_probs <- .GetProbs(data = obs_data, + indices_for_quantiles = good_indices_for_clim, + prob_thresholds = prob_thresholds, + weights = NULL, cross.val = cross.val) } else { obs_probs <- t(obs_data) } @@ -544,7 +563,8 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', rps_ref[good_values, i, j] <- colSums((probs_clim_cumsum - probs_obs_cumsum)^2) } # if (Fair) { # FairRPS - # ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps] + # ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) + # ## [formula taken from SpecsVerification::EnsRps] # R <- dim(exp)[2] #memb # R_new <- Inf # adjustment <- (-1) / (R - 1) * probs_clim_cumsum * (1 - probs_clim_cumsum) @@ -570,7 +590,7 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', rpss <- array(dim = c(nexp = nexp, nobs = nobs)) sign <- array(dim = c(nexp = nexp, nobs = nobs)) - if (any(!is.na(rps_exp_mean))) { + if (!all(is.na(rps_exp_mean))) { for (i in 1:nexp) { for (j in 1:nobs) { rpss[i, j] <- 1 - rps_exp_mean[i, j] / rps_ref_mean[i, j] @@ -578,7 +598,8 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', if (!any(ind_nonNA)) { sign[i, j] <- NA } else { - sign[i, j] <- .RandomWalkTest(skill_A = rps_exp[ind_nonNA, i, j], skill_B = rps_ref[ind_nonNA, i, j], + sign[i, j] <- .RandomWalkTest(skill_A = rps_exp[ind_nonNA, i, j], + skill_B = rps_ref[ind_nonNA, i, j], test.type = sig_method.type, alpha = alpha, sign = T, pval = F)$sign } @@ -598,7 +619,8 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } else { # rps_exp and rps_ref: [sdate] rpss <- 1 - mean(rps_exp, na.rm = TRUE) / mean(rps_ref, na.rm = TRUE) - sign <- .RandomWalkTest(skill_A = rps_exp[ind_nonNA], skill_B = rps_ref[ind_nonNA], + sign <- .RandomWalkTest(skill_A = rps_exp[ind_nonNA], + skill_B = rps_ref[ind_nonNA], test.type = sig_method.type, alpha = alpha, sign = T, pval = F)$sign } diff --git a/R/RandomWalkTest.R b/R/RandomWalkTest.R index 8d5f67f..caf24ad 100644 --- a/R/RandomWalkTest.R +++ b/R/RandomWalkTest.R @@ -94,7 +94,7 @@ RandomWalkTest <- function(skill_A, skill_B, time_dim = 'sdate', if (is.null(skill_A) | is.null(skill_B)) { stop("Parameters 'skill_A' and 'skill_B' cannot be NULL.") } - if(!is.numeric(skill_A) | !is.numeric(skill_B)) { + if (!is.numeric(skill_A) | !is.numeric(skill_B)) { stop("Parameters 'skill_A' and 'skill_B' must be a numerical array.") } if (!identical(dim(skill_A), dim(skill_B))) { @@ -112,7 +112,7 @@ RandomWalkTest <- function(skill_A, skill_B, time_dim = 'sdate', stop("Parameter 'alpha' must be a number between 0 and 1.") } ## test.type - if (!test.type %in% c('two.sided.approx','two.sided','greater','less')) { + if (!test.type %in% c('two.sided.approx', 'two.sided', 'greater', 'less')) { stop("Parameter 'test.type' must be 'two.sided.approx', 'two.sided', 'greater', or 'less'.") } if (test.type == 'two.sided.approx') { diff --git a/R/RatioPredictableComponents.R b/R/RatioPredictableComponents.R index 3d5cae5..b34d9fd 100644 --- a/R/RatioPredictableComponents.R +++ b/R/RatioPredictableComponents.R @@ -25,7 +25,9 @@ #' #'@import multiApply stats #'@export -RatioPredictableComponents <- function(exp, obs, time_dim = 'year', memb_dim = 'member', na.rm = FALSE, ncores = NULL) { +RatioPredictableComponents <- function(exp, obs, time_dim = 'year', + memb_dim = 'member', na.rm = FALSE, + ncores = NULL) { ## Checkings if (is.null(exp)) { @@ -61,7 +63,7 @@ RatioPredictableComponents <- function(exp, obs, time_dim = 'year', memb_dim = ' if (!is.logical(na.rm)) { stop("Parameter 'na.rm' must be TRUE or FALSE.") } - if (!is.null(ncores)){ + if (!is.null(ncores)) { if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1) { stop("Parameter 'ncores' must be a positive integer.") } @@ -83,7 +85,7 @@ RatioPredictableComponents <- function(exp, obs, time_dim = 'year', memb_dim = ' ## Ensemble mean and spread ens_mean <- apply(exp, 1, mean, na.rm = na.rm) - ens_spread <- apply(exp, 2, "-", ens_mean) + #ens_spread <- apply(exp, 2, "-", ens_mean) ## Ensemble mean variance -> signal var_signal <- var(ens_mean, na.rm = na.rm) diff --git a/R/RatioRMS.R b/R/RatioRMS.R index c3bb32b..d09fc0f 100644 --- a/R/RatioRMS.R +++ b/R/RatioRMS.R @@ -55,8 +55,10 @@ #'# time step. #'ano_exp_1 <- ClimProjDiags::Subset(ano_exp, 'member', c(1, 2)) #'ano_exp_2 <- ClimProjDiags::Subset(ano_exp, 'member', c(3)) -#'ano_exp_1 <- ClimProjDiags::Subset(ano_exp_1, c('dataset', 'ftime'), list(1, 1), drop = 'selected') -#'ano_exp_2 <- ClimProjDiags::Subset(ano_exp_2, c('dataset', 'ftime'), list(1, 1), drop = 'selected') +#'ano_exp_1 <- ClimProjDiags::Subset(ano_exp_1, c('dataset', 'ftime'), +#' list(1, 1), drop = 'selected') +#'ano_exp_2 <- ClimProjDiags::Subset(ano_exp_2, c('dataset', 'ftime'), +#' list(1, 1), drop = 'selected') #'ano_obs <- ClimProjDiags::Subset(ano_obs, c('dataset', 'ftime'), list(1, 1), drop = 'selected') #'# Compute ensemble mean and provide as inputs to RatioRMS. #'rrms <- RatioRMS(MeanDims(ano_exp_1, 'member'), @@ -92,14 +94,14 @@ RatioRMS <- function(exp1, exp2, obs, time_dim = 'sdate', pval = TRUE, ncores = dim(obs) <- c(length(obs)) names(dim(obs)) <- time_dim } - if(any(is.null(names(dim(exp1)))) | any(nchar(names(dim(exp1))) == 0) | - any(is.null(names(dim(exp2)))) | any(nchar(names(dim(exp2))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp1)))) | any(nchar(names(dim(exp1))) == 0) | + any(is.null(names(dim(exp2)))) | any(nchar(names(dim(exp2))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp1', 'exp2', and 'obs' must have dimension names.") } - if(!all(names(dim(exp1)) %in% names(dim(exp2))) | - !all(names(dim(exp2)) %in% names(dim(obs))) | - !all(names(dim(obs)) %in% names(dim(exp1)))) { + if (!all(names(dim(exp1)) %in% names(dim(exp2))) | + !all(names(dim(exp2)) %in% names(dim(obs))) | + !all(names(dim(obs)) %in% names(dim(exp1)))) { stop("Parameter 'exp1', 'exp2', and 'obs' must have same dimension names.") } name_1 <- sort(names(dim(exp1))) @@ -107,8 +109,8 @@ RatioRMS <- function(exp1, exp2, obs, time_dim = 'sdate', pval = TRUE, ncores = name_3 <- sort(names(dim(obs))) if (!all(dim(exp1)[name_1] == dim(exp2)[name_2]) | !all(dim(exp1)[name_1] == dim(obs)[name_3])) { - stop(paste0("Parameter 'exp1', 'exp2', and 'obs' must have the same length of ", - "all the dimensions.")) + stop("Parameter 'exp1', 'exp2', and 'obs' must have the same length of ", + "all the dimensions.") } ## time_dim if (!is.character(time_dim) | length(time_dim) > 1) { @@ -161,7 +163,8 @@ RatioRMS <- function(exp1, exp2, obs, time_dim = 'sdate', pval = TRUE, ncores = dif2 <- exp2 - obs rms1 <- MeanDims(dif1^2, time_dim, na.rm = TRUE)^0.5 rms2 <- MeanDims(dif2^2, time_dim, na.rm = TRUE)^0.5 - rms2[which(abs(rms2) <= (max(abs(rms2), na.rm = TRUE) / 1000))] <- max(abs(rms2), na.rm = TRUE) / 1000 + rms2[which(abs(rms2) <= (max(abs(rms2), na.rm = TRUE) / 1000))] <- + max(abs(rms2), na.rm = TRUE) / 1000 ratiorms <- rms1 / rms2 if (pval) { @@ -171,12 +174,12 @@ RatioRMS <- function(exp1, exp2, obs, time_dim = 'sdate', pval = TRUE, ncores = F[which(F < 1)] <- 1 / F[which(F < 1)] if (is.null(dim(ratiorms))) { - p.val <- c() + p.val <- NULL } else { p.val <- array(dim = dim(ratiorms)) } avail_ind <- which(!is.na(eno1) & !is.na(eno2) & eno1 > 2 & eno2 > 2) - p.val[avail_ind] <- (1 - pf(F,eno1[avail_ind] - 1, eno2[avail_ind] - 1)) * 2 + p.val[avail_ind] <- (1 - pf(F, eno1[avail_ind] - 1, eno2[avail_ind] - 1)) * 2 ratiorms[-avail_ind] <- NA } diff --git a/R/RatioSDRMS.R b/R/RatioSDRMS.R index 1b58eed..aff139c 100644 --- a/R/RatioSDRMS.R +++ b/R/RatioSDRMS.R @@ -62,8 +62,8 @@ RatioSDRMS <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', stop("Parameter 'exp' and 'obs' must be a numeric array.") } if (is.null(dim(exp)) | is.null(dim(obs))) { - stop(paste0("Parameter 'exp' and 'obs' must be array with as least two ", - "dimensions memb_dim and time_dim.")) + stop("Parameter 'exp' and 'obs' must be array with as least two ", + "dimensions memb_dim and time_dim.") } if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { @@ -112,8 +112,8 @@ RatioSDRMS <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', name_exp <- name_exp[-which(name_exp == memb_dim)] name_obs <- name_obs[-which(name_obs == memb_dim)] if (!identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of ", - "all the dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of ", + "all the dimensions except 'dat_dim' and 'memb_dim'.") } ## pval if (!is.logical(pval) | length(pval) > 1) { diff --git a/R/Regression.R b/R/Regression.R index dcc447e..2d09520 100644 --- a/R/Regression.R +++ b/R/Regression.R @@ -108,17 +108,17 @@ Regression <- function(datay, datax, reg_dim = 'sdate', formula = y ~ x, dim(datax) <- c(length(datax)) names(dim(datax)) <- reg_dim } - if(any(is.null(names(dim(datay)))) | any(nchar(names(dim(datay))) == 0) | - any(is.null(names(dim(datax)))) | any(nchar(names(dim(datax))) == 0)) { + if (any(is.null(names(dim(datay)))) | any(nchar(names(dim(datay))) == 0) | + any(is.null(names(dim(datax)))) | any(nchar(names(dim(datax))) == 0)) { stop("Parameter 'datay' and 'datax' must have dimension names.") } - if(!all(names(dim(datay)) %in% names(dim(datax))) | - !all(names(dim(datax)) %in% names(dim(datay)))) { + if (!all(names(dim(datay)) %in% names(dim(datax))) | + !all(names(dim(datax)) %in% names(dim(datay)))) { stop("Parameter 'datay' and 'datax' must have same dimension name") } name_datay <- sort(names(dim(datay))) name_datax <- sort(names(dim(datax))) - if(!all(dim(datay)[name_datay] == dim(datax)[name_datax])) { + if (!all(dim(datay)[name_datay] == dim(datax)[name_datax])) { stop("Parameter 'datay' and 'datax' must have same length of all dimensions.") } ## reg_dim @@ -150,15 +150,15 @@ Regression <- function(datay, datax, reg_dim = 'sdate', formula = y ~ x, } ## na.action if (!is.function(na.action) & !is.numeric(na.action)) { - stop(paste0("Parameter 'na.action' must be a function for NA values or ", - "a numeric indicating the number of NA values allowed ", - "before returning NA.")) + stop("Parameter 'na.action' must be a function for NA values or ", + "a numeric indicating the number of NA values allowed ", + "before returning NA.") } if (is.numeric(na.action)) { if (any(na.action %% 1 != 0) | any(na.action < 0) | length(na.action) > 1) { - stop(paste0("Parameter 'na.action' must be a function for NA values or ", - "a numeric indicating the number of NA values allowed ", - "before returning NA.")) + stop("Parameter 'na.action' must be a function for NA values or ", + "a numeric indicating the number of NA values allowed ", + "before returning NA.") } } ## ncores @@ -201,7 +201,7 @@ Regression <- function(datay, datax, reg_dim = 'sdate', formula = y ~ x, .Regression <- function(y, x, formula = y~x, pval = TRUE, conf = TRUE, sign = FALSE, alpha = 0.05, na.action = na.omit) { - NApos <- 1:length(x) + NApos <- seq_along(x) NApos[which(is.na(x) | is.na(y))] <- NA filtered <- rep(NA, length(x)) check_na <- FALSE diff --git a/R/Reorder.R b/R/Reorder.R index 71a22e3..12730a9 100644 --- a/R/Reorder.R +++ b/R/Reorder.R @@ -75,8 +75,8 @@ Reorder <- function(data, order) { } } if (length(order) != length(dim(data))) { - stop(paste0("The length of parameter 'order' should be the same with the ", - "dimension length of parameter 'data'.")) + stop("The length of parameter 'order' should be the same with the ", + "dimension length of parameter 'data'.") } @@ -97,7 +97,7 @@ Reorder <- function(data, order) { if (is.numeric(data)) { data <- aperm(data, order) } else { - y <- array(1:length(data), dim = dim(data)) + y <- array(seq_along(data), dim = dim(data)) y <- aperm(y, order) data <- data[as.vector(y)] dim(data) <- old_dims[order] diff --git a/R/ResidualCorr.R b/R/ResidualCorr.R index 18ca539..53cec7c 100644 --- a/R/ResidualCorr.R +++ b/R/ResidualCorr.R @@ -94,12 +94,12 @@ ResidualCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', if (!is.numeric(N.eff)) stop("Parameter 'N.eff' must be numeric.") if (!all(names(dim(N.eff)) %in% names(dim(obs))) | any(dim(obs)[match(names(dim(N.eff)), names(dim(obs)))] != dim(N.eff))) { - stop(paste0('If parameter "N.eff" is provided with an array, it must ', - 'have the same dimensions as "obs" except "time_dim".')) + stop('If parameter "N.eff" is provided with an array, it must ', + 'have the same dimensions as "obs" except "time_dim".') } } else if (any((!is.na(N.eff) & !is.numeric(N.eff)) | length(N.eff) != 1)) { - stop(paste0('Parameter "N.eff" must be NA, a numeric, or an array with ', - 'the same dimensions as "obs" except "time_dim".')) + stop('Parameter "N.eff" must be NA, a numeric, or an array with ', + 'the same dimensions as "obs" except "time_dim".') } ## time_dim @@ -126,10 +126,12 @@ ResidualCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', name_exp <- name_exp[-which(name_exp == memb_dim)] name_ref <- name_ref[-which(name_ref == memb_dim)] } - if (length(name_exp) != length(name_obs) | length(name_exp) != length(name_ref) | - any(dim(exp)[name_exp] != dim(obs)[name_obs]) | any(dim(exp)[name_exp] != dim(ref)[name_ref])) { - stop(paste0("Parameter 'exp', 'obs', and 'ref' must have same length of ", - "all dimensions except 'memb_dim'.")) + if (length(name_exp) != length(name_obs) | + length(name_exp) != length(name_ref) | + any(dim(exp)[name_exp] != dim(obs)[name_obs]) | + any(dim(exp)[name_exp] != dim(ref)[name_ref])) { + stop("Parameter 'exp', 'obs', and 'ref' must have same length of ", + "all dimensions except 'memb_dim'.") } ## method if (!method %in% c("pearson", "kendall", "spearman")) { @@ -167,14 +169,13 @@ ResidualCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', # Calculate ensemble mean dim_exp <- dim(exp) - dim_obs <- dim(obs) dim_ref <- dim(ref) if (!is.null(memb_dim)) { exp_memb_dim_ind <- which(names(dim_exp) == memb_dim) ref_memb_dim_ind <- which(names(dim_ref) == memb_dim) - exp <- apply(exp, c(1:length(dim_exp))[-exp_memb_dim_ind], mean, na.rm = FALSE) - ref <- apply(ref, c(1:length(dim_ref))[-ref_memb_dim_ind], mean, na.rm = FALSE) + exp <- apply(exp, c(seq_along(dim_exp))[-exp_memb_dim_ind], mean, na.rm = FALSE) + ref <- apply(ref, c(seq_along(dim_ref))[-ref_memb_dim_ind], mean, na.rm = FALSE) if (is.null(dim(exp))) exp <- array(exp, dim = c(dim_exp[time_dim])) if (is.null(dim(ref))) ref <- array(ref, dim = c(dim_ref[time_dim])) } diff --git a/R/SPOD.R b/R/SPOD.R index 3a8ff73..624f8af 100644 --- a/R/SPOD.R +++ b/R/SPOD.R @@ -122,13 +122,13 @@ SPOD <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l stop("Parameter 'lon_dim' is not found in 'data' dimension.") } # data_lats and data_lons part2 - if (dim(data)[lat_dim] != length(data_lats)){ - stop(paste0("The latitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lats'.")) + if (dim(data)[lat_dim] != length(data_lats)) { + stop("The latitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lats'.") } - if (dim(data)[lon_dim] != length(data_lons)){ - stop(paste0("The longitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lons'.")) + if (dim(data)[lon_dim] != length(data_lons)) { + stop("The longitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lons'.") } # ncores if (!is.null(ncores)) { @@ -139,20 +139,20 @@ SPOD <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } # mask if (!is.null(mask)) { - if (is.array(mask) & identical(names(dim(mask)), c(lat_dim,lon_dim)) & + if (is.array(mask) & identical(names(dim(mask)), c(lat_dim, lon_dim)) & identical(as.integer(dim(mask)), c(length(data_lats), length(data_lons)))) { ## To mask those grid point that are missing in the observations mask <- s2dv::Reorder(data = mask, order = c(lat_dim, lon_dim)) - fun_mask <- function(data, mask){ + fun_mask <- function(data, mask) { data[mask == 0] <- NA return(data) } data <- multiApply::Apply(data = data, target_dims = c(lat_dim, lon_dim), fun = fun_mask, mask = mask, ncores = ncores)$output1 } else { - stop(paste0("Parameter 'mask' must be NULL (no mask) or a numerical array ", - "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", - "points that have to be masked.")) + stop("Parameter 'mask' must be NULL (no mask) or a numerical array ", + "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", + "points that have to be masked.") } } # monini @@ -182,11 +182,11 @@ SPOD <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } # indices_for_clim if (!is.null(indices_for_clim)) { - if (!class(indices_for_clim) %in% c('numeric', 'integer') - & !(is.logical(indices_for_clim) & !any(indices_for_clim))) { - stop(paste0("The parameter 'indices_for_clim' must be a numeric vector ", - "or NULL to compute the anomalies based on the whole period, ", - "or FALSE if data are already anomalies")) + if (!(is(indices_for_clim, "numeric") || is(indices_for_clim, "integer")) & + !(is.logical(indices_for_clim) & !any(indices_for_clim))) { + stop("The parameter 'indices_for_clim' must be a numeric vector ", + "or NULL to compute the anomalies based on the whole period, ", + "or FALSE if data are already anomalies") } } # year_dim @@ -208,7 +208,7 @@ SPOD <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } } # na.rm - if (!na.rm %in% c(TRUE,FALSE)) { + if (!na.rm %in% c(TRUE, FALSE)) { stop("Parameter 'na.rm' must be TRUE or FALSE") } @@ -230,12 +230,12 @@ SPOD <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l londim = lon_dim, latdim = lat_dim) - data <- ClimProjDiags::CombineIndices(indices = list(mean_1,mean_2), + data <- ClimProjDiags::CombineIndices(indices = list(mean_1, mean_2), weights = NULL, operation = 'subtract') # (mean_1 - mean_2) - if (type == 'dcpp'){ + if (type == 'dcpp') { target_dims <- c(sdate_dim, fmonth_dim) - } else if (type %in% c('hist','obs')){ + } else if (type %in% c('hist', 'obs')) { target_dims <- c(year_dim, month_dim) } diff --git a/R/Season.R b/R/Season.R index e9dbb75..46dcc48 100644 --- a/R/Season.R +++ b/R/Season.R @@ -5,15 +5,15 @@ #'accounted. #' #'@param data A named numeric array with at least one dimension 'time_dim'. -#'@param time_dim A character string indicating the name of dimension along -#' which the seasonal mean or other calculations are computed. The default -#' value is 'ftime'. #'@param monini An integer indicating what the first month of the time series is. #' It can be from 1 to 12. #'@param moninf An integer indicating the starting month of the seasonal #' calculation. It can be from 1 to 12. #'@param monsup An integer indicating the end month of the seasonal calculation. #' It can be from 1 to 12. +#'@param time_dim A character string indicating the name of dimension along +#' which the seasonal mean or other calculations are computed. The default +#' value is 'ftime'. #'@param method An R function to be applied for seasonal calculation. For #' example, 'sum' can be used for total precipitation. The default value is mean. #'@param na.rm A logical value indicating whether to remove NA values along @@ -38,7 +38,7 @@ #'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2, na.rm = FALSE) #'@import multiApply #'@export -Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, +Season <- function(data, monini, moninf, monsup, time_dim = 'ftime', method = mean, na.rm = TRUE, ncores = NULL) { # Check inputs @@ -53,7 +53,7 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -144,7 +144,7 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, names(dim(res)) <- time_dim } else { time_dim_ind <- match(time_dim, names(dim(data))) - res <- apply(data, c(1:length(dim(data)))[-time_dim_ind], .Season, + res <- apply(data, c(seq_along(dim(data)))[-time_dim_ind], .Season, monini = monini, moninf = moninf, monsup = monsup, method = method, na.rm = na.rm) if (is.null(dim(res))) { @@ -176,18 +176,24 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, pos <- moninf : monsup # Extended index for all period: if (length(x) > pos[length(pos)]) { - pos2 <- lapply(pos, function(y) {seq(y, length(x), 12)}) + pos2 <- lapply(pos, function(y) { + seq(y, length(x), 12) + }) } else { pos2 <- pos } # Correct if the final season is not complete: maxyear <- min(unlist(lapply(pos2, length))) - pos2 <- lapply(pos2, function(y) {y[1 : maxyear]}) + pos2 <- lapply(pos2, function(y) { + y[1 : maxyear] + }) # Convert to array: pos2 <- unlist(pos2) dim(pos2) <- c(year = maxyear, month = length(pos2) / maxyear) - timeseries <- apply(pos2, 1, function(y) {method(x[y], na.rm = na.rm)}) + timeseries <- apply(pos2, 1, function(y) { + method(x[y], na.rm = na.rm) + }) timeseries <- as.array(timeseries) return(timeseries) diff --git a/R/SignalNoiseRatio.R b/R/SignalNoiseRatio.R index 18dccf4..cba54a9 100644 --- a/R/SignalNoiseRatio.R +++ b/R/SignalNoiseRatio.R @@ -25,7 +25,8 @@ #'@import multiApply #'@importFrom stats var #'@export -SignalNoiseRatio <- function(data, time_dim = 'year', member_dim = 'member', na.rm = FALSE, ncores = NULL) { +SignalNoiseRatio <- function(data, time_dim = 'year', member_dim = 'member', + na.rm = FALSE, ncores = NULL) { ## Input Check if (is.null(data)) { @@ -49,8 +50,8 @@ SignalNoiseRatio <- function(data, time_dim = 'year', member_dim = 'member', na. if (!is.logical(na.rm)) { stop("Parameter 'na.rm' must be TRUE or FALSE.") } - if (!is.null(ncores)){ - if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1){ + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1) { stop("Parameter 'ncores' must be a positive integer.") } } diff --git a/R/Smoothing.R b/R/Smoothing.R index 311095c..f1efa44 100644 --- a/R/Smoothing.R +++ b/R/Smoothing.R @@ -45,7 +45,7 @@ Smoothing <- function(data, time_dim = 'ftime', runmeanlen = 12, ncores = NULL) dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -62,12 +62,12 @@ Smoothing <- function(data, time_dim = 'ftime', runmeanlen = 12, ncores = NULL) } time_dim_length <- dim(data)[which(names(dim(data)) == time_dim)] if (runmeanlen >= time_dim_length & time_dim_length %% 2 == 0) { - stop(paste0("Parameter 'runmeanlen' must be within [1, ", time_dim_length - 1, - "].")) + stop("Parameter 'runmeanlen' must be within [1, ", time_dim_length - 1, + "].") } if (runmeanlen > time_dim_length & time_dim_length %% 2 != 0) { - stop(paste0("Parameter 'runmeanlen' must be within [1, ", time_dim_length, - "].")) + stop("Parameter 'runmeanlen' must be within [1, ", time_dim_length, + "].") } ## ncores if (!is.null(ncores)) { diff --git a/R/Spectrum.R b/R/Spectrum.R index 72cbd68..f336085 100644 --- a/R/Spectrum.R +++ b/R/Spectrum.R @@ -59,7 +59,7 @@ Spectrum <- function(data, time_dim = 'ftime', alpha = 0.05, ncores = NULL) { dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -118,7 +118,7 @@ Spectrum <- function(data, time_dim = 'ftime', alpha = 0.05, ncores = NULL) { toto2 <- spectrum(toto, plot = FALSE) store[jt, ] <- toto2$spec } - for (jx in 1:length(tmp$spec)) { + for (jx in seq_along(tmp$spec)) { output[jx, 3] <- quantile(store[, jx], 1 - alpha) } } else { diff --git a/R/Spread.R b/R/Spread.R index 1a60181..88ead15 100644 --- a/R/Spread.R +++ b/R/Spread.R @@ -97,14 +97,14 @@ Spread <- function(data, compute_dim = 'member', na.rm = TRUE, dim(data) <- c(length(data)) names(dim(data)) <- compute_dim[1] } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## compute_dim if (!is.character(compute_dim)) { stop("Parameter 'compute_dim' must be a character vector.") } - if (any(!compute_dim %in% names(dim(data)))) { + if (!all(compute_dim %in% names(dim(data)))) { stop("Parameter 'compute_dim' has some element not in 'data' dimension names.") } ## na.rm diff --git a/R/StatSeasAtlHurr.R b/R/StatSeasAtlHurr.R index a125f7f..5f94d5c 100644 --- a/R/StatSeasAtlHurr.R +++ b/R/StatSeasAtlHurr.R @@ -70,19 +70,19 @@ StatSeasAtlHurr <- function(atlano, tropano, hrvar = "HR", ncores = NULL) { dim(tropano) <- c(length(tropano)) names(dim(tropano)) <- 'dim1' } - if(any(is.null(names(dim(atlano)))) | any(nchar(names(dim(atlano))) == 0) | - any(is.null(names(dim(tropano)))) | any(nchar(names(dim(tropano))) == 0)) { + if (any(is.null(names(dim(atlano)))) | any(nchar(names(dim(atlano))) == 0) | + any(is.null(names(dim(tropano)))) | any(nchar(names(dim(tropano))) == 0)) { stop("Parameter 'atlano' and 'tropano' must have dimension names.") } - if(!all(names(dim(atlano)) %in% names(dim(tropano))) | - !all(names(dim(tropano)) %in% names(dim(atlano)))) { + if (!all(names(dim(atlano)) %in% names(dim(tropano))) | + !all(names(dim(tropano)) %in% names(dim(atlano)))) { stop("Parameter 'atlano' and 'tropano' must have same dimension names.") } name_1 <- sort(names(dim(atlano))) name_2 <- sort(names(dim(tropano))) if (!all(dim(atlano)[name_1] == dim(tropano)[name_2])) { - stop(paste0("Parameter 'atlano' and 'tropano' must have the same length of ", - "all the dimensions.")) + stop("Parameter 'atlano' and 'tropano' must have the same length of ", + "all the dimensions.") } ## hrvar if (hrvar != "HR" & hrvar != "TC" & hrvar != "PDI") { diff --git a/R/TPI.R b/R/TPI.R index 167664f..ab5f708 100644 --- a/R/TPI.R +++ b/R/TPI.R @@ -121,13 +121,13 @@ TPI <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo stop("Parameter 'lon_dim' is not found in 'data' dimension.") } # data_lats and data_lons part2 - if (dim(data)[lat_dim] != length(data_lats)){ - stop(paste0("The latitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lats'.")) + if (dim(data)[lat_dim] != length(data_lats)) { + stop("The latitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lats'.") } - if (dim(data)[lon_dim] != length(data_lons)){ - stop(paste0("The longitude dimension of parameter 'data' must be the same", - " length of parameter 'data_lons'.")) + if (dim(data)[lon_dim] != length(data_lons)) { + stop("The longitude dimension of parameter 'data' must be the same", + " length of parameter 'data_lons'.") } # ncores if (!is.null(ncores)) { @@ -138,20 +138,20 @@ TPI <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } # mask if (!is.null(mask)) { - if (is.array(mask) & identical(names(dim(mask)), c(lat_dim,lon_dim)) & + if (is.array(mask) & identical(names(dim(mask)), c(lat_dim, lon_dim)) & identical(as.integer(dim(mask)), c(length(data_lats), length(data_lons)))) { ## To mask those grid point that are missing in the observations mask <- s2dv::Reorder(data = mask, order = c(lat_dim, lon_dim)) - fun_mask <- function(data, mask){ + fun_mask <- function(data, mask) { data[mask == 0] <- NA return(data) } data <- multiApply::Apply(data = data, target_dims = c(lat_dim, lon_dim), fun = fun_mask, mask = mask, ncores = ncores)$output1 } else { - stop(paste0("Parameter 'mask' must be NULL (no mask) or a numerical array ", - "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", - "points that have to be masked.")) + stop("Parameter 'mask' must be NULL (no mask) or a numerical array ", + "with c(lat_dim, lon_dim) dimensions and 0 in those grid ", + "points that have to be masked.") } } # monini @@ -183,9 +183,9 @@ TPI <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo if (!is.null(indices_for_clim)) { if (!(inherits(indices_for_clim, 'numeric') | inherits(indices_for_clim, 'integer')) & !(is.logical(indices_for_clim) & !any(indices_for_clim))) { - stop(paste0("The parameter 'indices_for_clim' must be a numeric vector ", - "or NULL to compute the anomalies based on the whole period, ", - "or FALSE if data are already anomalies")) + stop("The parameter 'indices_for_clim' must be a numeric vector ", + "or NULL to compute the anomalies based on the whole period, ", + "or FALSE if data are already anomalies") } } # year_dim @@ -207,7 +207,7 @@ TPI <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } } # na.rm - if (!na.rm %in% c(TRUE,FALSE)) { + if (!na.rm %in% c(TRUE, FALSE)) { stop("Parameter 'na.rm' must be TRUE or FALSE") } @@ -240,11 +240,12 @@ TPI <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo weights = NULL, operation = 'mean') data <- ClimProjDiags::CombineIndices(indices = list(mean_2, mean_1_3), - weights = NULL, operation = 'subtract') # mean_2 - ((mean_1 + mean_3)/2) + weights = NULL, operation = 'subtract') + # mean_2 - ((mean_1 + mean_3)/2) - if (type == 'dcpp'){ + if (type == 'dcpp') { target_dims <- c(sdate_dim, fmonth_dim) - } else if (type %in% c('hist','obs')){ + } else if (type %in% c('hist', 'obs')) { target_dims <- c(year_dim, month_dim) } diff --git a/R/Trend.R b/R/Trend.R index d1af5ed..cb5183c 100644 --- a/R/Trend.R +++ b/R/Trend.R @@ -89,7 +89,7 @@ Trend <- function(data, time_dim = 'ftime', interval = 1, polydeg = 1, alpha = 0 dim(data) <- c(length(data)) names(dim(data)) <- time_dim } - if(any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { + if (any(is.null(names(dim(data)))) | any(nchar(names(dim(data))) == 0)) { stop("Parameter 'data' must have dimension names.") } ## time_dim @@ -163,7 +163,7 @@ Trend <- function(data, time_dim = 'ftime', interval = 1, polydeg = 1, alpha = 0 mon <- seq(x) * interval # remove NAs for potential poly() - NApos <- 1:length(x) + NApos <- seq_along(x) NApos[which(is.na(x))] <- NA x2 <- x[!is.na(NApos)] mon2 <- mon[!is.na(NApos)] @@ -184,7 +184,7 @@ Trend <- function(data, time_dim = 'ftime', interval = 1, polydeg = 1, alpha = 0 if (sign) signif <- !is.na(p.value) & p.value <= alpha } - detrended <- c() + detrended <- NULL detrended[is.na(x) == FALSE] <- x[is.na(x) == FALSE] - lm.out$fitted.values } else { diff --git a/R/UltimateBrier.R b/R/UltimateBrier.R index 3a6ca92..7ec4243 100644 --- a/R/UltimateBrier.R +++ b/R/UltimateBrier.R @@ -98,8 +98,8 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di if (!is.numeric(exp) | !is.numeric(obs)) { stop("Parameter 'exp' and 'obs' must be a vector or a numeric array.") } - if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | - any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + if (any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'exp' and 'obs' must have dimension names.") } ## dat_dim @@ -140,12 +140,12 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di name_exp <- name_exp[-which(name_exp == dat_dim)] name_obs <- name_obs[-which(name_obs == dat_dim)] if (any(name_exp != name_obs)) { - stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions except 'dat_dim' and 'memb_dim'.") } if (!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", - "of all the dimensions except 'dat_dim' and 'memb_dim'.")) + stop("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions except 'dat_dim' and 'memb_dim'.") } ## quantile if (!is.logical(quantile) | length(quantile) > 1) { @@ -164,8 +164,10 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di stop("Parameter 'quantile' must be TRUE if 'type' is 'FairEnsembleBSS' or 'FairEnsembleBS'.") } ## type - if (!(type %in% c("BS", "BSS", "FairEnsembleBS", "FairEnsembleBSS", "FairStartDatesBS", "FairStartDatesBSS"))) { - stop("Parameter 'type' must be one of 'BS', 'BSS', 'FairEnsembleBS', 'FairEnsembleBSS', 'FairStartDatesBS' or 'FairStartDatesBSS'.") + if (!(type %in% c("BS", "BSS", "FairEnsembleBS", "FairEnsembleBSS", + "FairStartDatesBS", "FairStartDatesBSS"))) { + stop("Parameter 'type' must be one of 'BS', 'BSS', 'FairEnsembleBS', ", + "'FairEnsembleBSS', 'FairStartDatesBS' or 'FairStartDatesBSS'.") } ## decomposition if (!is.logical(decomposition) | length(decomposition) > 1) { @@ -243,15 +245,16 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di res <- array(dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]), bin = length(thr) + 1)) - for (n_exp in 1:dim(exp)[2]) { - for (n_obs in 1:dim(obs)[2]) { + for (n_exp in seq_len(dim(exp)[2])) { + for (n_obs in seq_len(dim(obs)[2])) { ens_ref <- matrix(obs[, n_obs, 1], size_ens_ref, size_ens_ref, byrow = TRUE) - for (n_thr in 1:length(c(thr, 1))) { + for (n_thr in seq_along(c(thr, 1))) { #NOTE: FairBreirSs is deprecated now. Should change to SkillScore (according to # SpecsVerification's documentation) - res[n_exp, n_obs, n_thr] <- SpecsVerification::FairBrierSs(exp[, n_exp, ] > c(thr, 1)[n_thr], - ens_ref > c(thr, 1)[n_thr], - obs[, n_obs, 1] > c(thr, 1)[n_thr])['skillscore'] + res[n_exp, n_obs, n_thr] <- + SpecsVerification::FairBrierSs(exp[, n_exp, ] > c(thr, 1)[n_thr], + ens_ref > c(thr, 1)[n_thr], + obs[, n_obs, 1] > c(thr, 1)[n_thr])['skillscore'] } } } @@ -261,7 +264,8 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di } else if (type == 'FairEnsembleBS') { #NOTE: The calculation in s2dverification::UltimateBrier is wrong. In the final stage, - # the function calculates like "take(result, 3, 1) - take(result, 3, 2) + take(result, 3, 3)", + # the function calculates like + # "take(result, 3, 1) - take(result, 3, 2) + take(result, 3, 3)", # but the 3rd dim of result is 'bins' instead of decomposition. 'FairEnsembleBS' does # not have decomposition. # The calculation is fixed here. @@ -272,9 +276,9 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di res <- array(dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]), bin = length(thr) + 1)) - for (n_exp in 1:dim(exp)[2]) { - for (n_obs in 1:dim(obs)[2]) { - for (n_thr in 1:length(c(thr, 1))) { + for (n_exp in seq_len(dim(exp)[2])) { + for (n_obs in seq_len(dim(obs)[2])) { + for (n_thr in seq_along(c(thr, 1))) { fb <- SpecsVerification::FairBrier(ens = exp[, n_exp, ] > c(thr, 1)[n_thr], obs = obs[, n_obs, 1] > c(thr, 1)[n_thr]) res[n_exp, n_obs, n_thr] <- mean(fb, na.rm = T) @@ -295,8 +299,8 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di comp <- array(dim = c(nexp = as.numeric(dim(exp)[2]), nobs = as.numeric(dim(obs)[2]), comp = 3)) - for (n_exp in 1:dim(exp)[2]) { - for (n_obs in 1:dim(obs)[2]) { + for (n_exp in seq_len(dim(exp)[2])) { + for (n_obs in seq_len(dim(obs)[2])) { #NOTE: Parameter 'bins' is default. comp[n_exp, n_obs, ] <- SpecsVerification::BrierDecomp(p = exp[, n_exp], y = obs[, n_obs])[1, ] diff --git a/R/Utils.R b/R/Utils.R index ffee809..3b59d7a 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -8,7 +8,8 @@ ifelse(x > 0 && attributes(x)$match.length == nchar(name), TRUE, FALSE) } -.ConfigReplaceVariablesInString <- function(string, replace_values, allow_undefined_key_vars = FALSE) { +.ConfigReplaceVariablesInString <- function(string, replace_values, + allow_undefined_key_vars = FALSE) { # This function replaces all the occurrences of a variable in a string by # their corresponding string stored in the replace_values. if (length(strsplit(string, "\\$")[[1]]) > 1) { @@ -20,11 +21,15 @@ output <- paste(output, part, sep = "") } else { if (part %in% names(replace_values)) { - output <- paste(output, .ConfigReplaceVariablesInString(replace_values[[part]], replace_values, allow_undefined_key_vars), sep = "") + output <- paste(output, + .ConfigReplaceVariablesInString(replace_values[[part]], + replace_values, + allow_undefined_key_vars), sep = "") } else if (allow_undefined_key_vars) { output <- paste0(output, "$", part, "$") } else { - stop(paste('Error: The variable $', part, '$ was not defined in the configuration file.', sep = '')) + stop('Error: The variable $', part, + '$ was not defined in the configuration file.', sep = '') } } i <- i + 1 @@ -37,10 +42,12 @@ .KnownLonNames <- function() { known_lon_names <- c('lon', 'longitude', 'x', 'i', 'nav_lon') + return(known_lon_names) } .KnownLatNames <- function() { known_lat_names <- c('lat', 'latitude', 'y', 'j', 'nav_lat') + return(known_lat_names) } .t2nlatlon <- function(t) { @@ -70,7 +77,8 @@ } else { nlons <- nlons + 2 if (nlons > 9999) { - stop("Error: pick another gaussian grid truncation. It doesn't fulfill the standards to apply FFT.") + stop("Error: pick another gaussian grid truncation. ", + "It doesn't fulfill the standards to apply FFT.") } } } @@ -95,8 +103,8 @@ position <- 1 dims <- rev(dims) indices <- rev(indices) - for (i in 1:length(indices)) { - position <- position + (indices[i] - 1) * prod(dims[-c(1:i)]) + for (i in seq_along(indices)) { + position <- position + (indices[i] - 1) * prod(dims[-(1:i)]) } position } @@ -145,7 +153,7 @@ # But first we open the file and work out whether the requested variable is 2d fnc <- nc_open(filein) if (!(namevar %in% names(fnc$var))) { - stop(paste("Error: The variable", namevar, "is not defined in the file", filename)) + stop("Error: The variable", namevar, "is not defined in the file", filename) } var_long_name <- fnc$var[[namevar]]$longname units <- fnc$var[[namevar]]$units @@ -175,9 +183,12 @@ stop("Error: CDO libraries not available") } - cdo_version <- strsplit(suppressWarnings(system2("cdo", args = '-V', stderr = TRUE))[[1]], ' ')[[1]][5] + cdo_version <- + strsplit(suppressWarnings( + system2("cdo", args = '-V', stderr = TRUE))[[1]], ' ')[[1]][5] - cdo_version <- as.numeric_version(unlist(strsplit(cdo_version, "[A-Za-z]", fixed = FALSE))[[1]]) + cdo_version <- + as.numeric_version(unlist(strsplit(cdo_version, "[A-Za-z]", fixed = FALSE))[[1]]) } # If the variable to load is 2-d, we need to determine whether: @@ -200,8 +211,9 @@ } grids_first_lines <- grids_positions + 2 grids_last_lines <- c((grids_positions - 2)[-1], length(file_info)) - grids_info <- as.list(1:length(grids_positions)) - grids_info <- lapply(grids_info, function (x) file_info[grids_first_lines[x]:grids_last_lines[x]]) + grids_info <- as.list(seq_along(grids_positions)) + grids_info <- lapply(grids_info, + function (x) file_info[grids_first_lines[x]:grids_last_lines[x]]) grids_info <- lapply(grids_info, function (x) gsub(" *", " ", x)) grids_info <- lapply(grids_info, function (x) gsub("^ | $", "", x)) grids_info <- lapply(grids_info, function (x) unlist(strsplit(x, " | = "))) @@ -239,7 +251,9 @@ grids_info[which(grids_matches)][[1]])))) { grid_type <- grids_types[which(grids_matches)][1] } else { - stop("Error: Load() can't disambiguate: More than one lonlat/gaussian grids with the same size as the requested variable defined in ", filename) + stop("Error: Load() can't disambiguate: ", + "More than one lonlat/gaussian grids with the same size as ", + "the requested variable defined in ", filename) } } else if (sum(grids_matches) == 1) { grid_type <- grids_types[which(grids_matches)] @@ -318,11 +332,20 @@ } .warning(paste0("The dataset with index ", tail(work_piece[['indices']], 1), " in '", - work_piece[['dataset_type']], "' doesn't start at longitude 0 and will be re-interpolated in order to align its longitudes with the standard CDO grids definable with the names 'tgrid' or 'rx', which are by definition starting at the longitude 0.\n")) + work_piece[['dataset_type']], + "' doesn't start at longitude 0 and will be re-interpolated in order ", + "to align its longitudes with the standard CDO grids definable with ", + "the names 'tgrid' or 'rx', which are by definition ", + "starting at the longitude 0.\n")) if (!is.null(mask)) { .warning(paste0("A mask was provided for the dataset with index ", tail(work_piece[['indices']], 1), " in '", - work_piece[['dataset_type']], "'. This dataset has been re-interpolated to align its longitudes to start at 0. You must re-interpolate the corresponding mask to align its longitudes to start at 0 as well, if you haven't done so yet. Running cdo remapcon,", common_grid_name, " original_mask_file.nc new_mask_file.nc will fix it.\n")) + work_piece[['dataset_type']], + "'. This dataset has been re-interpolated to align its longitudes to ", + "start at 0. You must re-interpolate the corresponding mask to align ", + "its longitudes to start at 0 as well, if you haven't done so yet. ", + "Running cdo remapcon,", common_grid_name, + " original_mask_file.nc new_mask_file.nc will fix it.\n")) } } if (remap_needed && (grid_lons < common_grid_lons || grid_lats < common_grid_lats)) { @@ -404,7 +427,7 @@ ###mask_file <- tempfile(pattern = 'loadMask', fileext = '.nc') if (is.list(mask)) { if (!file.exists(mask[['path']])) { - stop(paste("Error: Couldn't find the mask file", mask[['path']])) + stop("Error: Couldn't find the mask file", mask[['path']]) } mask_file <- mask[['path']] ###file.copy(work_piece[['mask']][['path']], mask_file) @@ -413,26 +436,29 @@ if ('nc_var_name' %in% names(mask)) { if (!(mask[['nc_var_name']] %in% vars_in_mask)) { - stop(paste("Error: couldn't find variable", mask[['nc_var_name']], - "in the mask file", mask[['path']])) + stop("Error: couldn't find variable", mask[['nc_var_name']], + "in the mask file", mask[['path']]) } } else { if (length(vars_in_mask) != 1) { - stop(paste("Error: one and only one non-coordinate variable should be defined in the mask file", - mask[['path']], "if the component 'nc_var_name' is not specified. Currently found: ", - paste(vars_in_mask, collapse = ', '), ".")) + stop("Error: one and only one non-coordinate variable should be ", + "defined in the mask file", + mask[['path']], + "if the component 'nc_var_name' is not specified. ", + "Currently found: ", + paste(vars_in_mask, collapse = ', '), ".") } else { mask[['nc_var_name']] <- vars_in_mask } } if (sum(fnc_mask$var[[mask[['nc_var_name']]]]$size > 1) != 2) { - stop(paste0("Error: the variable '", + stop("Error: the variable '", mask[['nc_var_name']], "' must be defined only over the dimensions '", work_piece[['dimnames']][['lon']], "' and '", work_piece[['dimnames']][['lat']], "' in the mask file ", - mask[['path']])) + mask[['path']]) } mask <- ncvar_get(fnc_mask, mask[['nc_var_name']], collapse_degen = TRUE) nc_close(fnc_mask) @@ -454,16 +480,28 @@ ### Now ready to check that the mask is right ##if (!(lonlat_subsetting_requested && remap_needed)) { ### if ((dim(mask)[2] != length(lon)) || (dim(mask)[1] != length(lat))) { - ### stop(paste("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is wrong. It must be on the common grid if the selected output type is 'lonlat', 'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on the grid of the corresponding dataset if the selected output type is 'areave' and no 'grid' has been specified. For more information check ?Load and see help on parameters 'grid', 'maskmod' and 'maskobs'.", sep = "")) + ### stop(paste("Error: the mask of the dataset with index ", + ### tail(work_piece[['indices']], 1), " in '", + ### work_piece[['dataset_type']], "' is wrong. ", + ### "It must be on the common grid if the selected output type is 'lonlat', ", + ### "'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on ", + ### "the grid of the corresponding dataset if the selected output type is ", + ### "'areave' and no 'grid' has been specified. For more information ", + ### "check ?Load and see help on parameters 'grid', 'maskmod' and ", + ### "'maskobs'.", sep = "")) ### } - ###if (!(identical(mask_lon, lon) && identical(mask_lat, lat))) { - ### stop(paste0("Error: the longitudes and latitudes in the masks must be identical to the ones in the corresponding data files if output = 'areave' or, if the selected output is 'lon', 'lat' or 'lonlat', the longitudes in the mask file must start by 0 and the latitudes must be ordered from highest to lowest. See\n ", - ### work_piece[['mask']][['path']], " and ", filein)) - ###} + ###if (!(identical(mask_lon, lon) && identical(mask_lat, lat))) { + ### stop(paste0("Error: the longitudes and latitudes in the masks must be ", + ### "identical to the ones in the corresponding data files if output = 'areave' ", + ### " or, if the selected output is 'lon', 'lat' or 'lonlat', the longitudes in ", + ### "the mask file must start by 0 and the latitudes must be ordered from ", + ### "highest to lowest. See\n ", + ### work_piece[['mask']][['path']], " and ", filein)) + ###} } } - lon_indices <- 1:length(lon) + lon_indices <- seq_along(lon) if (!(lonlat_subsetting_requested && remap_needed)) { lon[which(lon < 0)] <- lon[which(lon < 0)] + 360 } @@ -478,11 +516,17 @@ ## always the latitudes are reordered. ## TODO: This could be avoided in future. if (lat[1] < lat[length(lat)]) { - lat_indices <- lat_indices[length(lat_indices):1] + lat_indices <- lat_indices[rev(seq_along(lat_indices))] } if (!is.null(mask) && !(lonlat_subsetting_requested && remap_needed)) { if ((dim(mask)[1] != length(lon)) || (dim(mask)[2] != length(lat))) { - stop(paste("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is wrong. It must be on the common grid if the selected output type is 'lonlat', 'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on the grid of the corresponding dataset if the selected output type is 'areave' and no 'grid' has been specified. For more information check ?Load and see help on parameters 'grid', 'maskmod' and 'maskobs'.", sep = "")) + stop("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), + " in '", work_piece[['dataset_type']], "' is wrong. It must be on the ", + "common grid if the selected output type is 'lonlat', 'lon' or 'lat', ", + "or 'areave' and 'grid' has been specified. It must be on the grid of ", + "the corresponding dataset if the selected output type is 'areave' and ", + "no 'grid' has been specified. For more information check ?Load and see ", + "help on parameters 'grid', 'maskmod' and 'maskobs'.") } mask <- mask[lon_indices, lat_indices] } @@ -495,15 +539,17 @@ ## if the requested number of points goes beyond the left or right ## sides of the map, we need to take the entire map so that the ## interpolation works properly - lon_indices <- 1:length(lon) + lon_indices <- seq_along(lon) } else { extra_points <- min(maximum_extra_points, head(lon_indices, 1) - 1) if (extra_points > 0) { - lon_indices <- c((head(lon_indices, 1) - extra_points):(head(lon_indices, 1) - 1), lon_indices) + lon_indices <- + c((head(lon_indices, 1) - extra_points):(head(lon_indices, 1) - 1), lon_indices) } extra_points <- min(maximum_extra_points, length(lon) - tail(lon_indices, 1)) if (extra_points > 0) { - lon_indices <- c(lon_indices, (tail(lon_indices, 1) + 1):(tail(lon_indices, 1) + extra_points)) + lon_indices <- c(lon_indices, + (tail(lon_indices, 1) + 1):(tail(lon_indices, 1) + extra_points)) } } min_lat_ind <- min(lat_indices) @@ -543,7 +589,8 @@ work_piece[['dimnames']][['member']] <- 'lev' } if (work_piece[['dimnames']][['member']] %in% var_dimnames) { - nmemb <- fnc$var[[namevar]][['dim']][[match(work_piece[['dimnames']][['member']], var_dimnames)]]$len + nmemb <- fnc$var[[namevar]][['dim']][[match(work_piece[['dimnames']][['member']], + var_dimnames)]]$len expected_dims <- c(expected_dims, work_piece[['dimnames']][['member']]) } else { nmemb <- 1 @@ -554,9 +601,9 @@ if (!is.null(old_members_dimname)) { expected_dims[which(expected_dims == 'lev')] <- old_members_dimname } - stop(paste("Error: the expected dimension(s)", - paste(expected_dims[which(is.na(dim_matches))], collapse = ', '), - "were not found in", filename)) + stop("Error: the expected dimension(s)", + paste(expected_dims[which(is.na(dim_matches))], collapse = ', '), + "were not found in", filename) } time_dimname <- var_dimnames[-dim_matches] } else { @@ -571,10 +618,13 @@ if (!is.null(old_members_dimname)) { expected_dims[which(expected_dims == 'lev')] <- old_members_dimname } - stop(paste("Error: the variable", namevar, - "is defined over more dimensions than the expected (", - paste(c(expected_dims, 'time'), collapse = ', '), - "). It could also be that the members, longitude or latitude dimensions are named incorrectly. In that case, either rename the dimensions in the file or adjust Load() to recognize the actual name with the parameter 'dimnames'. See file", filename)) + stop("Error: the variable ", namevar, + " is defined over more dimensions than the expected (", + paste(c(expected_dims, 'time'), collapse = ', '), + "). It could also be that the members, longitude or latitude ", + "dimensions are named incorrectly. In that case, either rename ", + "the dimensions in the file or adjust Load() to recognize the actual ", + "name with the parameter 'dimnames'. See file ", filename) } } else { nltime <- 1 @@ -588,7 +638,7 @@ # to regrid it and work out the number of longitudes and latitudes. # We don't need more. members <- 1 - ltimes_list <- list(c(1)) + ltimes_list <- list(1) } else { # The data is arranged in the array 'tmp' with the dimensions in a # common order: @@ -648,7 +698,7 @@ } final_dims <- c(length(subset_indices[[1]]), length(subset_indices[[2]]), 1, 1) } else { - start <- end <- c() + start <- end <- NULL subset_indices <- list() ncdf_dims <- list() final_dims <- c(1, 1, 1, 1) @@ -663,16 +713,17 @@ final_dims[3] <- length(members) } if (time_dimname %in% expected_dims) { - if (any(!is.na(ltimes))) { + if (!all(is.na(ltimes))) { start <- c(start, head(ltimes[which(!is.na(ltimes))], 1)) end <- c(end, tail(ltimes[which(!is.na(ltimes))], 1)) - subset_indices <- c(subset_indices, list(ltimes - head(ltimes[which(!is.na(ltimes))], 1) + 1)) + subset_indices <- c(subset_indices, + list(ltimes - head(ltimes[which(!is.na(ltimes))], 1) + 1)) } else { start <- c(start, NA) end <- c(end, NA) subset_indices <- c(subset_indices, list(ltimes)) } - dim_time <- ncdim_def(time_dimname, "", 1:length(ltimes), unlim = TRUE) + dim_time <- ncdim_def(time_dimname, "", seq_along(ltimes), unlim = TRUE) ncdf_dims <- c(ncdf_dims, list(dim_time)) final_dims[4] <- length(ltimes) } @@ -684,7 +735,7 @@ if (prod(final_dims) > 0) { tmp <- take(ncvar_get(fnc, namevar, start, count, collapse_degen = FALSE), - 1:length(subset_indices), subset_indices) + seq_along(subset_indices), subset_indices) # The data is regridded if it corresponds to an atmospheric variable. When # the chosen output type is 'areave' the data is not regridded to not # waste computing time unless the user specified a common grid. @@ -734,34 +785,37 @@ ## In principle cdo should put in order the longitudes ## and slice them properly unless data is across greenwich sub_lon[which(sub_lon < 0)] <- sub_lon[which(sub_lon < 0)] + 360 - sub_lon_indices <- 1:length(sub_lon) + sub_lon_indices <- seq_along(sub_lon) if (lonmax < lonmin) { sub_lon_indices <- sub_lon_indices[which((sub_lon <= lonmax) | (sub_lon >= lonmin))] } - sub_lat_indices <- 1:length(sub_lat) + sub_lat_indices <- seq_along(sub_lat) ## In principle cdo should put in order the latitudes if (sub_lat[1] < sub_lat[length(sub_lat)]) { - sub_lat_indices <- length(sub_lat):1 + sub_lat_indices <- rev(seq_along(sub_lat)) } final_dims[c(1, 2)] <- c(length(sub_lon_indices), length(sub_lat_indices)) subset_indices[[dim_matches[1]]] <- sub_lon_indices subset_indices[[dim_matches[2]]] <- sub_lat_indices tmp <- take(ncvar_get(fnc2, namevar, collapse_degen = FALSE), - 1:length(subset_indices), subset_indices) + seq_along(subset_indices), subset_indices) if (!is.null(mask)) { ## We create a very simple 2d netcdf file that is then interpolated to the common ## grid to know what are the lons and lats of our slice of data mask_file <- tempfile(pattern = 'loadMask', fileext = '.nc') mask_file_remap <- tempfile(pattern = 'loadMask', fileext = '.nc') - dim_longitudes <- ncdim_def(work_piece[['dimnames']][['lon']], "degrees_east", c(0, 360)) - dim_latitudes <- ncdim_def(work_piece[['dimnames']][['lat']], "degrees_north", c(-90, 90)) + dim_longitudes <- ncdim_def(work_piece[['dimnames']][['lon']], + "degrees_east", c(0, 360)) + dim_latitudes <- ncdim_def(work_piece[['dimnames']][['lat']], + "degrees_north", c(-90, 90)) ncdf_var <- ncvar_def('LSM', "", list(dim_longitudes, dim_latitudes), NA, 'double') fnc_mask <- nc_create(mask_file, list(ncdf_var)) ncvar_put(fnc_mask, ncdf_var, array(rep(0, 4), dim = c(2, 2))) nc_close(fnc_mask) - system(paste0("cdo -L -s remap", work_piece[['remap']], ",", common_grid_name, + system(paste0("cdo -L -s remap", work_piece[['remap']], ",", + common_grid_name, " ", mask_file, " ", mask_file_remap, " 2>/dev/null", sep = "")) fnc_mask <- nc_open(mask_file_remap) mask_lons <- ncvar_get(fnc_mask, 'lon') @@ -769,7 +823,16 @@ nc_close(fnc_mask) file.remove(mask_file, mask_file_remap) if ((dim(mask)[1] != common_grid_lons) || (dim(mask)[2] != common_grid_lats)) { - stop(paste("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is wrong. It must be on the common grid if the selected output type is 'lonlat', 'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on the grid of the corresponding dataset if the selected output type is 'areave' and no 'grid' has been specified. For more information check ?Load and see help on parameters 'grid', 'maskmod' and 'maskobs'.", sep = "")) + stop("Error: the mask of the dataset with index ", + tail(work_piece[['indices']], 1), " in '", + work_piece[['dataset_type']], + "' is wrong. It must be on the common grid if the ", + "selected output type is 'lonlat', 'lon' or 'lat', ", + "or 'areave' and 'grid' has been specified. It must ", + "be on the grid of the corresponding dataset if the ", + "selected output type is 'areave' and no 'grid' has been ", + "specified. For more information check ?Load and see help ", + "on parameters 'grid', 'maskmod' and 'maskobs'.") } mask_lons[which(mask_lons < 0)] <- mask_lons[which(mask_lons < 0)] + 360 if (lonmax >= lonmin) { @@ -779,7 +842,7 @@ } mask_lat_indices <- which((mask_lats >= latmin) & (mask_lats <= latmax)) if (sub_lat[1] < sub_lat[length(sub_lat)]) { - mask_lat_indices <- mask_lat_indices[length(mask_lat_indices):1] + mask_lat_indices <- mask_lat_indices[rev(seq_along(mask_lat_indices))] } mask <- mask[mask_lon_indices, mask_lat_indices] } @@ -801,9 +864,17 @@ } } if (!all(dim_matches == sort(dim_matches))) { - if (!found_disordered_dims && rev(work_piece[['indices']])[2] == 1 && rev(work_piece[['indices']])[3] == 1) { + if (!found_disordered_dims && + rev(work_piece[['indices']])[2] == 1 && + rev(work_piece[['indices']])[3] == 1) { found_disordered_dims <- TRUE - .warning(paste0("The dimensions for the variable ", namevar, " in the files of the experiment with index ", tail(work_piece[['indices']], 1), " are not in the optimal order for loading with Load(). The optimal order would be '", paste(expected_dims, collapse = ', '), "'. One of the files of the dataset is stored in ", filename)) + .warning(paste0("The dimensions for the variable ", namevar, + " in the files of the experiment with index ", + tail(work_piece[['indices']], 1), + " are not in the optimal order for loading with Load(). ", + "The optimal order would be '", + paste(expected_dims, collapse = ', '), + "'. One of the files of the dataset is stored in ", filename)) } tmp <- aperm(tmp, dim_matches) } @@ -846,13 +917,15 @@ } if (output == 'areave' || output == 'lon') { - weights <- InsertDim(cos(final_lats * pi / 180), 1, length(final_lons), name = 'lon') + weights <- InsertDim(cos(final_lats * pi / 180), 1, + length(final_lons), name = 'lon') weights[which(is.na(x))] <- NA if (output == 'areave') { weights <- weights / mean(weights, na.rm = TRUE) mean(x * weights, na.rm = TRUE) } else { - weights <- weights / InsertDim(MeanDims(weights, 2, na.rm = TRUE), 2, length(final_lats), name = 'lat') + weights <- weights / InsertDim(MeanDims(weights, 2, na.rm = TRUE), 2, + length(final_lats), name = 'lat') MeanDims(x * weights, 2, na.rm = TRUE) } } else if (output == 'lat') { @@ -920,7 +993,7 @@ ### foobar <- writeBin(work_piece[['progress_amount']], progress_connection) ###} if (!silent && !is.null(work_piece[['progress_amount']])) { - message(paste0(work_piece[['progress_amount']]), appendLF = FALSE) + message(work_piece[['progress_amount']], appendLF = FALSE) } found_file } @@ -957,8 +1030,7 @@ dataOut <- sampleData dataOut$mod <- sampleData$mod[, , selected_start_dates, selected_lead_times, , ] dataOut$obs <- sampleData$obs[, , selected_start_dates, selected_lead_times, , ] - } - else if (output == 'areave') { + } else if (output == 'areave') { sampleData <- s2dv::sampleTimeSeries if (is.null(leadtimemax)) { leadtimemax <- dim(sampleData$mod)[lead_times_position] @@ -992,7 +1064,10 @@ } else { id <- 'OBS' } - defaults <- c(paste0('$DEFAULT_', id, '_MAIN_PATH$'), paste0('$DEFAULT_', id, '_FILE_PATH$'), '$DEFAULT_NC_VAR_NAME$', '$DEFAULT_SUFFIX$', '$DEFAULT_VAR_MIN$', '$DEFAULT_VAR_MAX$') + defaults <- c(paste0('$DEFAULT_', id, '_MAIN_PATH$'), + paste0('$DEFAULT_', id, '_FILE_PATH$'), + '$DEFAULT_NC_VAR_NAME$', '$DEFAULT_SUFFIX$', + '$DEFAULT_VAR_MIN$', '$DEFAULT_VAR_MAX$') info <- NULL for (entry in matching_entries) { @@ -1042,7 +1117,7 @@ x <- gsub('\\\\', '', x) x <- gsub('\\^', '', x) x <- gsub('\\$', '', x) - x <- unname(sapply(strsplit(x, '[',fixed = TRUE)[[1]], function(y) gsub('.*]', '.', y))) + x <- unname(sapply(strsplit(x, '[', fixed = TRUE)[[1]], function(y) gsub('.*]', '.', y))) do.call(paste0, as.list(x)) } else { x @@ -1069,9 +1144,11 @@ right_known <- head(strsplit(file_name_with_globs, '*', fixed = TRUE)[[1]], 1) right_known_no_tags <- .ConfigReplaceVariablesInString(right_known, replace_values) path_with_globs_rx <- utils::glob2rx(paste0(path_with_globs, right_known_no_tags)) - match <- regexpr(gsub('$', '', path_with_globs_rx, fixed = TRUE), paste0(actual_path, file_name)) + match <- regexpr(gsub('$', '', path_with_globs_rx, fixed = TRUE), + paste0(actual_path, file_name)) if (match != 1) { - stop("Incorrect parameters to replace glob expressions. The path with expressions does not match the actual path.") + stop("Incorrect parameters to replace glob expressions. ", + "The path with expressions does not match the actual path.") } if (attr(match, 'match.length') - nchar(right_known_no_tags) < nchar(actual_path)) { path_with_globs <- paste0(path_with_globs, right_known_no_tags, '*') @@ -1079,32 +1156,41 @@ } } path_with_globs_rx <- utils::glob2rx(path_with_globs) - values_to_replace <- c() - tags_to_replace_starts <- c() - tags_to_replace_ends <- c() + values_to_replace <- NULL + tags_to_replace_starts <- NULL + tags_to_replace_ends <- NULL give_warning <- FALSE for (tag in tags_to_keep) { matches <- gregexpr(paste0('$', tag, '$'), path_with_globs_rx, fixed = TRUE)[[1]] lengths <- attr(matches, 'match.length') if (!(length(matches) == 1 && matches[1] == -1)) { - for (i in 1:length(matches)) { + for (i in seq_along(matches)) { left <- NULL if (matches[i] > 1) { - left <- .ConfigReplaceVariablesInString(substr(path_with_globs_rx, 1, matches[i] - 1), replace_values) - left_known <- strReverse(head(strsplit(strReverse(left), strReverse('.*'), fixed = TRUE)[[1]], 1)) + left <- + .ConfigReplaceVariablesInString(substr(path_with_globs_rx, 1, + matches[i] - 1), replace_values) + left_known <- + strReverse(head(strsplit(strReverse(left), + strReverse('.*'), fixed = TRUE)[[1]], 1)) } right <- NULL if ((matches[i] + lengths[i] - 1) < nchar(path_with_globs_rx)) { - right <- .ConfigReplaceVariablesInString(substr(path_with_globs_rx, matches[i] + lengths[i], nchar(path_with_globs_rx)), replace_values) + right <- + .ConfigReplaceVariablesInString(substr(path_with_globs_rx, + matches[i] + lengths[i], + nchar(path_with_globs_rx)), + replace_values) right_known <- head(strsplit(right, '.*', fixed = TRUE)[[1]], 1) } - final_match <- NULL match_limits <- NULL if (!is.null(left)) { left_match <- regexpr(paste0(left, replace_values[[tag]], right_known), actual_path) match_len <- attr(left_match, 'match.length') - left_match_limits <- c(left_match + match_len - 1 - nchar(clean(right_known)) - nchar(replace_values[[tag]]) + 1, - left_match + match_len - 1 - nchar(clean(right_known))) + left_match_limits <- + c(left_match + match_len - 1 - nchar(clean(right_known)) - + nchar(replace_values[[tag]]) + 1, + left_match + match_len - 1 - nchar(clean(right_known))) if (!(left_match < 1)) { match_limits <- left_match_limits } @@ -1113,8 +1199,10 @@ if (!is.null(right)) { right_match <- regexpr(paste0(left_known, replace_values[[tag]], right), actual_path) match_len <- attr(right_match, 'match.length') - right_match_limits <- c(right_match + nchar(clean(left_known)), - right_match + nchar(clean(left_known)) + nchar(replace_values[[tag]]) - 1) + right_match_limits <- + c(right_match + nchar(clean(left_known)), + right_match + nchar(clean(left_known)) + + nchar(replace_values[[tag]]) - 1) if (is.null(match_limits) && !(right_match < 1)) { match_limits <- right_match_limits } @@ -1143,8 +1231,11 @@ while (length(values_to_replace) > 0) { actual_path <- paste0(substr(actual_path, 1, head(tags_to_replace_starts, 1) - 1), '$', head(values_to_replace, 1), '$', - substr(actual_path, head(tags_to_replace_ends, 1) + 1, nchar(actual_path))) - extra_chars <- nchar(head(values_to_replace, 1)) + 2 - (head(tags_to_replace_ends, 1) - head(tags_to_replace_starts, 1) + 1) + substr(actual_path, head(tags_to_replace_ends, 1) + 1, + nchar(actual_path))) + extra_chars <- nchar(head(values_to_replace, 1)) + 2 - + (head(tags_to_replace_ends, 1) - + head(tags_to_replace_starts, 1) + 1) values_to_replace <- values_to_replace[-1] tags_to_replace_starts <- tags_to_replace_starts[-1] tags_to_replace_ends <- tags_to_replace_ends[-1] @@ -1155,7 +1246,8 @@ if (give_warning) { .warning(paste0("Too complex path pattern specified for ", dataset_name, - ". Double check carefully the '$Files' fetched for this dataset or specify a simpler path pattern.")) + ". Double check carefully the '$Files' fetched for this dataset ", + "or specify a simpler path pattern.")) } if (permissive) { @@ -1170,10 +1262,10 @@ path_with_globs_and_tag <- paste0('^', path_with_globs_and_tag, '$') parts <- strsplit(path_with_globs_and_tag, '*', fixed = TRUE)[[1]] parts <- as.list(parts[grep(tag, parts)]) - longest_couples <- c() - pos_longest_couples <- c() + longest_couples <- NULL + pos_longest_couples <- NULL found_value <- NULL - for (i in 1:length(parts)) { + for (i in seq_along(parts)) { parts[[i]] <- strsplit(parts[[i]], tag)[[1]] if (length(parts[[i]]) == 1) { parts[[i]] <- c(parts[[i]], '') @@ -1184,13 +1276,15 @@ longest_couples <- c(longest_couples, max(len_couples)) } chosen_part <- which.max(longest_couples) - parts[[chosen_part]] <- parts[[chosen_part]][pos_longest_couples[chosen_part]:(pos_longest_couples[chosen_part] + 1)] + parts[[chosen_part]] <- + parts[[chosen_part]][pos_longest_couples[chosen_part]:(pos_longest_couples[chosen_part] + 1)] if (nchar(parts[[chosen_part]][1]) >= nchar(parts[[chosen_part]][2])) { if (nchar(parts[[chosen_part]][1]) > 0) { matches <- gregexpr(parts[[chosen_part]][1], actual_path)[[1]] if (length(matches) == 1) { match_left <- matches - actual_path <- substr(actual_path, match_left + attr(match_left, 'match.length'), nchar(actual_path)) + actual_path <- + substr(actual_path, match_left + attr(match_left, 'match.length'), nchar(actual_path)) } } if (nchar(parts[[chosen_part]][2]) > 0) { @@ -1212,7 +1306,9 @@ matches <- gregexpr(parts[[chosen_part]][1], actual_path)[[1]] if (length(matches) == 1) { match_left <- matches - found_value <- substr(actual_path, match_left + attr(match_left, 'match.length'), nchar(actual_path)) + found_value <- + substr(actual_path, match_left + attr(match_left, 'match.length'), + nchar(actual_path)) } } } @@ -1292,7 +1388,9 @@ } # Change filenames when necessary if (any(ext != ext[1])) { - .warning(paste0("some extensions of the filenames provided in 'fileout' are not ", ext[1],". The extensions are being converted to ", ext[1], ".")) + .warning(paste0("some extensions of the filenames provided in 'fileout' ", + "are not ", ext[1], + ". The extensions are being converted to ", ext[1], ".")) fileout <- sub("\\.[a-zA-Z0-9]*$", ext[1], fileout) } } else { @@ -1359,9 +1457,9 @@ } args[["tag"]] <- NULL - message(paste0(tag, paste(strwrap( - args, indent = indent, exdent = exdent - ), collapse = collapse)), appendLF = appendLF, domain = domain) + tmp <- paste0(tag, + paste(strwrap(args, indent = indent, exdent = exdent), collapse = collapse)) + message(tmp, appendLF = appendLF, domain = domain) } .warning <- function(...) { @@ -1430,15 +1528,15 @@ } args[["tag"]] <- NULL - warning(paste0(tag, paste(strwrap( - args, indent = indent, exdent = exdent - ), collapse = collapse)), call. = call, immediate. = immediate, - noBreaks. = noBreaks, domain = domain) + tmp <- paste0(tag, + paste(strwrap(args, indent = indent, exdent = exdent), collapse = collapse)) + warning(tmp, call. = call, immediate. = immediate, + noBreaks. = noBreaks, domain = domain) } .IsColor <- function(x) { res <- try(col2rgb(x), silent = TRUE) - return(!"try-error" %in% class(res)) + return(!is(res, "try-error")) } # This function switches to a specified figure at position (row, col) in a layout. @@ -1502,7 +1600,7 @@ if (is.numeric(x)) { x <- aperm(x, new_order) } else { - y <- array(1:length(x), dim = dim(x)) + y <- array(seq_along(x), dim = dim(x)) y <- aperm(y, new_order) x <- x[as.vector(y)] } @@ -1521,8 +1619,8 @@ # the same name are found in the two inputs, and they have a different # length, the maximum is taken. .MergeArrayDims <- function(dims1, dims2) { - new_dims1 <- c() - new_dims2 <- c() + new_dims1 <- NULL + new_dims2 <- NULL while (length(dims1) > 0) { if (names(dims1)[1] %in% names(dims2)) { pos <- which(names(dims2) == names(dims1)[1]) @@ -1533,7 +1631,7 @@ new_dims1 <- c(new_dims1, dims_to_add, dims1[1]) new_dims2 <- c(new_dims2, dims2[1:pos]) dims1 <- dims1[-1] - dims2 <- dims2[-c(1:pos)] + dims2 <- dims2[-(1:pos)] } else { new_dims1 <- c(new_dims1, dims1[1]) new_dims2 <- c(new_dims2, 1) @@ -1569,7 +1667,7 @@ new_dims <- .MergeArrayDims(dim(array1), dim(array2)) dim(array1) <- new_dims[[1]] dim(array2) <- new_dims[[2]] - for (j in 1:length(dim(array1))) { + for (j in seq_along(dim(array1))) { if (names(dim(array1))[j] != along) { if (dim(array1)[j] != dim(array2)[j]) { if (which.max(c(dim(array1)[j], dim(array2)[j])) == 1) { @@ -1657,33 +1755,40 @@ last_years_for_clim <- n_sdates : (n_sdates - n_fyears + 1) } else { ## indices_for_clim specified as a numeric vector first_years_for_clim <- seq(from = indices_for_clim[1], by = -1, length.out = n_fyears) - last_years_for_clim <- seq(from = indices_for_clim[length(indices_for_clim)], by = -1, length.out = n_fyears) + last_years_for_clim <- + seq(from = indices_for_clim[length(indices_for_clim)], + by = -1, length.out = n_fyears) } data <- s2dv::Reorder(data = data, order = c(fyear_dim, sdate_dim)) anom <- array(data = NA, dim = dim(data)) for (i in 1:n_fyears) { - clim <- mean(data[i,first_years_for_clim[i]:last_years_for_clim[i]], na.rm = na.rm) - anom[i,] <- data[i,] - clim + clim <- mean(data[i, first_years_for_clim[i]:last_years_for_clim[i]], na.rm = na.rm) + anom[i, ] <- data[i, ] - clim } } - } else if (type %in% c('obs','hist')) { + } else if (type %in% c('obs', 'hist')) { - data <- multiApply::Apply(data = data, target_dims = month_dim, fun = mean, na.rm = na.rm)$output1 + data <- multiApply::Apply(data = data, target_dims = month_dim, + fun = mean, na.rm = na.rm)$output1 if (identical(indices_for_clim, FALSE)) { ## data is already anomalies clim <- 0 - } else if (is.null(indices_for_clim)) { ## climatology over the whole period + } else if (is.null(indices_for_clim)) { + ## climatology over the whole period clim <- multiApply::Apply(data = data, target_dims = year_dim, fun = mean, na.rm = na.rm)$output1 - } else { ## indices_for_clim specified as a numeric vector + } else { + ## indices_for_clim specified as a numeric vector clim <- multiApply::Apply(data = ClimProjDiags::Subset(x = data, along = year_dim, indices = indices_for_clim), target_dims = year_dim, fun = mean, na.rm = na.rm)$output1 } anom <- data - clim - } else {stop('type must be dcpp, hist or obs')} + } else { + stop('type must be dcpp, hist or obs') + } return(anom) } @@ -1698,7 +1803,8 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE bar_limits, var_limits = NULL, triangle_ends = NULL, plot = TRUE, draw_separators = FALSE, - bar_titles = NULL, title_scale = 1, label_scale = 1, extra_margin = rep(0, 4), + bar_titles = NULL, title_scale = 1, + label_scale = 1, extra_margin = rep(0, 4), ...) { # bar_limits if (!is.numeric(bar_limits) || length(bar_limits) != 2) { @@ -1727,7 +1833,7 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE chosen_sets <- 1:nmap chosen_sets <- chosen_sets + floor((length(col_sets) - length(chosen_sets)) / 2) } else { - chosen_sets <- array(1:length(col_sets), nmap) + chosen_sets <- array(seq_along(col_sets), nmap) } cols <- col_sets[chosen_sets] } else { @@ -1742,7 +1848,7 @@ GradientCatsColorBar <- function(nmap, brks = NULL, cols = NULL, vertical = TRUE "maps in 'maps'.") } } - for (i in 1:length(cols)) { + for (i in seq_along(cols)) { if (length(cols[[i]]) != (length(brks) - 1)) { cols[[i]] <- grDevices::colorRampPalette(cols[[i]])(length(brks) - 1) } diff --git a/man/ACC.Rd b/man/ACC.Rd index e1a8fb2..f733f74 100644 --- a/man/ACC.Rd +++ b/man/ACC.Rd @@ -2,7 +2,8 @@ % Please edit documentation in R/ACC.R \name{ACC} \alias{ACC} -\title{Compute the spatial anomaly correlation coefficient between the forecast and corresponding observation} +\title{Compute the spatial anomaly correlation coefficient between the forecast and +corresponding observation} \usage{ ACC( exp, diff --git a/man/Clim.Rd b/man/Clim.Rd index a5a6f19..c3bd96f 100644 --- a/man/Clim.Rd +++ b/man/Clim.Rd @@ -74,7 +74,8 @@ A list of 2: This function computes per-pair climatologies for the experimental and observational data using one of the following methods: \enumerate{ - \item{per-pair method (Garcia-Serrano and Doblas-Reyes, CD, 2012 https://doi.org/10.1007/s00382-012-1413-1)} + \item{per-pair method (Garcia-Serrano and Doblas-Reyes, CD, 2012 + https://doi.org/10.1007/s00382-012-1413-1)} \item{Kharin method (Kharin et al, GRL, 2012 https://doi.org/10.1029/2012GL052647)} \item{Fuckar method (Fuckar et al, GRL, 2014 https://doi.org/10.1002/2014GL060815)} } diff --git a/man/Corr.Rd b/man/Corr.Rd index 9fc2d31..38d5c64 100644 --- a/man/Corr.Rd +++ b/man/Corr.Rd @@ -2,7 +2,8 @@ % Please edit documentation in R/Corr.R \name{Corr} \alias{Corr} -\title{Compute the correlation coefficient between an array of forecast and their corresponding observation} +\title{Compute the correlation coefficient between an array of forecast and their +corresponding observation} \usage{ Corr( exp, diff --git a/man/MSE.Rd b/man/MSE.Rd index cd58402..ded3c24 100644 --- a/man/MSE.Rd +++ b/man/MSE.Rd @@ -18,7 +18,8 @@ MSE( ) } \arguments{ -\item{exp}{A named numeric array of experimental data, with at least #' 'time_dim' dimension. It can also be a vector with the same length as 'obs'.} +\item{exp}{A named numeric array of experimental data, with at least +'time_dim' dimension. It can also be a vector with the same length as 'obs'.} \item{obs}{A named numeric array of observational data, same dimensions as parameter 'exp' except along 'dat_dim' and 'memb_dim'. It can also be a diff --git a/man/Persistence.Rd b/man/Persistence.Rd index 9b09ac3..5ce2b5e 100644 --- a/man/Persistence.Rd +++ b/man/Persistence.Rd @@ -7,11 +7,11 @@ Persistence( data, dates, - time_dim = "time", start, end, ft_start, ft_end = ft_start, + time_dim = "time", max_ft = 10, nmemb = 1, na.action = 10, @@ -27,9 +27,6 @@ The data should start at least 40 time steps (years or days) before \item{dates}{A sequence of 4-digit integers (YYYY) or string (YYYY-MM-DD) in class 'Date' indicating the dates available in the observations.} -\item{time_dim}{A character string indicating the dimension along which to -compute the autoregression. The default value is 'time'.} - \item{start}{A 4-digit integer (YYYY) or a string (YYYY-MM-DD) in class 'Date' indicating the first start date of the persistence forecast. It must be between 1850 and 2020.} @@ -47,6 +44,9 @@ average forecast times for which persistence should be calculated in the case of a multi-timestep average persistence. The default value is 'ft_start'.} +\item{time_dim}{A character string indicating the dimension along which to +compute the autoregression. The default value is 'time'.} + \item{max_ft}{An integer indicating the maximum forecast time possible for 'data'. For example, for decadal prediction 'max_ft' would correspond to 10 (years). The default value is 10.} diff --git a/man/RatioRMS.Rd b/man/RatioRMS.Rd index 3330eb5..4e834ad 100644 --- a/man/RatioRMS.Rd +++ b/man/RatioRMS.Rd @@ -69,8 +69,10 @@ ano_obs <- Ano(sampleData$obs, clim$clim_obs) # time step. ano_exp_1 <- ClimProjDiags::Subset(ano_exp, 'member', c(1, 2)) ano_exp_2 <- ClimProjDiags::Subset(ano_exp, 'member', c(3)) -ano_exp_1 <- ClimProjDiags::Subset(ano_exp_1, c('dataset', 'ftime'), list(1, 1), drop = 'selected') -ano_exp_2 <- ClimProjDiags::Subset(ano_exp_2, c('dataset', 'ftime'), list(1, 1), drop = 'selected') +ano_exp_1 <- ClimProjDiags::Subset(ano_exp_1, c('dataset', 'ftime'), + list(1, 1), drop = 'selected') +ano_exp_2 <- ClimProjDiags::Subset(ano_exp_2, c('dataset', 'ftime'), + list(1, 1), drop = 'selected') ano_obs <- ClimProjDiags::Subset(ano_obs, c('dataset', 'ftime'), list(1, 1), drop = 'selected') # Compute ensemble mean and provide as inputs to RatioRMS. rrms <- RatioRMS(MeanDims(ano_exp_1, 'member'), diff --git a/man/Season.Rd b/man/Season.Rd index fccd9ff..60fbbbc 100644 --- a/man/Season.Rd +++ b/man/Season.Rd @@ -6,10 +6,10 @@ \usage{ Season( data, - time_dim = "ftime", monini, moninf, monsup, + time_dim = "ftime", method = mean, na.rm = TRUE, ncores = NULL @@ -18,10 +18,6 @@ Season( \arguments{ \item{data}{A named numeric array with at least one dimension 'time_dim'.} -\item{time_dim}{A character string indicating the name of dimension along -which the seasonal mean or other calculations are computed. The default -value is 'ftime'.} - \item{monini}{An integer indicating what the first month of the time series is. It can be from 1 to 12.} @@ -31,6 +27,10 @@ calculation. It can be from 1 to 12.} \item{monsup}{An integer indicating the end month of the seasonal calculation. It can be from 1 to 12.} +\item{time_dim}{A character string indicating the name of dimension along +which the seasonal mean or other calculations are computed. The default +value is 'ftime'.} + \item{method}{An R function to be applied for seasonal calculation. For example, 'sum' can be used for total precipitation. The default value is mean.} -- GitLab From 142fe17d9b4b2fd2304eda59b4839cfca604c822 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 13 Nov 2023 18:20:05 +0100 Subject: [PATCH 08/11] Fix remaining lint findings --- .lintr | 9 +++++---- R/AMV.R | 2 +- R/CDORemap.R | 4 ++-- R/CRPSS.R | 4 ++-- R/Composite.R | 2 +- R/DiffCorr.R | 6 ++---- R/ProjectField.R | 8 ++++---- R/RPS.R | 2 +- R/RandomWalkTest.R | 4 ++-- R/Reorder.R | 2 +- R/Utils.R | 32 +++++++++++++++++--------------- 11 files changed, 38 insertions(+), 37 deletions(-) diff --git a/.lintr b/.lintr index 239b922..45704fc 100644 --- a/.lintr +++ b/.lintr @@ -26,13 +26,14 @@ exclusions: list( "tests/testthat/", "tests/testthat.R", "R/CDORemap.R" = list( - function_argument_linter = NULL, - nonportable_path_linter = NULL + function_argument_linter = Inf, + nonportable_path_linter = Inf ), "R/NAO.R" = list( - function_argument_linter = NULL + function_argument_linter = Inf ), "R/Utils.R" = list( - function_argument_linter = NULL + function_argument_linter = Inf, + nonportable_path_linter = Inf ) ) diff --git a/R/AMV.R b/R/AMV.R index 4c9324e..83b63b0 100644 --- a/R/AMV.R +++ b/R/AMV.R @@ -144,7 +144,7 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo identical(as.integer(dim(mask)), c(length(data_lats), length(data_lons)))) { ## To mask those grid point that are missing in the observations mask <- s2dv::Reorder(data = mask, order = c(lat_dim, lon_dim)) - fun_mask <- function(data, mask){ + fun_mask <- function(data, mask) { data[mask == 0] <- NA return(data) } diff --git a/R/CDORemap.R b/R/CDORemap.R index 402a2b6..af6e0a0 100644 --- a/R/CDORemap.R +++ b/R/CDORemap.R @@ -295,7 +295,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, } } - data_array <- array(as.numeric(NA), array_dims) + data_array <- array(NA_real_, array_dims) } if (!(is.logical(data_array) || is.numeric(data_array)) || !is.array(data_array)) { stop("Parameter 'data_array' must be a numeric array.") @@ -996,7 +996,7 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, # If is irregular, the order of dimension may need to be recovered after reading all the file: if (is_irregular & (!is.null(dims_to_iterate))) { if (exists('pos_new_dims')) { - pos_new_dims <- 1:length(dim(result_array)) + pos_new_dims <- seq_along(dim(result_array)) dims_to_change <- match(backup_result_array_dims, dim(result_array)) pos_new_dims[which(dims_to_change != 1)] <- dims_to_change[which(dims_to_change != 1)] diff --git a/R/CRPSS.R b/R/CRPSS.R index 894b361..74ee144 100644 --- a/R/CRPSS.R +++ b/R/CRPSS.R @@ -149,8 +149,8 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', } if (!identical(length(name_exp), length(name_obs)) | !identical(dim(exp)[name_exp], dim(obs)[name_obs])) { - stop(paste0("Parameter 'exp' and 'obs' must have same length of all dimensions", - " except 'memb_dim' and 'dat_dim'.")) + stop("Parameter 'exp' and 'obs' must have same length of all dimensions", + " except 'memb_dim' and 'dat_dim'.") } if (!is.null(ref)) { name_ref <- sort(names(dim(ref))) diff --git a/R/Composite.R b/R/Composite.R index 71010b0..fb5593d 100644 --- a/R/Composite.R +++ b/R/Composite.R @@ -185,7 +185,7 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), ncores = ncores) if (!is.null(fileout)) { - save(output, file = paste(fileout, '.sav', sep = '')) + save(output, file = paste0(fileout, '.sav') } return(output) diff --git a/R/DiffCorr.R b/R/DiffCorr.R index 3148e6f..3e82402 100644 --- a/R/DiffCorr.R +++ b/R/DiffCorr.R @@ -255,8 +255,7 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', output$p.val <- p.value } if (sign) { - output$sign <- ifelse(!is.na(p.value) & p.value <= alpha & output$diff.corr > 0, - TRUE, FALSE) + output$sign <- !is.na(p.value) & p.value <= alpha & output$diff.corr > 0 } } else if (test.type == 'two-sided') { @@ -271,8 +270,7 @@ DiffCorr <- function(exp, obs, ref, N.eff = NA, time_dim = 'sdate', output$p.val <- p.value } if (sign) { - output$sign <- ifelse(!is.na(p.value) & p.value <= alpha / 2, - TRUE, FALSE) + output$sign <- !is.na(p.value) & p.value <= alpha / 2 } } else { diff --git a/R/ProjectField.R b/R/ProjectField.R index 9a10095..4fdf189 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -117,14 +117,14 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon } ## ano (2) if (!all(space_dim %in% names(dim(ano))) | !time_dim %in% names(dim(ano))) { - stop(paste0("Parameter 'ano' must be an array with dimensions named as ", - "parameter 'space_dim' and 'time_dim'.")) + stop("Parameter 'ano' must be an array with dimensions named as ", + "parameter 'space_dim' and 'time_dim'.") } ## eof (2) if (!all(space_dim %in% names(dim(eof[[EOFs]]))) | !'mode' %in% names(dim(eof[[EOFs]]))) { - stop(paste0("The component 'EOFs' or 'REOFs' of parameter 'eof' must be an array ", - "with dimensions named as parameter 'space_dim' and 'mode'.")) + stop("The component 'EOFs' or 'REOFs' of parameter 'eof' must be an array ", + "with dimensions named as parameter 'space_dim' and 'mode'.") } if (length(dim(eof$wght)) != 2 | !all(names(dim(eof$wght)) %in% space_dim)) { stop("The component 'wght' of parameter 'eof' must be an array ", diff --git a/R/RPS.R b/R/RPS.R index 17c98c4..29f9bc3 100644 --- a/R/RPS.R +++ b/R/RPS.R @@ -359,7 +359,7 @@ RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', cat_dim = NUL } else { ## not enough values different from NA - rps[, i, j] <- as.numeric(NA) + rps[, i, j] <- NA_real_ } diff --git a/R/RandomWalkTest.R b/R/RandomWalkTest.R index caf24ad..16d89f6 100644 --- a/R/RandomWalkTest.R +++ b/R/RandomWalkTest.R @@ -159,7 +159,7 @@ RandomWalkTest <- function(skill_A, skill_B, time_dim = 'sdate', output$score <- A_better - B_better if (test.type == 'two.sided.approx') { - output$sign <- ifelse(test = abs(output$score) > (2 * sqrt(N.eff)), yes = TRUE, no = FALSE) + output$sign <- abs(output$score) > (2 * sqrt(N.eff)) } else { @@ -175,7 +175,7 @@ RandomWalkTest <- function(skill_A, skill_B, time_dim = 'sdate', output$p.val <- p.val } if (sign) { - output$sign <- ifelse(!is.na(p.val) & p.val <= alpha, TRUE, FALSE) + output$sign <- !is.na(p.val) & p.val <= alpha } } diff --git a/R/Reorder.R b/R/Reorder.R index 12730a9..fdad61d 100644 --- a/R/Reorder.R +++ b/R/Reorder.R @@ -37,7 +37,7 @@ Reorder <- function(data, order) { } ## If attribute "dimensions" exists - attr.dim.reorder <- ifelse(!is.null(attributes(data)$dimensions), TRUE, FALSE) + attr.dim.reorder <- !is.null(attributes(data)$dimensions) ## order if (is.null(order)) { diff --git a/R/Utils.R b/R/Utils.R index 3b59d7a..e50fb18 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -5,7 +5,7 @@ ## Function to tell if a regexpr() match is a complete match to a specified name .IsFullMatch <- function(x, name) { - ifelse(x > 0 && attributes(x)$match.length == nchar(name), TRUE, FALSE) + x > 0 && attributes(x)$match.length == nchar(name) } .ConfigReplaceVariablesInString <- function(string, replace_values, @@ -18,13 +18,13 @@ i <- 0 for (part in parts) { if (i %% 2 == 0) { - output <- paste(output, part, sep = "") + output <- paste0(output, part) } else { if (part %in% names(replace_values)) { - output <- paste(output, - .ConfigReplaceVariablesInString(replace_values[[part]], - replace_values, - allow_undefined_key_vars), sep = "") + output <- paste0(output, + .ConfigReplaceVariablesInString(replace_values[[part]], + replace_values, + allow_undefined_key_vars)) } else if (allow_undefined_key_vars) { output <- paste0(output, "$", part, "$") } else { @@ -413,7 +413,7 @@ system(paste0("cdo -L -s remap", work_piece[['remap']], ",", common_grid_name, " -selname,", namevar, " ", filecopy, " ", filein, - " 2>/dev/null", sep = "")) + " 2>/dev/null")) file.remove(filecopy) work_piece[['dimnames']][['lon']] <- 'lon' work_piece[['dimnames']][['lat']] <- 'lat' @@ -446,7 +446,7 @@ mask[['path']], "if the component 'nc_var_name' is not specified. ", "Currently found: ", - paste(vars_in_mask, collapse = ', '), ".") + toString(vars_in_mask), ".") } else { mask[['nc_var_name']] <- vars_in_mask } @@ -602,7 +602,7 @@ expected_dims[which(expected_dims == 'lev')] <- old_members_dimname } stop("Error: the expected dimension(s)", - paste(expected_dims[which(is.na(dim_matches))], collapse = ', '), + toString(expected_dims[which(is.na(dim_matches))]), "were not found in", filename) } time_dimname <- var_dimnames[-dim_matches] @@ -620,7 +620,7 @@ } stop("Error: the variable ", namevar, " is defined over more dimensions than the expected (", - paste(c(expected_dims, 'time'), collapse = ', '), + toString(c(expected_dims, 'time')), "). It could also be that the members, longitude or latitude ", "dimensions are named incorrectly. In that case, either rename ", "the dimensions in the file or adjust Load() to recognize the actual ", @@ -776,7 +776,7 @@ paste0(lonmin, ",", lonmax, ",") }, latmin, ",", latmax, " -remap", work_piece[['remap']], ",", common_grid_name, - " ", filein2, " ", filein, " 2>/dev/null", sep = "")) + " ", filein2, " ", filein, " 2>/dev/null")) file.remove(filein2) fnc2 <- nc_open(filein) sub_lon <- ncvar_get(fnc2, 'lon') @@ -816,7 +816,7 @@ nc_close(fnc_mask) system(paste0("cdo -L -s remap", work_piece[['remap']], ",", common_grid_name, - " ", mask_file, " ", mask_file_remap, " 2>/dev/null", sep = "")) + " ", mask_file, " ", mask_file_remap, " 2>/dev/null")) fnc_mask <- nc_open(mask_file_remap) mask_lons <- ncvar_get(fnc_mask, 'lon') mask_lats <- ncvar_get(fnc_mask, 'lat') @@ -873,7 +873,7 @@ tail(work_piece[['indices']], 1), " are not in the optimal order for loading with Load(). ", "The optimal order would be '", - paste(expected_dims, collapse = ', '), + toString(expected_dims), "'. One of the files of the dataset is stored in ", filename)) } tmp <- aperm(tmp, dim_matches) @@ -1777,10 +1777,12 @@ clim <- 0 } else if (is.null(indices_for_clim)) { ## climatology over the whole period - clim <- multiApply::Apply(data = data, target_dims = year_dim, fun = mean, na.rm = na.rm)$output1 + clim <- multiApply::Apply(data = data, target_dims = year_dim, fun = mean, + na.rm = na.rm)$output1 } else { ## indices_for_clim specified as a numeric vector - clim <- multiApply::Apply(data = ClimProjDiags::Subset(x = data, along = year_dim, indices = indices_for_clim), + clim <- multiApply::Apply(data = ClimProjDiags::Subset(x = data, along = year_dim, + indices = indices_for_clim), target_dims = year_dim, fun = mean, na.rm = na.rm)$output1 } -- GitLab From 2b15f58bae069c4b578727b7b00f0a3ffaa868ce Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 14 Nov 2023 12:43:45 +0100 Subject: [PATCH 09/11] Fix brace error. Update .lintr for lintr_3.1.1 --- .lintr | 3 +-- R/Composite.R | 2 +- R/Utils.R | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.lintr b/.lintr index 45704fc..b2d4240 100644 --- a/.lintr +++ b/.lintr @@ -2,11 +2,10 @@ linters: linters_with_tags( tags = c("package_development", "readability", "best_practices"), line_length_linter = line_length_linter(100L), T_and_F_symbol_linter = NULL, - single_quotes_linter = NULL, + quotes_linter = NULL, commented_code_linter = NULL, implicit_integer_linter = NULL, vector_logic_linter = NULL, - infix_spaces_linter = NULL, extraction_operator_linter = NULL, function_left_parentheses_linter = NULL, semicolon_linter = NULL diff --git a/R/Composite.R b/R/Composite.R index fb5593d..1d8fb53 100644 --- a/R/Composite.R +++ b/R/Composite.R @@ -185,7 +185,7 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), ncores = ncores) if (!is.null(fileout)) { - save(output, file = paste0(fileout, '.sav') + save(output, file = paste0(fileout, '.sav')) } return(output) diff --git a/R/Utils.R b/R/Utils.R index e50fb18..cc8ebe2 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -1261,7 +1261,7 @@ tag <- paste0('\\$', tag, '\\$') path_with_globs_and_tag <- paste0('^', path_with_globs_and_tag, '$') parts <- strsplit(path_with_globs_and_tag, '*', fixed = TRUE)[[1]] - parts <- as.list(parts[grep(tag, parts)]) + parts <- as.list(grep(tag, parts, value = TRUE)) longest_couples <- NULL pos_longest_couples <- NULL found_value <- NULL -- GitLab From f44bc829aca80e21c120c93d61d2d9a747ca34cd Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 14 Nov 2023 15:33:09 +0100 Subject: [PATCH 10/11] Fixes for lintr_3.1.1 checks --- .lintr | 8 +++-- R/ACC.R | 63 ++++++++++++++++------------------ R/AMV.R | 8 ++--- R/AbsBiasSS.R | 8 ++--- R/Ano.R | 2 +- R/Ano_CrossValid.R | 19 +++------- R/BrierScore.R | 6 ++-- R/CDORemap.R | 40 ++++++++++----------- R/CRPSS.R | 8 ++--- R/Clim.R | 9 ++--- R/Composite.R | 6 ++-- R/Consist_Trend.R | 2 +- R/EOF.R | 2 +- R/Filter.R | 11 +++--- R/GMST.R | 8 ++--- R/GSAT.R | 8 ++--- R/GetProbs.R | 2 +- R/MeanDims.R | 6 ++-- R/ProbBins.R | 6 ++-- R/RPSS.R | 8 ++--- R/RatioPredictableComponents.R | 2 +- R/RatioSDRMS.R | 2 +- R/Regression.R | 18 +++++----- R/Reorder.R | 8 ++--- R/SPOD.R | 8 ++--- R/SignalNoiseRatio.R | 2 +- R/Spectrum.R | 2 +- R/TPI.R | 8 ++--- R/Trend.R | 4 +-- R/UltimateBrier.R | 6 ++-- R/Utils.R | 24 ++++++------- 31 files changed, 135 insertions(+), 179 deletions(-) diff --git a/.lintr b/.lintr index b2d4240..dac9e36 100644 --- a/.lintr +++ b/.lintr @@ -1,4 +1,4 @@ -linters: linters_with_tags( +linters: linters_with_tags( # lintr_3.1.1 tags = c("package_development", "readability", "best_practices"), line_length_linter = line_length_linter(100L), T_and_F_symbol_linter = NULL, @@ -8,7 +8,11 @@ linters: linters_with_tags( vector_logic_linter = NULL, extraction_operator_linter = NULL, function_left_parentheses_linter = NULL, - semicolon_linter = NULL + semicolon_linter = NULL, + indentation_linter = NULL, + unnecessary_nested_if_linter = NULL, + if_not_else_linter = NULL, + object_length_linter = NULL ) exclusions: list( "R/Load.R", diff --git a/R/ACC.R b/R/ACC.R index 6865834..ee9d381 100644 --- a/R/ACC.R +++ b/R/ACC.R @@ -464,23 +464,21 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', if (is.infinite(acc[iexp, iobs])) acc[iexp, iobs] <- NA # pval, sign, and conf - if (pval | conf | sign) { - if (conftype == "parametric") { - # calculate effective sample size - eno <- .Eno(as.vector(obs_sub), na.action = na.pass) - - if (pval | sign) { - t <- qt(1 - alpha, eno - 2) # a number - p.value <- sqrt(t^2 / (t^2 + eno - 2)) - if (pval) p.val[iexp, iobs] <- p.value - if (sign) signif[iexp, iobs] <- !is.na(p.value) & p.value <= alpha - } - if (conf) { - conf.upper[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + + if ((pval | conf | sign) && conftype == "parametric") { + # calculate effective sample size + eno <- .Eno(as.vector(obs_sub), na.action = na.pass) + + if (pval | sign) { + t <- qt(1 - alpha, eno - 2) # a number + p.value <- sqrt(t^2 / (t^2 + eno - 2)) + if (pval) p.val[iexp, iobs] <- p.value + if (sign) signif[iexp, iobs] <- !is.na(p.value) & p.value <= alpha + } + if (conf) { + conf.upper[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + qnorm(1 - alpha / 2) / sqrt(eno - 3)) - conf.lower[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + + conf.lower[iexp, iobs] <- tanh(atanh(acc[iexp, iobs]) + qnorm(alpha / 2) / sqrt(eno - 3)) - } } } @@ -507,29 +505,26 @@ ACC <- function(exp, obs, dat_dim = NULL, lat_dim = 'lat', lon_dim = 'lon', } # pval, sign, and conf - if (pval | sign | conf) { - if (conftype == "parametric") { - # calculate effective sample size along lat_dim and lon_dim - # combine lat_dim and lon_dim into one dim first - obs_tmp <- array(obs_sub, - dim = c(space = prod(dim(obs_sub)[1:2]), - dim(obs_sub)[3])) - eno <- apply(obs_tmp, 2, .Eno, na.action = na.pass) # a vector of avg_dim - if (pval | sign) { - t <- qt(1 - alpha, eno - 2) # a vector of avg_dim - p.value <- sqrt(t^2 / (t^2 + eno - 2)) - if (pval) p.val[iexp, iobs, ] <- p.value - if (sign) signif[iexp, iobs, ] <- !is.na(p.value) & p.value <= alpha - } - if (conf) { - conf.upper[iexp, iobs, ] <- tanh(atanh(acc[iexp, iobs, ]) + + if ((pval | sign | conf) && conftype == "parametric") { + # calculate effective sample size along lat_dim and lon_dim + # combine lat_dim and lon_dim into one dim first + obs_tmp <- array(obs_sub, + dim = c(space = prod(dim(obs_sub)[1:2]), + dim(obs_sub)[3])) + eno <- apply(obs_tmp, 2, .Eno, na.action = na.pass) # a vector of avg_dim + if (pval | sign) { + t <- qt(1 - alpha, eno - 2) # a vector of avg_dim + p.value <- sqrt(t^2 / (t^2 + eno - 2)) + if (pval) p.val[iexp, iobs, ] <- p.value + if (sign) signif[iexp, iobs, ] <- !is.na(p.value) & p.value <= alpha + } + if (conf) { + conf.upper[iexp, iobs, ] <- tanh(atanh(acc[iexp, iobs, ]) + qnorm(1 - alpha / 2) / sqrt(eno - 3)) - conf.lower[iexp, iobs, ] <- tanh(atanh(acc[iexp, iobs, ]) + + conf.lower[iexp, iobs, ] <- tanh(atanh(acc[iexp, iobs, ]) + qnorm(alpha / 2) / sqrt(eno - 3)) - } } } - } # if avg_dim is not NULL } diff --git a/R/AMV.R b/R/AMV.R index 83b63b0..60b07da 100644 --- a/R/AMV.R +++ b/R/AMV.R @@ -157,11 +157,9 @@ AMV <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } } # monini - if (type == 'dcpp') { - if (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | - monini > 12) { - stop("Parameter 'monini' must be an integer from 1 to 12.") - } + if (type == 'dcpp' && + (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | monini > 12)) { + stop("Parameter 'monini' must be an integer from 1 to 12.") } # fmonth_dim if (type == 'dcpp') { diff --git a/R/AbsBiasSS.R b/R/AbsBiasSS.R index 84215bc..1b81797 100644 --- a/R/AbsBiasSS.R +++ b/R/AbsBiasSS.R @@ -180,11 +180,9 @@ AbsBiasSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = NULL, stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', ", "'greater', or 'less'.") } - if (sig_method.type == 'two.sided.approx') { - if (alpha != 0.05) { - .warning("DelSole and Tippett (2016) aproximation is valid for alpha ", - "= 0.05 only. Returning the significance at the 0.05 significance level.") - } + if (sig_method.type == 'two.sided.approx' && alpha != 0.05) { + .warning("DelSole and Tippett (2016) aproximation is valid for alpha ", + "= 0.05 only. Returning the significance at the 0.05 significance level.") } ## ncores diff --git a/R/Ano.R b/R/Ano.R index c9ca5c1..ccb41e0 100644 --- a/R/Ano.R +++ b/R/Ano.R @@ -87,7 +87,7 @@ } if (!parallel_compute) { target_dims_ind <- match(names(dim(clim)), names(dim(data))) - if (any(target_dims_ind != sort(target_dims_ind))) { + if (is.unsorted(target_dims_ind)) { clim <- Reorder(clim, match(sort(target_dims_ind), target_dims_ind)) } if (length(dim(data)) == length(dim(clim))) { diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index b915f1e..e083fc9 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -129,10 +129,8 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', } } # memb_dim and dat_dim - if (!memb) { - if (!memb_dim %in% dat_dim) { - stop("Parameter 'memb_dim' must be one element in parameter 'dat_dim'.") - } + if (!memb && !memb_dim %in% dat_dim) { + stop("Parameter 'memb_dim' must be one element in parameter 'dat_dim'.") } ## ncores @@ -161,9 +159,7 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', name_exp <- names(dim(exp)) name_obs <- names(dim(obs)) order_obs <- match(name_exp, name_obs) - if (any(order_obs != sort(order_obs))) { - obs <- Reorder(obs, order_obs) - } + obs <- Reorder(obs, order_obs) #----------------------------------- # Per-paired method: If any sdate along dat_dim is NA, turn all sdate points @@ -272,13 +268,8 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', clim_obs_tmp <- array(clim_obs, dim = c(dim_obs_ori[pos], dim_obs_ori[-pos])) # Reorder it back to dim(clim_exp) tmp <- match(dim_exp_ori, dim(clim_exp_tmp)) - if (any(tmp != sort(tmp))) { - clim_exp <- Reorder(clim_exp_tmp, tmp) - clim_obs <- Reorder(clim_obs_tmp, tmp) - } else { - clim_exp <- clim_exp_tmp - clim_obs <- clim_obs_tmp - } + clim_exp <- Reorder(clim_exp_tmp, tmp) + clim_obs <- Reorder(clim_obs_tmp, tmp) } } # calculate ano diff --git a/R/BrierScore.R b/R/BrierScore.R index 682cdb1..82526c0 100644 --- a/R/BrierScore.R +++ b/R/BrierScore.R @@ -146,10 +146,8 @@ BrierScore <- function(exp, obs, thresholds = seq(0.1, 0.9, 0.1), time_dim = 'sd if (!memb_dim %in% names(dim(exp))) { stop("Parameter 'memb_dim' is not found in 'exp' dimension.") } - if (memb_dim %in% names(dim(obs))) { - if (dim(obs)[memb_dim] != 1) { - stop("The length of parameter 'memb_dim' in 'obs' must be 1.") - } + if (memb_dim %in% names(dim(obs)) && dim(obs)[memb_dim] != 1) { + stop("The length of parameter 'memb_dim' in 'obs' must be 1.") } } ## exp and obs (2) diff --git a/R/CDORemap.R b/R/CDORemap.R index af6e0a0..ecee32d 100644 --- a/R/CDORemap.R +++ b/R/CDORemap.R @@ -413,11 +413,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, method <- 'con' } else if (method %in% c('dis', 'distance-weighted')) { method <- 'dis' - } else if (method %in% 'nn') { + } else if (method == 'nn') { method <- 'nn' - } else if (method %in% 'laf') { + } else if (method == 'laf') { method <- 'laf' - } else if (method %in% 'con2') { + } else if (method == 'con2') { method <- 'con2' } else { stop("Unsupported CDO remap method. Only 'bilinear', ", @@ -632,18 +632,16 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, # } # Check if interpolation can be skipped. interpolation_needed <- TRUE - if (!force_remap) { - if (!(grid_type == 'custom')) { - if (length(lons) == grid_lons && length(lats) == grid_lats) { - if (grid_type == 'regular') { - if (.isRegularVector(lons) && .isRegularVector(lats)) { - interpolation_needed <- FALSE - } - } else if (grid_type == 'gaussian') { - # TODO: improve this check. Gaussian quadrature should be used. - if (.isRegularVector(lons) && !.isRegularVector(lats)) { - interpolation_needed <- FALSE - } + if (!force_remap && !(grid_type == 'custom')) { + if (length(lons) == grid_lons && length(lats) == grid_lats) { + if (grid_type == 'regular') { + if (.isRegularVector(lons) && .isRegularVector(lats)) { + interpolation_needed <- FALSE + } + } else if (grid_type == 'gaussian') { + # TODO: improve this check. Gaussian quadrature should be used. + if (.isRegularVector(lons) && !.isRegularVector(lats)) { + interpolation_needed <- FALSE } } } @@ -940,13 +938,11 @@ CDORemap <- function(data_array = NULL, lons, lats, grid, method, lat_pos <- which(names(new_dims) == lat_dim) # Fix issue 259, expected order from CDO output is lon lat # If is irregular, lat and lon position need to be checked: - if (is_irregular) { - if (lon_pos > lat_pos) { - new_pos <- seq_along(new_dims) - new_pos[lon_pos] <- lat_pos - new_pos[lat_pos] <- lon_pos - new_dims <- new_dims[new_pos] - } + if (is_irregular && lon_pos > lat_pos) { + new_pos <- seq_along(new_dims) + new_pos[lon_pos] <- lat_pos + new_pos[lat_pos] <- lon_pos + new_dims <- new_dims[new_pos] } result_array <- array(dim = new_dims) store_indices <- as.list(rep(TRUE, length(dim(result_array)))) diff --git a/R/CRPSS.R b/R/CRPSS.R index 74ee144..5c901ac 100644 --- a/R/CRPSS.R +++ b/R/CRPSS.R @@ -189,11 +189,9 @@ CRPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', ", "'greater', or 'less'.") } - if (sig_method.type == 'two.sided.approx') { - if (alpha != 0.05) { - .warning("DelSole and Tippett (2016) aproximation is valid for alpha ", - "= 0.05 only. Returning the significance at the 0.05 significance level.") - } + if (sig_method.type == 'two.sided.approx' && alpha != 0.05) { + .warning("DelSole and Tippett (2016) aproximation is valid for alpha ", + "= 0.05 only. Returning the significance at the 0.05 significance level.") } ## ncores if (!is.null(ncores)) { diff --git a/R/Clim.R b/R/Clim.R index 38e6964..d3dde13 100644 --- a/R/Clim.R +++ b/R/Clim.R @@ -323,6 +323,7 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), tmp_exp <- Trend(data = exp, time_dim = time_dim, interval = 1, polydeg = 1, conf = FALSE, ncores = ncores_input)$trend # tmp_exp: [stats, dat_dim] + ##NOTE: Cannot use rowMeans here because tmp_obs may have only one dim tmp_obs_mean <- apply(tmp_obs, 1, mean) #average out dat_dim (dat and member) #tmp_obs_mean: [stats = 2] if (!is.null(dat_dim)) { @@ -352,11 +353,11 @@ Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), } # average out dat_dim, get a number - if (is.null(dim(clim_obs))) { +# if (is.null(dim(clim_obs))) { clim_obs_mean <- mean(clim_obs) - } else { - clim_obs_mean <- mean(apply(clim_obs, 1, mean)) - } +# } else { +# clim_obs_mean <- mean(rowMeans(clim_obs)) +# } clim_obs_mean <- array(clim_obs_mean, dim = dim(exp)) #enlarge it for the next line clim_exp <- trend_exp - trend_obs + clim_obs_mean diff --git a/R/Composite.R b/R/Composite.R index 1d8fb53..3831e07 100644 --- a/R/Composite.R +++ b/R/Composite.R @@ -203,7 +203,7 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), dof <- array(dim = dim(data)[1:2]) pval <- array(dim = c(dim(data)[1:2], composite = K)) - if (eno == TRUE) { + if (eno) { n_tot <- Eno(data, time_dim = time_dim, ncores = ncores_input) } else { n_tot <- length(occ) @@ -214,14 +214,14 @@ Composite <- function(data, occ, time_dim = 'time', space_dim = c('lon', 'lat'), for (k in 1:K) { - if (length(which(occ == k)) >= 1) { + if (any(occ == k)) { indices <- which(occ == k) + lag toberemoved <- which(0 > indices | indices > dim(data)[3]) if (length(toberemoved) > 0) { indices <- indices[-toberemoved] } - if (eno == TRUE) { + if (eno) { data_tmp <- data[, , indices] names(dim(data_tmp)) <- names(dim(data)) n_k <- Eno(data_tmp, time_dim = time_dim, ncores = ncores_input) diff --git a/R/Consist_Trend.R b/R/Consist_Trend.R index d2f5fbd..8289168 100644 --- a/R/Consist_Trend.R +++ b/R/Consist_Trend.R @@ -161,7 +161,7 @@ Consist_Trend <- function(exp, obs, dat_dim = 'dataset', time_dim = 'sdate', int # obs: [nobs, sdate] # Find common points - nan <- apply(exp, 2, mean, na.rm = FALSE) + apply(obs, 2, mean, na.rm = FALSE) # [sdate] + nan <- colMeans(exp, na.rm = FALSE) + colMeans(obs, na.rm = FALSE) # [sdate] exp[, is.na(nan)] <- NA obs[, is.na(nan)] <- NA diff --git a/R/EOF.R b/R/EOF.R index fde52a2..38c3fae 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -221,7 +221,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), ano <- ano * InsertDim(wght, 1, nt) # The use of the correlation matrix is done under the option corr. - if (corr == TRUE) { + if (corr) { stdv <- apply(ano, c(2, 3), sd, na.rm = T) ano <- ano / InsertDim(stdv, 1, nt) } diff --git a/R/Filter.R b/R/Filter.R index 3dbd2e3..e7043e2 100644 --- a/R/Filter.R +++ b/R/Filter.R @@ -103,18 +103,17 @@ Filter <- function(data, freq, time_dim = 'ftime', ncores = NULL) { for (jfreq in seq(freq - 0.5 / ndat2, freq + 0.5 / ndat2, 0.1 / (ndat2 * fac1))) { for (phase in seq(0, pi, (pi / (10 * fac2)))) { xtest <- cos(phase + 1:ndat * jfreq * 2 * pi) - test <- lm(data[is.na(data) == FALSE] ~ xtest[ - is.na(data) == FALSE])$fitted.values - if (sum(test ^ 2) > maxi) { + test <- lm(data[!is.na(data)] ~ xtest[!is.na(data)])$fitted.values + if (sum(test^2) > maxi) { endphase <- phase endfreq <- jfreq } - maxi <- max(sum(test ^ 2), maxi) + maxi <- max(sum(test^2), maxi) } } xend <- cos(endphase + 1:ndat * endfreq * 2 * pi) - data[is.na(data) == FALSE] <- data[is.na(data) == FALSE] - lm( - data[is.na(data) == FALSE] ~ xend[is.na(data) == FALSE] + data[!is.na(data)] <- data[!is.na(data)] - lm( + data[!is.na(data)] ~ xend[!is.na(data)] )$fitted.values return(invisible(data)) diff --git a/R/GMST.R b/R/GMST.R index 65e21e9..65cf99d 100644 --- a/R/GMST.R +++ b/R/GMST.R @@ -184,11 +184,9 @@ GMST <- function(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_va } } # monini - if (type == 'dcpp') { - if (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | - monini > 12) { - stop("Parameter 'monini' must be an integer from 1 to 12.") - } + if (type == 'dcpp' && + (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | monini > 12)) { + stop("Parameter 'monini' must be an integer from 1 to 12.") } # fmonth_dim if (type == 'dcpp') { diff --git a/R/GSAT.R b/R/GSAT.R index c70f590..eaf914f 100644 --- a/R/GSAT.R +++ b/R/GSAT.R @@ -153,11 +153,9 @@ GSAT <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } } # monini - if (type == 'dcpp') { - if (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | - monini > 12) { - stop("Parameter 'monini' must be an integer from 1 to 12.") - } + if (type == 'dcpp' && + (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | monini > 12)) { + stop("Parameter 'monini' must be an integer from 1 to 12.") } # fmonth_dim if (type == 'dcpp') { diff --git a/R/GetProbs.R b/R/GetProbs.R index 8a56007..2a53889 100644 --- a/R/GetProbs.R +++ b/R/GetProbs.R @@ -348,6 +348,6 @@ GetProbs <- function(data, time_dim = 'sdate', memb_dim = 'member', cumulative_weights <- cumulative_weights - cumulative_weights[1] # fix the 0 cumulative_weights <- cumulative_weights / cumulative_weights[length(cumulative_weights)] # fix the 1 - return(list("data" = data_vector[sorter], "cumulative_weights" = cumulative_weights)) + return(list(data = data_vector[sorter], cumulative_weights = cumulative_weights)) } diff --git a/R/MeanDims.R b/R/MeanDims.R index 588f514..45fd6f6 100644 --- a/R/MeanDims.R +++ b/R/MeanDims.R @@ -50,10 +50,8 @@ MeanDims <- function(data, dims, na.rm = FALSE, drop = TRUE) { stop("Parameter 'dims' exceeds the dimension length of parameter 'data'.") } } - if (is.character(dims)) { - if (!all(dims %in% names(dim(data)))) { - stop("Parameter 'dims' do not match the dimension names of parameter 'data'.") - } + if (is.character(dims) && !all(dims %in% names(dim(data)))) { + stop("Parameter 'dims' do not match the dimension names of parameter 'data'.") } ## na.rm if (!is.logical(na.rm) | length(na.rm) > 1) { diff --git a/R/ProbBins.R b/R/ProbBins.R index 444ef28..adc8890 100644 --- a/R/ProbBins.R +++ b/R/ProbBins.R @@ -80,10 +80,8 @@ ProbBins <- function(data, thr, fcyr = 'all', time_dim = 'sdate', memb_dim = 'me } if (!is.numeric(thr) | !is.vector(thr)) { stop("Parameter 'thr' must be a numeric vector.") - } else if (quantile) { - if (!all(thr <= 1 & thr >= 0)) { - stop("Parameter 'thr' must be within the range [0, 1] if 'quantile' is TRUE.") - } + } else if (quantile && !all(thr <= 1 & thr >= 0)) { + stop("Parameter 'thr' must be within the range [0, 1] if 'quantile' is TRUE.") } ## time_dim if (!is.character(time_dim) | length(time_dim) > 1) { diff --git a/R/RPSS.R b/R/RPSS.R index c6d3a12..de4e257 100644 --- a/R/RPSS.R +++ b/R/RPSS.R @@ -348,11 +348,9 @@ RPSS <- function(exp, obs, ref = NULL, time_dim = 'sdate', memb_dim = 'member', stop("Parameter 'sig_method.type' must be 'two.sided.approx', 'two.sided', ", "'greater', or 'less'.") } - if (sig_method.type == 'two.sided.approx') { - if (alpha != 0.05) { - .warning("DelSole and Tippett (2016) aproximation is valid for alpha ", - "= 0.05 only. Returning the significance at the 0.05 significance level.") - } + if (sig_method.type == 'two.sided.approx' && alpha != 0.05) { + .warning("DelSole and Tippett (2016) aproximation is valid for alpha ", + "= 0.05 only. Returning the significance at the 0.05 significance level.") } ## ncores if (!is.null(ncores)) { diff --git a/R/RatioPredictableComponents.R b/R/RatioPredictableComponents.R index b34d9fd..3b30301 100644 --- a/R/RatioPredictableComponents.R +++ b/R/RatioPredictableComponents.R @@ -84,7 +84,7 @@ RatioPredictableComponents <- function(exp, obs, time_dim = 'year', # obs: [time] ## Ensemble mean and spread - ens_mean <- apply(exp, 1, mean, na.rm = na.rm) + ens_mean <- rowMeans(exp, na.rm = na.rm) #ens_spread <- apply(exp, 2, "-", ens_mean) ## Ensemble mean variance -> signal diff --git a/R/RatioSDRMS.R b/R/RatioSDRMS.R index aff139c..f7e848f 100644 --- a/R/RatioSDRMS.R +++ b/R/RatioSDRMS.R @@ -171,7 +171,7 @@ RatioSDRMS <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', dif <- exp - InsertDim(ens_exp, 2, dim(exp)[2]) # [nexp, member, sdate] std <- apply(dif, 1, sd, na.rm = TRUE) # [nexp] - enosd <- apply(Eno(dif, names(dim(exp))[3]), 1, sum, na.rm = TRUE) + enosd <- rowSums(Eno(dif, names(dim(exp))[3]), na.rm = TRUE) # Create empty arrays ratiosdrms <- array(dim = c(nexp = as.numeric(nexp), nobs = as.numeric(nobs))) # [nexp, nobs] diff --git a/R/Regression.R b/R/Regression.R index 2d09520..ef92fc4 100644 --- a/R/Regression.R +++ b/R/Regression.R @@ -226,17 +226,15 @@ Regression <- function(datay, datax, reg_dim = 'sdate', formula = y ~ x, filtered[!is.na(NApos)] <- y[!is.na(NApos)] - lm.out$fitted.values # Check if NA is too many - if (check_na) { - if (sum(is.na(NApos)) > na_threshold) { #turn everything into NA - coeff[which(!is.na(coeff))] <- NA - if (conf) { - conf.lower[which(!is.na(conf.lower))] <- NA - conf.upper[which(!is.na(conf.upper))] <- NA - } - if (pval) p.val[which(!is.na(p.val))] <- NA - if (sign) signif[which(!is.na(signif))] <- NA - filtered[which(!is.na(filtered))] <- NA + if (check_na && sum(is.na(NApos)) > na_threshold) { #turn everything into NA + coeff[which(!is.na(coeff))] <- NA + if (conf) { + conf.lower[which(!is.na(conf.lower))] <- NA + conf.upper[which(!is.na(conf.upper))] <- NA } + if (pval) p.val[which(!is.na(p.val))] <- NA + if (sign) signif[which(!is.na(signif))] <- NA + filtered[which(!is.na(filtered))] <- NA } res <- list(regression = coeff, filtered = filtered) diff --git a/R/Reorder.R b/R/Reorder.R index fdad61d..2809a00 100644 --- a/R/Reorder.R +++ b/R/Reorder.R @@ -63,11 +63,9 @@ Reorder <- function(data, order) { } } else { dim_names <- names(dim(data)) - if (attr.dim.reorder) { - if (any(attributes(data)$dimensions != dim_names)) { - warning("Found attribute 'dimensions' has different names from ", - "names(dim(x)). Use the latter one to reorder.") - } + if (attr.dim.reorder && any(attributes(data)$dimensions != dim_names)) { + warning("Found attribute 'dimensions' has different names from ", + "names(dim(x)). Use the latter one to reorder.") } } if (!all(order %in% dim_names)) { diff --git a/R/SPOD.R b/R/SPOD.R index 624f8af..3f01957 100644 --- a/R/SPOD.R +++ b/R/SPOD.R @@ -156,11 +156,9 @@ SPOD <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'l } } # monini - if (type == 'dcpp') { - if (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | - monini > 12) { - stop("Parameter 'monini' must be an integer from 1 to 12.") - } + if (type == 'dcpp' && + (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | monini > 12)) { + stop("Parameter 'monini' must be an integer from 1 to 12.") } # fmonth_dim if (type == 'dcpp') { diff --git a/R/SignalNoiseRatio.R b/R/SignalNoiseRatio.R index cba54a9..6ea72b6 100644 --- a/R/SignalNoiseRatio.R +++ b/R/SignalNoiseRatio.R @@ -69,7 +69,7 @@ SignalNoiseRatio <- function(data, time_dim = 'year', member_dim = 'member', # data: [time, member] ## Ensemble mean and spread - ens_mean <- apply(data, 1, mean, na.rm = na.rm) + ens_mean <- rowMeans(data, na.rm = na.rm) ens_spread <- apply(data, 2, "-", ens_mean) ## Ensemble mean variance -> signal diff --git a/R/Spectrum.R b/R/Spectrum.R index f336085..cbaf135 100644 --- a/R/Spectrum.R +++ b/R/Spectrum.R @@ -97,7 +97,7 @@ Spectrum <- function(data, time_dim = 'ftime', alpha = 0.05, ncores = NULL) { .Spectrum <- function(data, alpha = 0.05) { # data: [time] - data <- data[is.na(data) == FALSE] + data <- data[!is.na(data)] ndat <- length(data) if (ndat >= 3) { diff --git a/R/TPI.R b/R/TPI.R index ab5f708..ecde7ac 100644 --- a/R/TPI.R +++ b/R/TPI.R @@ -155,11 +155,9 @@ TPI <- function(data, data_lats, data_lons, type, lat_dim = 'lat', lon_dim = 'lo } } # monini - if (type == 'dcpp') { - if (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | - monini > 12) { - stop("Parameter 'monini' must be an integer from 1 to 12.") - } + if (type == 'dcpp' && + (!is.numeric(monini) | monini %% 1 != 0 | monini < 1 | monini > 12)) { + stop("Parameter 'monini' must be an integer from 1 to 12.") } # fmonth_dim if (type == 'dcpp') { diff --git a/R/Trend.R b/R/Trend.R index cb5183c..883bcdf 100644 --- a/R/Trend.R +++ b/R/Trend.R @@ -179,13 +179,13 @@ Trend <- function(data, time_dim = 'ftime', interval = 1, polydeg = 1, alpha = 0 } if (pval | sign) { - p.value <- as.array(stats::anova(lm.out)$'Pr(>F)'[1]) + p.value <- as.array(stats::anova(lm.out)[['Pr(>F)']][1]) if (pval) p.val <- p.value if (sign) signif <- !is.na(p.value) & p.value <= alpha } detrended <- NULL - detrended[is.na(x) == FALSE] <- x[is.na(x) == FALSE] - lm.out$fitted.values + detrended[!is.na(x)] <- x[!is.na(x)] - lm.out$fitted.values } else { diff --git a/R/UltimateBrier.R b/R/UltimateBrier.R index 7ec4243..79b9864 100644 --- a/R/UltimateBrier.R +++ b/R/UltimateBrier.R @@ -155,10 +155,8 @@ UltimateBrier <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_di if (!is.numeric(thr) | !is.vector(thr)) { stop("Parameter 'thr' must be a numeric vector.") } - if (quantile) { - if (!all(thr < 1 & thr > 0)) { - stop("Parameter 'thr' must be between 0 and 1 when quantile is TRUE.") - } + if (quantile && !all(thr < 1 & thr > 0)) { + stop("Parameter 'thr' must be between 0 and 1 when quantile is TRUE.") } if (!quantile & (type %in% c('FairEnsembleBSS', 'FairEnsembleBS'))) { stop("Parameter 'quantile' must be TRUE if 'type' is 'FairEnsembleBSS' or 'FairEnsembleBS'.") diff --git a/R/Utils.R b/R/Utils.R index cc8ebe2..c6e233c 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -120,7 +120,7 @@ output <- work_piece[['output']] # The names of all data files in the directory of the repository that match # the pattern are obtained. - if (length(grep("^http", filename)) > 0) { + if (any(grep("^http", filename))) { is_url <- TRUE files <- filename ## TODO: Check that the user is not using shell globbing exps. @@ -137,13 +137,11 @@ found_file <- filename mask <- work_piece[['mask']] - if (!silent) { - if (explore_dims) { - .message(paste("Exploring dimensions...", filename)) - } - ##} else { - ## cat(paste("* Reading & processing data...", filename, '\n')) - ##} + if (!silent && explore_dims) { + .message(paste("Exploring dimensions...", filename)) + ##} else { + ## cat(paste("* Reading & processing data...", filename, '\n')) + ##} } # We will fill in 'expected_dims' with the names of the expected dimensions of @@ -219,12 +217,12 @@ grids_info <- lapply(grids_info, function (x) unlist(strsplit(x, " | = "))) grids_types <- unlist(lapply(grids_info, function (x) x[grep('gridtype', x) + 1])) grids_matches <- unlist(lapply(grids_info, function (x) { - nlons <- if (length(grep('xsize', x)) > 0) { + nlons <- if (any(grep('xsize', x))) { as.numeric(x[grep('xsize', x) + 1]) } else { NA } - nlats <- if (length(grep('ysize', x)) > 0) { + nlats <- if (any(grep('ysize', x))) { as.numeric(x[grep('ysize', x) + 1]) } else { NA @@ -277,13 +275,13 @@ # later on. if (!is.null(work_piece[['grid']])) { # Now we calculate the common grid type and its lons and lats - if (length(grep('^t\\d{1,+}grid$', work_piece[['grid']])) > 0) { + if (any(grep('^t\\d{1,+}grid$', work_piece[['grid']]))) { common_grid_type <- 'gaussian' common_grid_res <- as.numeric(strsplit(work_piece[['grid']], '[^0-9]{1,+}')[[1]][2]) nlonlat <- .t2nlatlon(common_grid_res) common_grid_lats <- nlonlat[1] common_grid_lons <- nlonlat[2] - } else if (length(grep('^r\\d{1,+}x\\d{1,+}$', work_piece[['grid']])) > 0) { + } else if (any(grep('^r\\d{1,+}x\\d{1,+}$', work_piece[['grid']]))) { common_grid_type <- 'lonlat' common_grid_lons <- as.numeric(strsplit(work_piece[['grid']], '[^0-9]{1,+}')[[1]][2]) common_grid_lats <- as.numeric(strsplit(work_piece[['grid']], '[^0-9]{1,+}')[[1]][3]) @@ -863,7 +861,7 @@ ###} } } - if (!all(dim_matches == sort(dim_matches))) { + if (is.unsorted(dim_matches)) { if (!found_disordered_dims && rev(work_piece[['indices']])[2] == 1 && rev(work_piece[['indices']])[3] == 1) { -- GitLab From 75b51c7af7f27e47b6821740b12ec181f08402dd Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 14 Nov 2023 15:59:08 +0100 Subject: [PATCH 11/11] Save lintr check result for future comparison --- .lintr | 3 ++- .lintr_result | Bin 0 -> 6270 bytes R/NAO.R | 4 ++-- 3 files changed, 4 insertions(+), 3 deletions(-) create mode 100644 .lintr_result diff --git a/.lintr b/.lintr index dac9e36..8431cf7 100644 --- a/.lintr +++ b/.lintr @@ -12,7 +12,8 @@ linters: linters_with_tags( # lintr_3.1.1 indentation_linter = NULL, unnecessary_nested_if_linter = NULL, if_not_else_linter = NULL, - object_length_linter = NULL + object_length_linter = NULL, + infix_spaces_linter(exclude_operators = "~") ) exclusions: list( "R/Load.R", diff --git a/.lintr_result b/.lintr_result new file mode 100644 index 0000000000000000000000000000000000000000..25342f93ea01b203b2755ca93fc2e00c3842ff15 GIT binary patch literal 6270 zcmV-^7=h;>iwFP!000001MQvJa~nr`z=t}0$+E3v6R)kfMXMHo1c3x->ayhxMUj%M z(>&yZqT%LD0~l*C1NRIlB1xr^+J{taZ7NQsDwV5}-N)3XlG;?B@<-$)Z>imfq$&@2 z**xZLo$s5$(R1J+2jqZ2vx-DxFqrB2z8}A@kFUS}^d&`6jw;8djwnZuLs2=tzP5bn zDjYilZ~nab`U3pE2ES9vG37;geR*NazNu4tbv3sFZ%?@&Dau`;JQeuLaocGaEO7Ad za@|xN-7;-rSFF0BkqX^rL~W>sRi%!u64k2K47Q^?4Pupu!EBp26>5_Fd=?724PUUy zdviHOIU-*8<8}qf2bV~xd6zWXsbz_^WoHRzC31s2T)%%GuA^63QPZn%AZ2URVW}*s zvg%gzn0Jz*96KUDj!CP`hQcr5SN!0##!8HHrWI|6>t;Fd@v$vxv*xi=f|!04I3|ix zX?~8sXPU=OwXYi%^=q#DP;x~>Hyy^kx=(%EJnx0(c`uZ7gW+?uv?TPT6+6 zXOATD_`>3%kHH@%#Nd30!Fy1(F7yFpKDdnb`xF!bKf^NH2P`v{6*Slc?#Q>^>(Orq zph*SX}H#;AbBA;X=MLj7x z@{J&?vw@ROKBwIDT!VP{XOF=YlCSI3bU+3~(>YTeqd|ZTO6*2;%QA>#5n8JmjdX_S zrtL7QAyLmc9E1xJ-GRdd$f}zrQ&9>WzHeG)qiWUdHb*(KY;nSNC}No|9^eA$@zeS~!3+Fu1T`q73xO-XDLhBfpw%snP6j@I zCh?K@>>Z!KkoZV^_KweAOME0gd&lQ*B|Z|Lz2ox}iI2o*7x+AQ;u`?^L`kOqK6fS9 ze_w;D`MU4WC#P<&9aKRbyH$ic!*xK40}KR_m?J@=bQDGQ;l;;WFseW++WKs!$VO++MUrNHJw88Y=(rTaHyN{R3`2qqbMVZR=`M^mXD`*g!0h? zvG}vzsG~uJ?(>i1^&S7&#gtmoaDL1kP9aASo!x7@b0B zB)W)o+l8qK&7K8Es!f{X_-=XO{_0X}rzQ%j7gZBzd0x56b;eimzu3pt(}dWX3$eA{ zsbM$5Dqw;tmZ6~?vf0<^*<3zLW^>o@Pd*cgU`(P!@kpWuBI*}O5fy48-O9y9D!!u= zr6B?GJ>E-;w;rvqDy{kO`S0E0^U;v-nGN;ZZni2IY84eJ=d{t8ws(7OURSQnbqyV# zQ?azz4owt>q^CbUQ$G>}HXry#mocNCt|0=PmFot@5uF-X1RF%!cidv&K)~IN}=TlN@84B(@+JwX6R0* z;Gvn?No6)R@|&CR3-5UAU12j5K^6+}O5nC{xOFOm$k@(=vbA`q+2W(Y77B4mvW0B@ zvA|aLP_s3N-MZRg3w&lbwt`4SLxj=_UVlO%`bL1LFc?JtIGPZl>UU+MoIwo~zW8jE z(;F|8qx63vybibjb4G(L>Hpen{ky={i-WQC9&~P~LAEK^>6XDrN@HctSPE2S>tz!Z zyH$69sRl7E2YCY3Yk_N|T2rgucTv$*-AvCxXO5X=r;^q)J;lJ)5+1^5z#WN9%{=#2CxiYc*u0jK)vSP?-TDq?X=y1TU86`X;rhPvxM?8jxMDx zJxOKZTN>lMdF6~}9>7wNmZg~Aj9?9Ax-Ja`h~%gyp!Rm)8?VE`XTa!eE ziTcZNCTb8HMIC9QhDy|5jWbb$*rotG;R42SWKkXZf#%miS}ch8g}y zVoutMqEQq%Y1@mVDN%3-%27VZQ8w2DByT<+F~V@jxM4-Urov zKq3cm5v%UB?FG)I^19v_HFmrvU=-zBBHT~kEQO7YkpI`YwLiV5# z@+*&;)r$y;e$MoA#j#1R#4&b_s!WV^jpc?FT6nlk+C>hC;@9|DAg8Jc<;u>eBf9;Q0K1iPOmqTlR ze3k5*TS#c-Mp-IXblcQ`WBIsbi87L81sXOM_xrkM2>}&eq4<5Q+n)MRVp6m{QzHsO zQq!B7skalN=5nZo^xL@}*aQ&~mIAf9+HrePq9i0XeX!95VVxZWn~@*>yV@E0TYR*# zvXLcO(#VppHienf{B_f%u??u+edYXg;QEs^yceY9D}k1G#)6jjdu3K20xzx!>zir; zg>rs^fmwO%Px+cx5^5Y@4SJQ+z`^A+gDalnouKp(}u0m4{ALoV*R!opY(MXW|lj*ngQYqARUr&go@G$kQ zR{grulqC;ytmHzq5RFt!d_-wTdCpGtI~`H|jnOA0oOLH!_T7G7-q&je>y)lhgNqZK=+! z1;@Y~o9dc>(~X-6nWONO>pg!hds!ya;qVEVpt;$7X&s3|k(Ov+mi|Q=C25of1?h!l z-3W#f=|cHr;QTIeV{^eZr8^F@on0*{o%6<%-7lh&Rm)C8;}|HrNb=WB3>9y3L%&9D0u*s5PdG}ZwPxQW706xk-|OV2%_91N9>r008&;h)@f zt>E)HuJ8cAZxG!q={v-#F-{$e+g%sq`hK7>uvPS>3RKhinYk<}%*;Vgm2TPoPn%== zA#GlasQekXMn$it6RObJ!>Z8Ph{{i@LVu|wW8VuQ`(DWPF!0d!)=@Dfix*oPMc8r8 zx%ljgBF%YUSpHWi2lJf`@xT9mbg;*s{{2aWKC=<&;64PK*!vP2HZA^+paY%~%4HjGnd`qwT8!X>Vh@X6jpATF0i?U2`IJ8fS z#;sZ_hg|F}3Pd?baQqlNSX~;8v=<>y_7JKTW5rf*XP%f0iE@z)^<-%3ML||)24QIA zCpL4~1Jm@9y97rMtiSQCr|7nv0^k2;;Hr}|dl^FHEdh~N#sU#H)2>?4_pmk#1@O9L zqs7KK$%bU3d8G%dfi(`FDao`?=0lrreS~$};|ho2u96XDqA0R$(hH!enS=nE3q_`X zmKz>Hq~_(fzz$Q~jf_|y(X)x-by)R_1)h{ty zHKI5aMS7tg=u9PrPIv?DFLJwL=Xtr}xQD?+ebsKiP)#d(afrn&sy=HC3&$P_o{~&; zW$M&p#xdm@GgW_1Oq!b~(Z0@!Q5S<$L!I{0jUJXmx6YvJE~;3XqU%x-Hf*M#9RN6o~?n z6#01wcC8*K1W!2P{ZaQmRiEKQucI~OO-n?!c?_Q#TSqC>-_vd2Wad4K?gt zl#wK=A5pp>t?`Oz9yIPf0*%RzXpW%78CyzZ-20v>d9)a4;E3ge^iJ=EhG4#QD>uvy zvDBfqdPGSniu6&vxf1gZT^)q0y=83sJe;j9)K2N0y-m#7s2aW@ypU?IMm)^;=Wpwy z-5cYg-5U`PGl|+wY!~QoxWP(p=uRPKPeo1=?uMkZg0$}LpPg8VNZJ{2{<}3C5h}eK z@emVfA4IJ_JnUM181WF}uhrwhJ(iy+$=Lk4kj-Bm!WPRxOky_uMd2ulH2S?j64!ZN z-aq5;=>awjFGoDe1eyp@v+s|GX5Wu^l*!ZV)G;L);~(By59&2^>mRelFA7Idr19?s z(s4mnSN6|De0Gq-0#_oQWdd!4sM-(4M71A8Jj?j2_5`Tb@7e!ANyh$P2}OAqv2LR~ z2OtVcQKT>EN!1@J2jUDu?ZshPj0n9>rZ4EN+I@5e2dP@=3p_vnV+CsscZgtd?J!QtlPKAMcloDS}-+kKo3K2Y6G=49{-tBl%#o#he zv&ng-t}MO2>QD#&-xnO?PCc;b_)0=p(;oB4w(@o!5 znI3v-Cs8O8CO;EvkMH^bT2Ba|@S2P@sM@HRB~dz(B!4u_8fT_Ih2evQSPDnWt+|zp zN{SiL400vnE#b*S!`U(#8Y_Ems8Oq6rl;B5?7ZB(?I2nDd!c+Zc=~h7p>%_ zK#Sm5bax3w3fjJf6rr}QmrbUTE$C`hX@i)SL$(+$*U$o2c$;8*xq#fj>&7|V&Y3j* zaG_?|nav1QVZ}}au5rfN!sMC7I?8Y?wRL*kfd3rou$x>DB+2}-}?b6+!F z^8|UhxtfZcZk>;Kgz+C!8Bn+TIB<3lx}D7NvL3qqFC`hL5Duu_$_>vebfF`rXAotj zDAF_Rp0Kt3vmOV6Pe|2k5f3HpNwfTP+_e2P;-SW0+b7q-_4+s2I4zXl37#I^0sQG2 zntsm8b%S!uE#J!T3`cDT9S3ywb1Vmc9UHoWj#>dCRPY#NxTdpA~C5Q<=M)ieYhgu*z<2SC}O>D#RJu_JuyVNQ(MV z^shoWxW4Le`64oaFIsMmrq~U*WVMi0MIhx_0;009ajaVTIqYi#5yEJv$4Qu*_L4 zooZbS_h$iB7oo>wWg;*_kzJ4&DgPmqmk%{YsCN|a02qDl#|XdWB2+is?J^B7ftvRr z0@O*OMlg%o&W6WY>yE%09KA^Ln~{5HpjaPC)Rdp^-eUdJXri`b>%TJyXEU8y1=DDn zDeT=-6X`;P+$*{KblG+l1(lNUD8CTO>4|{nYUJz`wR4~;#&tE_GD97PJR1~25lSq0 z{Yj+gKgY%dHTGhHs1sp=8qx#}29G%15R}Jw!gFOn3)JXufly$VBt%m`6CipkaQfj) zLHt1njcv-Y!Cb6T`DJiu zbh~?`S6rY_c)>A~2?Xlc4FRYFjq92Z&X3&8t+1LwRd(C3wwBsp*}j>Q8g(i~}QV#w!GLh3- zlf9v81XWC+>g-rh^(nzH!WFj7xb2TN+R3yAcZ@J*?&5vSN3{)qYiRDWVCxJx)5Zle z)6-Enp~R*oP92;o0#5nh>4(af%?#knuDL_YosL*ht<=qD{zz6|KP@$r>Ke?7;+j*W zpECu7u8loH3y4slb039KsQ=#!B@|mQTyGLl`ac1sHBLq}TKr3X4>besimM4{2+6fv3tjTYWL zRV{(ZikyBzAq00Zo@hcY3WS^*(&Kq$L}f0bbIolbiVoA z1IEj2fpgmM2Ru+bgh>qXwSdVCEwdcIb0a>wqR7roPf$+2ln^L|&>~{(Hm8~nMq`mW z_M&B2{3i8hH8HESmL*&KnJxB}J8!lbhx@yUGQAX8IL1e@GUefHB;k{mWUC)rbAq&9 z9fYlsADp|0jTT&|aE=;AYbp~N%tA$TI4DO|s9Cp0?yE|8Vs|Xvl<(ZO%JE#=`>=iR o7!G>}PW;YH#j3KICCZ)346Rr*c0t>oL9%}J{{yY+S)oV)0J>QYN&o-= literal 0 HcmV?d00001 diff --git a/R/NAO.R b/R/NAO.R index 6cb4976..5586985 100644 --- a/R/NAO.R +++ b/R/NAO.R @@ -417,9 +417,9 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', # add_member_back if (add_member_back) { - suppressWarnings( + suppressWarnings({ NAOO.ver <- InsertDim(NAOO.ver, 2, 1, name = names(dim(exp))[1]) - ) + }) } #NOTE: EOFs_obs is not returned because it's only the result of the last sdate -- GitLab