#'Compute the residual correlation and its significance
#'
#'The residual correlation assesses whether a forecast captures any of the 
#'observed variability that is not already captured by a reference forecast 
#'(Smith et al., 2019; https://doi.org/10.1038/s41612-019-0071-y.).
#'The procedure is as follows: the residuals of the forecasts and observations 
#'are computed by linearly regressing out the reference forecast's ensemble mean
#'from the forecasts' ensemble mean and observations, respectively. Then, the 
#'residual correlation is computed as the correlation between both residuals. 
#'Positive values of the residual correlation indicate that the forecast capture
#'more observed variability than the reference forecast, while negative values  
#'mean that the reference forecast capture more. The significance of the 
#'residual correlation is computed with a two-sided t-test
#'(Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7) using an 
#'effective degrees of freedom to account for the time series' autocorrelation 
#'(von Storch and Zwiers, 1999; https://doi.org/10.1017/CBO9780511612336).
#'
#'@param exp A named numerical array of the forecast with at least time 
#'  dimension. 
#'@param ref A named numerical array of the reference forecast data with at 
#'  least time dimension. The dimensions must be the same as "exp" except 
#'  'memb_dim'.
#'@param obs A named numerical array of the observations with at least time 
#'  dimension. The dimensions must be the same as "exp" except 'memb_dim'.
#'@param time_dim A character string indicating the name of the time dimension.
#'  The default value is 'year'.
#'@param memb_dim A character string indicating the name of the member dimension
#'  to compute the ensemble mean of the forecast and reference forecast. If it 
#'  is NULL, the ensemble mean should be provided directly to the function. The
#'  default value is NULL.
#'@param method A character string indicating the correlation coefficient to be
#'  computed ("pearson", "kendall", or "spearman"). The default value is 
#'  "pearson".
#'@param alpha A numeric of the significance level to be used in the statistical
#'  significance test. If it is a numeric, "sign" will be returned. If NULL, the
#'  p-value will be returned instead. The default value is NULL.
#'@param ncores An integer indicating the number of cores to use for parallel 
#'  computation. The default value is NULL.
#'
#'@return A list with:
#'\item{$r}{
#'  A numerical array of the residual correlation with the same dimensions as 
#'  the input arrays except "time_dim" (and "memb_dim" if provided).
#'}
#'\item{$sign}{
#'  A logical array of the statistical significance of the residual correlation
#'  with the same dimensions as the input arrays except "time_dim" (and 
#'  "memb_dim" if provided). Returned only if "alpha" is a numeric.
#'}
#'\item{$p.val}{
#'  A numeric array of the p-values with the same dimensions as the input arrays
#'  except "time_dim" (and "memb_dim" if provided). Returned only if "alpha" is
#'  NULL.
#'}
#'
#'@examples
#' exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, year = 50))
#' ref <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, year = 50))
#' obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, year = 50))
#' res <- ResidualCorr(exp, ref, obs, memb_dim = 'member')
#'
#'@import multiApply
#'@export
ResidualCorr <- function(exp, ref, obs, time_dim = 'year', memb_dim = NULL, 
                         method = 'pearson', alpha = NULL, ncores = NULL) {
  
  # Check inputs
  ## exp, ref, and obs (1)
  if (!is.array(exp) | !is.numeric(exp))
    stop('Parameter "exp" must be a numeric array.')
  if (!is.array(ref) | !is.numeric(ref))
    stop('Parameter "ref" must be a numeric array.')
  if (!is.array(obs) | !is.numeric(obs))
    stop('Parameter "obs" must be a numeric array.')

  ## time_dim
  if (!is.character(time_dim) | length(time_dim) != 1)
    stop('Parameter "time_dim" must be a character string.')
  if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(ref)) | 
      !time_dim %in% names(dim(obs))) {
    stop("Parameter 'time_dim' is not found in 'exp', 'ref', or 'obs' dimension.")
  }
  ## memb_dim
  if (!is.null(memb_dim)) {
    if (!is.character(memb_dim) | length(memb_dim) > 1) {
      stop("Parameter 'memb_dim' must be a character string.")
    }
    if (!memb_dim %in% names(dim(exp)) | !memb_dim %in% names(dim(ref))) {
      stop("Parameter 'memb_dim' is not found in 'exp' or 'ref' dimension.")
    }
  }
  ## exp, ref, and obs (2)
  name_exp <- sort(names(dim(exp)))
  name_ref <- sort(names(dim(ref)))
  name_obs <- sort(names(dim(obs)))
  if (!is.null(memb_dim)) {
    name_exp <- name_exp[-which(name_exp == memb_dim)]
    name_ref <- name_ref[-which(name_ref == memb_dim)]
  }
  if (!all.equal(dim(exp)[name_exp], dim(ref)[name_ref], dim(obs)[name_obs])) {
    stop(paste0("Parameter 'exp', 'ref', and 'obs' must have same length of ",
                "all dimensions expect 'memb_dim'."))
  }
  ## method
  if (!method %in% c("pearson", "kendall", "spearman")) {
    stop('Parameter "method" must be "pearson", "kendall", or "spearman".')
  }
  ## alpha
  if (!is.null(alpha)) {
    if (any(!is.numeric(alpha) | alpha <= 0 | alpha >= 1 |  
        length(alpha) > 1)) {
      stop('Parameter "alpha" must be NULL or a number between 0 and 1.')
    }
  }
  ## ncores
  if (!is.null(ncores)) {
    if (any(!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 |
        length(ncores) > 1)) {
      stop('Parameter "ncores" must be either NULL or a positive integer.')
    }
  }

  ###############################

  # Calculate ensemble mean
  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)
    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]))
  }
 
  # output_dims
  if (is.null(alpha)) {
    output_dims <- list(r = NULL, p.val = NULL)
  } else {
    output_dims <- list(r = NULL, sign = NULL)
  }
 
  ## Residual correlation and its significance
  output <- Apply(data = list(exp = exp, ref = ref, obs = obs),
                  target_dims = time_dim, fun = .ResidualCorr,
                  method = method, 
                  alpha = alpha, ncores = ncores)
  return(output)
}

