Commit 71f3967b authored by aho's avatar aho
Browse files

Add 'ncores' in those functions used internally.

parent 5dc785fc
Pipeline #5073 failed with stage
in 1 minute and 44 seconds
......@@ -283,8 +283,8 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
exp_ori <- exp
obs_ori <- obs
}
exp <- MeanDims(exp, memb_dim, na.rm = TRUE)
obs <- MeanDims(obs, memb_dim, na.rm = TRUE)
exp <- MeanDims(exp, memb_dim, na.rm = TRUE, ncores = ncores)
obs <- MeanDims(obs, memb_dim, na.rm = TRUE, ncores = ncores)
}
if (is.null(avg_dim)) {
......@@ -292,11 +292,9 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
target_dims = list(c(space_dim, dat_dim),
c(space_dim, dat_dim)),
fun = .ACC,
dat_dim = dat_dim,
#space_dim = space_dim,
avg_dim = avg_dim,
conftype = conftype,
pval = pval, conf = conf, conf.lev = conf.lev,
dat_dim = dat_dim, avg_dim = avg_dim,
conftype = conftype, pval = pval, conf = conf, conf.lev = conf.lev,
ncores_input = ncores,
ncores = ncores)
if (conftype == 'bootstrap') {
......@@ -304,17 +302,17 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
target_dims = list(c(memb_dim, dat_dim, space_dim),
c(memb_dim, dat_dim, space_dim)),
fun = .ACC_bootstrap,
dat_dim = dat_dim, memb_dim = memb_dim,
#space_dim = space_dim,
avg_dim = avg_dim,
conftype = conftype,
pval = pval, conf = conf, conf.lev = conf.lev,
dat_dim = dat_dim, memb_dim = memb_dim, avg_dim = avg_dim,
conftype = conftype, pval = pval, conf = conf, conf.lev = conf.lev,
ncores_input = ncores,
ncores = ncores)
#NOTE: pval?
res <- list(acc = res$acc,
acc_conf.lower = res_conf$acc_conf.lower, acc_conf.upper = res_conf$acc_conf.upper,
acc_conf.lower = res_conf$acc_conf.lower,
acc_conf.upper = res_conf$acc_conf.upper,
macc = res$macc,
macc_conf.lower = res_conf$macc_conf.lower, macc_conf.upper = res_conf$macc_conf.upper)
macc_conf.lower = res_conf$macc_conf.lower,
macc_conf.upper = res_conf$macc_conf.upper)
}
} else {
......@@ -322,28 +320,26 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
target_dims = list(c(space_dim, avg_dim, dat_dim),
c(space_dim, avg_dim, dat_dim)),
fun = .ACC,
dat_dim = dat_dim,
#space_dim = space_dim,
avg_dim = avg_dim,
conftype = conftype,
pval = pval, conf = conf, conf.lev = conf.lev,
dat_dim = dat_dim, avg_dim = avg_dim,
conftype = conftype, pval = pval, conf = conf, conf.lev = conf.lev,
ncores_input = ncores,
ncores = ncores)
if (conftype == 'bootstrap') {
res_conf <- Apply(list(exp_ori, obs_ori),
target_dims = list(c(memb_dim, dat_dim, avg_dim, space_dim),
c(memb_dim, dat_dim, avg_dim, space_dim)),
fun = .ACC_bootstrap,
dat_dim = dat_dim, memb_dim = memb_dim,
#space_dim = space_dim,
avg_dim = avg_dim,
conftype = conftype,
pval = pval, conf = conf, conf.lev = conf.lev,
ncores = ncores)
target_dims = list(c(memb_dim, dat_dim, avg_dim, space_dim),
c(memb_dim, dat_dim, avg_dim, space_dim)),
fun = .ACC_bootstrap,
dat_dim = dat_dim, memb_dim = memb_dim, avg_dim = avg_dim,
conftype = conftype, pval = pval, conf = conf, conf.lev = conf.lev,
ncores_input = ncores,
ncores = ncores)
res <- list(acc = res$acc,
acc_conf.lower = res_conf$acc_conf.lower, acc_conf.upper = res_conf$acc_conf.upper,
acc_conf.lower = res_conf$acc_conf.lower,
acc_conf.upper = res_conf$acc_conf.upper,
macc = res$macc,
macc_conf.lower = res_conf$macc_conf.lower, macc_conf.upper = res_conf$macc_conf.upper)
macc_conf.lower = res_conf$macc_conf.lower,
macc_conf.upper = res_conf$macc_conf.upper)
}
......@@ -355,7 +351,8 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
.ACC <- function(exp, obs, dat_dim = 'dataset', #space_dim = c('lat', 'lon'),
avg_dim = 'sdate', #memb_dim = NULL,
lon = NULL, lat = NULL, lonlatbox = NULL,
conf = TRUE, conftype = "parametric", conf.lev = 0.95, pval = TRUE) {
conf = TRUE, conftype = "parametric", conf.lev = 0.95, pval = TRUE,
ncores_input = NULL) {
# if (is.null(avg_dim))
# exp: [space_dim, dat_exp]
......@@ -423,7 +420,7 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
# calculate effective sample size along space_dim
# combine space_dim into one dim first
obs_tmp <- array(obs_sub, dim = c(space = length(obs_sub)))
eno <- Eno(obs_tmp, 'space') # a number
eno <- Eno(obs_tmp, 'space', ncores = ncores_input) # a number
if (pval) {
t <- qt(conf.lev, eno - 2) # a number
p.val[iexp, iobs] <- sqrt(t^2 / (t^2 + eno - 2))
......@@ -461,7 +458,7 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
# combine space_dim into one dim first
obs_tmp <- array(obs_sub, dim = c(space = prod(dim(obs_sub)[-length(dim(obs_sub))]),
dim(obs_sub)[length(dim(obs_sub))]))
eno <- Eno(obs_tmp, 'space') # a vector of avg_dim
eno <- Eno(obs_tmp, 'space', ncores = ncores_input) # a vector of avg_dim
if (pval) {
t <- qt(conf.lev, eno - 2) # a vector of avg_dim
p.val[iexp, iobs, ] <- sqrt(t^2 / (t^2 + eno - 2))
......@@ -513,9 +510,10 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
.ACC_bootstrap <- function(exp, obs, dat_dim = 'dataset', #space_dim = c('lat', 'lon'),
avg_dim = 'sdate', memb_dim = NULL,
lon = NULL, lat = NULL, lonlatbox = NULL,
conf = TRUE, conftype = "parametric", conf.lev = 0.95, pval = TRUE) {
avg_dim = 'sdate', memb_dim = NULL,
lon = NULL, lat = NULL, lonlatbox = NULL,
conf = TRUE, conftype = "parametric", conf.lev = 0.95, pval = TRUE,
ncores_input = NULL) {
# if (is.null(avg_dim))
# exp: [memb_exp, dat_exp, space_dim]
# obs: [memb_obs, dat_obs, space_dim]
......@@ -560,8 +558,8 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
dim = dim(obs))
# ensemble mean before .ACC
drawexp <- MeanDims(drawexp, memb_dim, na.rm = TRUE)
drawobs <- MeanDims(drawobs, memb_dim, na.rm = TRUE)
drawexp <- MeanDims(drawexp, memb_dim, na.rm = TRUE, ncores = ncores_input)
drawobs <- MeanDims(drawobs, memb_dim, na.rm = TRUE, ncores = ncores_input)
# Reorder
if (is.null(avg_dim)) {
drawexp <- Reorder(drawexp, c(2, 3, 1))
......@@ -572,7 +570,8 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
}
#calculate the ACC of the randomized field
tmpACC <- .ACC(drawexp, drawobs, conf = FALSE, pval = FALSE, avg_dim = avg_dim)
tmpACC <- .ACC(drawexp, drawobs, conf = FALSE, pval = FALSE, avg_dim = avg_dim,
ncores_input = ncores_input)
if (is.null(avg_dim)) {
acc_draw[, , jdraw] <- tmpACC$acc
} else {
......@@ -616,6 +615,4 @@ ACC <- function(exp, obs, dat_dim = 'dataset', space_dim = c('lat', 'lon'),
macc_conf.upper = macc_conf.upper))
}
}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment