From 892832b04bb6c3704f5f7431d289afcbc2acc962 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 6 Nov 2020 09:26:48 +0100 Subject: [PATCH 1/4] Change atomic function to compiled one. It doesn't speed up the function though. --- R/Season.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/Season.R b/R/Season.R index b8743d3..c60d156 100644 --- a/R/Season.R +++ b/R/Season.R @@ -36,8 +36,9 @@ #'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2) #'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2, na.rm = FALSE) #'@import multiApply +#'@importFrom compiler cmpfun #'@export -Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, +Season3 <- function(data, time_dim = 'ftime', monini, moninf, monsup, method = mean, na.rm = TRUE, ncores = NULL) { # Check inputs @@ -125,7 +126,7 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, return(res) } -.Season <- function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { +.Season_uncompiled <- function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { #### Create position index: # Basic index: @@ -148,4 +149,5 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, return(timeseries) } +.Season <- cmpfun(.Season_uncompiled) -- GitLab From 4a7d2e7ede9827c9974f289df31f6d482e61e9c8 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 6 Nov 2020 09:52:51 +0100 Subject: [PATCH 2/4] Fix typo --- R/Season.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/Season.R b/R/Season.R index c60d156..6f09ffc 100644 --- a/R/Season.R +++ b/R/Season.R @@ -38,7 +38,7 @@ #'@import multiApply #'@importFrom compiler cmpfun #'@export -Season3 <- function(data, time_dim = 'ftime', monini, moninf, monsup, +Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, method = mean, na.rm = TRUE, ncores = NULL) { # Check inputs -- GitLab From c912318e2935cb24894bcd0834cb57b7550a222c Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 11 Nov 2020 10:53:25 +0100 Subject: [PATCH 3/4] Compile .Season --- R/Season.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/Season.R b/R/Season.R index 6f09ffc..e71fd63 100644 --- a/R/Season.R +++ b/R/Season.R @@ -126,7 +126,7 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, return(res) } -.Season_uncompiled <- function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { +.Season <- compiler::cmpfun(function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { #### Create position index: # Basic index: @@ -148,6 +148,5 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, timeseries <- as.array(timeseries) return(timeseries) -} -.Season <- cmpfun(.Season_uncompiled) +}) -- GitLab From 56fe57ee2f11a3bf1fb11fd4b45edfd635ee6a55 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 11 Nov 2020 14:08:18 +0100 Subject: [PATCH 4/4] Improve Season() speed by using apply() instead of Apply() when ncores is NULL or 1. --- NEWS.md | 1 + R/Season.R | 30 +++++++++++++++++++++++--- tests/testthat/test-Season.R | 42 ++++++++++++++++++++++++++++++++++++ 3 files changed, 70 insertions(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 9979a52..ffcc48e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,6 +8,7 @@ - Add p-value by ANOVA in Trend(). - Change MeanDims() na.rm default to FALSE to be in line with mean() - Remove unecessary parameter checks in Clim() +- Improve Season() performance by using apply() when 'ncores' is not bigger than 1 # s2dv 0.0.1 (Release date: 2020-02-07) - The package is the advanced version of package 's2dverification', adopting the regime of package 'multiApply' for all the analytic functions. Most of the other functions for plotting and data retrieval in 's2dverification' are also preserved in this package. diff --git a/R/Season.R b/R/Season.R index e71fd63..7bc5c52 100644 --- a/R/Season.R +++ b/R/Season.R @@ -36,7 +36,6 @@ #'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2) #'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2, na.rm = FALSE) #'@import multiApply -#'@importFrom compiler cmpfun #'@export Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, method = mean, na.rm = TRUE, ncores = NULL) { @@ -116,6 +115,29 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, monsup <- monsup + 12 } +# if (ncores == 1 | is.null(ncores)) { use apply } else { use Apply } + if (!is.null(ncores)) { + if (ncores == 1) { + use_apply <- TRUE + } else { + use_apply <- FALSE + } + } else { + use_apply <- TRUE + } + + if (use_apply) { + time_dim_ind <- match(time_dim, names(dim(data))) + res <- apply(data, c(1:length(dim(data)))[-time_dim_ind], .Season, + monini = monini, moninf = moninf, monsup = monsup, + method = method, na.rm = na.rm) + if (length(dim(res)) < length(dim(data))) { + res <- InsertDim(res, posdim = 1, lendim = 1, name = time_dim) + } else { + names(dim(res))[1] <- time_dim + } + + } else { res <- Apply(list(data), target_dims = time_dim, output_dims = time_dim, @@ -123,10 +145,12 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, monini = monini, moninf = moninf, monsup = monsup, method = method, na.rm = na.rm, ncores = ncores)$output1 + } + return(res) } -.Season <- compiler::cmpfun(function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { +.Season <- function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { #### Create position index: # Basic index: @@ -148,5 +172,5 @@ Season <- function(data, time_dim = 'ftime', monini, moninf, monsup, timeseries <- as.array(timeseries) return(timeseries) -}) +} diff --git a/tests/testthat/test-Season.R b/tests/testthat/test-Season.R index 4ed9b12..36c3027 100644 --- a/tests/testthat/test-Season.R +++ b/tests/testthat/test-Season.R @@ -72,24 +72,46 @@ test_that("2. Output checks: dat1", { dim(Season(dat1, monini = 1, moninf = 1, monsup = 2)), c(ftime = 3, member = 2, sdate = 2, lon = 3) ) + expect_equal( + dim(Season(dat1, monini = 1, moninf = 1, monsup = 2, ncores = 2)), + c(ftime = 3, member = 2, sdate = 2, lon = 3) + ) expect_equal( dim(Season(dat1, time_dim = 'lon', monini = 1, moninf = 1, monsup = 2)), c(lon = 1, member = 2, ftime = 36, sdate = 2) ) + expect_equal( + dim(Season(dat1, time_dim = 'lon', monini = 1, moninf = 1, monsup = 2, ncores = 2)), + c(lon = 1, member = 2, ftime = 36, sdate = 2) + ) expect_equal( dim(Season(dat1, monini = 10, moninf = 12, monsup = 2)), c(ftime = 3, member = 2, sdate = 2, lon = 3) ) + expect_equal( + dim(Season(dat1, monini = 10, moninf = 12, monsup = 2, ncores = 2)), + c(ftime = 3, member = 2, sdate = 2, lon = 3) + ) expect_equal( median(Season(dat1, monini = 10, moninf = 12, monsup = 2)), 0.007925, tolerance = 0.0001 ) + expect_equal( + median(Season(dat1, monini = 10, moninf = 12, monsup = 2, ncores = 2)), + 0.007925, + tolerance = 0.0001 + ) expect_equal( median(Season(dat1, monini = 10, moninf = 2, monsup = 5, method = sum)), 0.2732015, tolerance = 0.0001 ) + expect_equal( + median(Season(dat1, monini = 10, moninf = 2, monsup = 5, method = sum, ncores = 2)), + 0.2732015, + tolerance = 0.0001 + ) }) @@ -101,21 +123,41 @@ test_that("3. Output checks: dat2", { -0.01986671, tolerance = 0.0001 ) + expect_equal( + median(Season(dat2, monini = 10, moninf = 12, monsup = 2, ncores = 2)), + -0.01986671, + tolerance = 0.0001 + ) expect_equal( median(Season(dat2, monini = 10, moninf = 12, monsup = 2, na.rm = F), na.rm = TRUE), 0.06207006, tolerance = 0.0001 ) + expect_equal( + median(Season(dat2, monini = 10, moninf = 12, monsup = 2, na.rm = F, ncores = 2), na.rm = TRUE), + 0.06207006, + tolerance = 0.0001 + ) res <- Season(dat2, monini = 10, moninf = 12, monsup = 2, na.rm = F) expect_equal( length(res[which(is.na(as.vector(res)))]), 10 ) + res <- Season(dat2, monini = 10, moninf = 12, monsup = 2, na.rm = F, ncores = 2) + expect_equal( + length(res[which(is.na(as.vector(res)))]), + 10 + ) res <- Season(dat2, monini = 10, moninf = 12, monsup = 2) expect_equal( length(res[which(is.na(as.vector(res)))]), 0 ) + res <- Season(dat2, monini = 10, moninf = 12, monsup = 2, ncores = 2) + expect_equal( + length(res[which(is.na(as.vector(res)))]), + 0 + ) }) ############################################## -- GitLab