.ResidualCorr <- function(exp, ref, obs, method, alpha) {
  # exp and ref and obs: [time]

  if (!anyNA(exp) & !anyNA(ref) & !anyNA(obs)) {
    
    # Residuals of 'exp' and 'obs' (regressing 'ref' out in both 'exp' and 'obs')
    exp_res <- lm(formula = y ~ x, data = list(y = exp, x = ref), na.action = NULL)$residuals
    obs_res <- lm(formula = y ~ x, data = list(y = obs, x = ref), na.action = NULL)$residuals
    
    # Residual correlation (and significance)
    residual_cor <- NULL
    residual_cor$r <- cor(x = exp_res, y = obs_res, method = method)
    
    # Effective degrees of freedom
    n_eff <- .Eno(x = obs_res, na.action = na.pass)
    
    ## Statistic
    t <- abs(residual_cor$r) * sqrt(n_eff - 2) / sqrt(1 - residual_cor$r^2)
    
    if (is.null(alpha)) { # p-value
      residual_cor$p.val <- pt(q = t, df = n_eff - 2, lower.tail = FALSE)
    } else {
      t_alpha2_n2 <- qt(p = alpha / 2, df = n_eff - 2, lower.tail = FALSE)
      if (!anyNA(c(t,t_alpha2_n2)) & t >= t_alpha2_n2) {
        residual_cor$sign <- TRUE
      } else {
        residual_cor$sign <- FALSE
      }
    }
    
  } else { # There is NA
    
    if (is.null(alpha)) {
      residual_cor <- list(r = NA, p.val = NA)
    } else {
      residual_cor <- list(r = NA, sign = NA)
    }
    
  }
  
  return(residual_cor)
}
