
library(s2dv)
library(multiApply)

DiffCorr <- function(exp, ref, obs, conf.lev = NULL, handle.na = 'return.na', time_dim = 'year', member_dim = NULL, ncores = NULL){
  
  ## Checkings
  if (!is.array(exp)){stop('"exp" must be an array.')}
  if (!is.array(obs)){stop('"obs" must be an array.')}
  if (!is.array(ref)){stop('"ref" must be an array.')}
  if (!identical(as.numeric(dim(exp)[time_dim]), as.numeric(dim(ref)[time_dim]))){stop('"time_dim" must have the same length in "exp" and "ref".')}
  if (!identical(as.numeric(dim(exp)[time_dim]), as.numeric(dim(obs)[time_dim]))){stop('"time_dim" must have the same length in "exp" and "obs".')}
  if (!is.null(conf.lev)){
    if (!is.numeric(conf.lev) | conf.lev <= 0 | conf.lev >= 1){stop('"conf.lev" must be either NULL or a number between 0 and 1.')}
  }
  if (!is.character(time_dim)){stop('"time_dim" must be a string.')}
  if (!is.null(member_dim)){
    if (!is.character(member_dim)){stop('"member_dim" must be either NULL or a string.')}
  }
  if (!is.null(ncores)){
    if (!is.numeric(ncores) | ncores < 1){stop('"ncores" must be either NULL or a positive integer.')}
  }
  
  ## Ensemble means
  if (!is.null(member_dim)){
    exp <- multiApply::Apply(data = exp, target_dims = member_dim, fun = mean, na.rm = FALSE, ncores = ncores)$output1
    ref <- multiApply::Apply(data = ref, target_dims = member_dim, fun = mean, na.rm = FALSE, ncores = ncores)$output1
  }
  
  ## Correlation difference
  output <- multiApply::Apply(data = list(exp = exp, ref = ref, obs = obs),
                              target_dims = time_dim, fun = .DiffCorr,
                              conf.lev = conf.lev, handle.na = handle.na, 
                              time_dim = time_dim, ncores = ncores)
  return(output)
}

.DiffCorr <- function(exp, ref, obs, conf.lev, handle.na, time_dim) {
  
  ## handle NA's
  if (handle.na == "na.fail") {
    if (any(is.na(c(exp, ref, obs)))) {
      stop("There are missing values.")
    }
  } else if (handle.na == "only.complete.triplets") {
    nna <- !is.na(fcst) & !is.na(fcst.ref) & !is.na(obs)
    if (all(nna == FALSE)) {
      stop("There are no complete sets of forecasts and observations")
    }
    exp <- exp[nna]
    ref <- ref[nna]
    obs <- obs[nna]
  } else if (handle.na != "return.na") {
    stop("unknown 'handle.na' argument")
  }
  
  ## Number of effective degrees of freedom
  N <- s2dv::Eno(data = obs, time_dim = time_dim, na.action = na.pass, ncores = 1)
  
  ## Correlation coefficients and their confidence intervals
  cor.exp <- cor(exp, obs)
  cor.ref <- cor(ref, obs)
  
  ## Correlation difference
  output <- NULL
  output$corr.diff <- cor.exp - cor.ref
  
  ## auxiliary quantities
  r12 <- cor.exp
  r13 <- cor.ref
  r23 <- cor(exp, ref)
  
  ## confidence interval, according to Zou (2007)
  if (!is.null(conf.lev)){

    ## individual confidence limits of cor.exp and cor.ref (not used)
    # z.exp <- 0.5 * log((1 + cor.exp) / (1 - cor.exp))
    # z.ref <- 0.5 * log((1 + cor.ref) / (1 - cor.ref))
    
    alpha <- (1. - conf.lev) / 2.
    l1 <- tanh(atanh(r12) + qnorm(alpha)/sqrt(N-3))
    u1 <- tanh(atanh(r12) + qnorm(1-alpha)/sqrt(N-3))
    l2 <- tanh(atanh(r13) + qnorm(alpha)/sqrt(N-3))
    u2 <- tanh(atanh(r13) + qnorm(1-alpha)/sqrt(N-3))
    
    ## Correlation between the two corr.coef r12 and r13
    c.12.13 <- ((r23 - 0.5 * r12 * r13) * (1 - r12*r12 - r13*r13 - r23*r23) + r23*r23*r23) / ((1 - r12*r12) * (1 - r13*r13))
    
    ## Confidence interval
    output$conf.lower <- r12 - r13 - sqrt((r12-l1)^2 + (u2 - r13)^2 - 2*c.12.13*(r12-l1)*(u2-r13))
    output$conf.upper <- r12 - r13 + sqrt((u1 - r12)^2 + (r13-l2)^2 - 2*c.12.13*(u1-r12)*(r13-l2))
    
  }
  
  ## p-value of one-sided test for equality of dependent correlation coefficients (Steiger, 1980)
  R <- (1-r12*r12-r13*r13-r23*r23) + 2*r12*r13*r23
  t <- (r12 - r13) * sqrt((N-1)*(1+r23) / (2 * ((N-1)/(N-3)) * R + 0.25*(r12+r13)^2 * (1-r23)^3))
  output$p.value <- 1 - pt(t, df=N-3)
  
  return(output)
}
