From 4db7cb27076b3a5beb9bdd7c5e9cd4c69866c7c8 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 24 Nov 2023 16:16:16 +0100 Subject: [PATCH] Correct output dims when dat_dim and memb_dim are NULL --- R/Corr.R | 65 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 41 insertions(+), 24 deletions(-) diff --git a/R/Corr.R b/R/Corr.R index c11fcf6..744ff10 100644 --- a/R/Corr.R +++ b/R/Corr.R @@ -282,22 +282,27 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, .Corr <- function(exp, obs, dat_dim = NULL, memb_dim = 'member', time_dim = 'sdate', method = 'pearson', conf = TRUE, pval = TRUE, sign = FALSE, alpha = 0.05) { + + if (is.null(dat_dim)) { + nexp <- 1 + nobs <- 1 + } else { + nexp <- as.numeric(dim(exp)[dat_dim]) + nobs <- as.numeric(dim(obs)[dat_dim]) + } + if (is.null(memb_dim)) { + CORR <- array(dim = c(nexp = nexp, nobs = nobs)) + if (is.null(dat_dim)) { # exp: [sdate] # obs: [sdate] - nexp <- 1 - nobs <- 1 - CORR <- array(dim = c(nexp = nexp, nobs = nobs)) if (any(!is.na(exp)) && sum(!is.na(obs)) > 2) { - CORR <- cor(exp, obs, use = "pairwise.complete.obs", method = method) + CORR[, ] <- cor(exp, obs, use = "pairwise.complete.obs", method = method) } } else { # exp: [sdate, dat_exp] # obs: [sdate, dat_obs] - nexp <- as.numeric(dim(exp)[dat_dim]) - nobs <- as.numeric(dim(obs)[dat_dim]) - 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) { @@ -328,13 +333,11 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, exp_memb <- as.numeric(dim(exp)[memb_dim]) # memb_dim obs_memb <- as.numeric(dim(obs)[memb_dim]) + CORR <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) + if (is.null(dat_dim)) { # exp: [sdate, memb_exp] # obs: [sdate, memb_obs] - nexp <- 1 - nobs <- 1 - CORR <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) - for (j in 1:obs_memb) { for (y in 1:exp_memb) { @@ -349,11 +352,6 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, } else { # exp: [sdate, dat_exp, memb_exp] # obs: [sdate, dat_obs, memb_obs] - nexp <- as.numeric(dim(exp)[dat_dim]) - nobs <- as.numeric(dim(obs)[dat_dim]) - - CORR <- array(dim = c(nexp = nexp, nobs = nobs, exp_memb = exp_memb, obs_memb = obs_memb)) - for (j in 1:obs_memb) { for (y in 1:exp_memb) { CORR[, , y, j] <- sapply(1:nobs, function(i) { @@ -438,14 +436,33 @@ Corr <- function(exp, obs, time_dim = 'sdate', dat_dim = NULL, ################################### # Remove nexp and nobs if dat_dim = NULL - if (is.null(dat_dim) & !is.null(memb_dim)) { - dim(CORR) <- dim(CORR)[3:length(dim(CORR))] - if (pval) { - dim(p.val) <- dim(p.val)[3:length(dim(p.val))] - } - if (conf) { - dim(conflow) <- dim(conflow)[3:length(dim(conflow))] - dim(confhigh) <- dim(confhigh)[3:length(dim(confhigh))] + if (is.null(dat_dim)) { +# if (is.null(dat_dim) & !is.null(memb_dim)) { + + if (length(dim(CORR)) == 2) { + dim(CORR) <- NULL + if (pval) { + dim(p.val) <- NULL + } + if (conf) { + dim(conflow) <- NULL + dim(confhigh) <- NULL + } + if (sign) { + dim(signif) <- NULL + } + } else { + dim(CORR) <- dim(CORR)[3:length(dim(CORR))] + if (pval) { + dim(p.val) <- dim(p.val)[3:length(dim(p.val))] + } + if (conf) { + dim(conflow) <- dim(conflow)[3:length(dim(conflow))] + dim(confhigh) <- dim(confhigh)[3:length(dim(confhigh))] + } + if (sign) { + dim(signif) <- dim(signif)[3:length(dim(signif))] + } } } -- GitLab