#'Compute the correlation coefficient between an array of forecast and their corresponding observation
#'
#'Calculate the correlation coefficient (Pearson, Kendall or Spearman) for 
#'an array of forecast and an array of observation.  
#'The correlations are computed along sdate_dim, the dimension corresponding 
#'to the startdate dimension. If comp_dim is given, the correlations are 
#'computed only if data along the comp_dim dimension are complete between  
#'limits[1] and limits[2], i.e., there is no NA between limits[1] and 
#'limits[2]. This option can be activated if the user wishes to account only 
#'for the forecasts which the corresponding observations are available at all 
#'leadtimes. \cr 
#'The confidence interval is computed by the Fisher transformation.\cr 
#'The significance level relies on an one-sided student-T distribution.\cr 
#'
#'@param exp A named numeric array of experimental data, with at least two 
#'  dimensions 'sdate_dim' and 'memb_dim'.
#'@param obs A named numeric array of observational data, same dimensions as  
#'  parameter 'exp' except along memb_dim.
#'@param memb_dim A character string indicating the name of member (nobs/nexp) 
#'  dimension. The default value is 'member'.
#'@param sdate_dim A character string indicating the name of dimension along  
#'  which the correlations are computed. The default value is 'sdate'.
#'@param comp_dim A character string indicating the name of dimension along which
#'  the data is taken into account only if it is complete. The default value
#'  is NULL.
#'@param limits A vector of two integers indicating the range along comp_dim to 
#'  be completed. The default is c(1, length(comp_dim dimension)).
#'@param siglev A numeric indicating the confidence level for the 
#'  regression computation. The default value is 0.95.
#'@param method A character string indicating the type of correlation: 
#'  'pearson', 'spearman', or 'kendall'. The default value is 'pearson'.
#'@param conf A logical value indicating whether to retrieve the confidence 
#'  intervals or not. The default value is TRUE.
#'@param pval A logical value indicating whether to compute or not the p-value 
#'  of the test Ho: Corr = 0. The default value is TRUE.
#'@param ncores An integer indicating the number of cores to use for parallel 
#'  computation. The default value is 1.
#'
#'@return 
#'A list containing the numeric arrays with dimension:\cr 
#'(# of datasets along memb_dim in exp, # of datasets along memb_dim in obs, 
#'all other dimensions of exp & obs except sdate_dim).\cr 
#'\item{$corr}{
#'  The correlation coefficient. 
#'}
#'\item{$p_val}{
#'  The p-value. Only present if \code{pval = TRUE}.
#'}
#'\item{$conf.lower}{
#'  The lower confidence interval. Only present if \code{conf = TRUE}.
#'}
#'\item{$conf.upper}{
#'  The upper confidence interval. Only present if \code{conf = TRUE}.
#'}
#'
#'@keywords datagen
#'@author History:\cr
#'0.1  -  2011-04  (V. Guemas, \email{vguemas@bsc.es})  -  Original code\cr
#'1.0  -  2013-09  (N. Manubens, \email{nicolau.manubens@bsc.es})  -  Formatting to R CRAN\cr
#'1.1  -  2014-10  (M. Menegoz, \email{martin.menegoz@bsc.es})  -  Adding siglev argument\cr
#'1.2  -  2015-03  (L.P. Caron, \email{louis-philippe.caron@@bsc.es})  - Adding method argument\cr
#'1.3  -  2017-02  (A. Hunter, \email{alasdair.hunter@bsc.es})  -  Adapted to veriApply()
#'3.0  -  2020-01  (A. Ho, \email{an.ho@bsc.es})  -  Adapt to multiApply
#'@examples
#'# Load sample data as in Load() example: 
#'example(Load) 
#'clim <- Clim(sampleData$mod, sampleData$obs) 
#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) 
#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) 
#'runmean_months <- 12 
#'dim_to_smooth <- 4  
#'# Smooth along lead-times   
#'smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) 
#'smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) 
#'leadtimes_per_startdate <- 60 
#'corr <- Corr(smooth_ano_exp, 
#'             smooth_ano_obs,
#'             comp_dim = 'ftime', #Discard start dates which contain any NA ftime             
#'             limits = c(ceiling((runmean_months + 1) / 2),                         
#'             leadtimes_per_startdate - floor(runmean_months / 2))) 
#'
#'@rdname Corr
#'@importFrom stats cor pt qnorm 
#'@export
Corr <- function(exp, obs, memb_dim = 'member', sdate_dim = 'sdate', 
                 comp_dim = NULL, limits = NULL,
                 siglev = 0.95, method = 'pearson', 
                 conf = TRUE, pval = TRUE, ncores = 1) {

  # Check inputs 
  ## exp and obs (1)
  if (is.null(exp) | is.null(obs)) {
    stop("Parameter 'exp' and 'obs' cannot be NULL.")
  }
  if (!is.numeric(exp) | !is.numeric(obs)) {
    stop("Parameter 'exp' and 'obs' must be a numeric array.")
  }
  if (is.null(dim(exp)) | is.null(dim(obs))) {
    stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ",
                "containing sdate_dim and memb_dim."))
  }
  if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) |
     any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) {
    stop("Parameter 'exp' and 'obs' must have dimension names.")
  }
  if(!all(names(dim(exp)) %in% names(dim(obs))) | 
     !all(names(dim(obs)) %in% names(dim(exp)))) {
    stop("Parameter 'exp' and 'obs' must have same dimension name")
  }
  ## 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(obs))) {
    stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.")
  }
  ## sdate_dim
  if (!is.character(sdate_dim) | length(sdate_dim) > 1) {
    stop("Parameter 'sdate_dim' must be a character string.")
  }
  if (!sdate_dim %in% names(dim(exp)) | !sdate_dim %in% names(dim(obs))) {
    stop("Parameter 'sdate_dim' is not found in 'exp' or 'obs' dimension.")
  }
  ##comp_dim
  if (!is.null(comp_dim)) {
    if (!is.character(comp_dim) | length(comp_dim) > 1) {
      stop("Parameter 'comp_dim' must be a character string.")
    }
    if (!comp_dim %in% names(dim(exp)) | !comp_dim %in% names(dim(obs))) {
      stop("Parameter 'comp_dim' is not found in 'exp' or 'obs' dimension.")
    }
  }
  ##limits
  if (!is.null(limits)) {
    if (is.null(comp_dim)) {
      stop("Paramter 'com_dim' cannot be NULL if 'limits' is assigned.")
    }
    if (!is.numeric(limits) | any(limits %% 1 != 0) | any(limits < 0) | 
        length(limits) != 2 | any(limits > dim(exp)[comp_dim])) {
      stop(paste0("Parameter 'limits' must be a vector of two positive ",
                  "integers smaller than the length of paramter 'comp_dim'."))
    }
  }
  ## siglev
  if (!is.numeric(siglev) | siglev < 0 | siglev > 1 | length(siglev) > 1) {
    stop("Parameter 'siglev' must be a numeric number between 0 and 1.")
  }
  ## method
  if (!(method %in% c("kendall", "spearman", "pearson"))) {
    stop("Parameter 'method' must be one of 'kendall', 'spearman' or 'pearson'.")}
  ## conf
  if (!is.logical(conf) | length(conf) > 1) {
    stop("Parameter 'conf' must be one logical value.")
  }
  ## pval
  if (!is.logical(pval) | length(pval) > 1) {
    stop("Parameter 'pval' must be one logical value.")
  }
  ## ncores
  if (!is.null(ncores)) {
    if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 |
      length(ncores) > 1) {
      stop("Parameter 'ncores' must be a positive integer.")
    }
  } 
  ## exp and obs (2)
  name_exp <- sort(names(dim(exp)))
  name_obs <- sort(names(dim(obs)))
  name_exp <- name_exp[-which(name_exp == memb_dim)]
  name_obs <- name_obs[-which(name_obs == memb_dim)]
  if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) {
    stop(paste0("Parameter 'exp' and 'obs' must have same length of ",
                "all dimension expect 'memb_dim'."))
  }
  if (dim(exp)[sdate_dim] < 3) {
    stop("The length of sdate_dim must be at least 3 to compute correlation.")
  }

  ###############################
  # Calculate Corr

  # Remove data along comp_dim dim if there is at least one NA between limits
  if (!is.null(comp_dim)) {
    if (is.null(limits)) {
      limits <- c(1, dim(obs)[comp_dim])
    }
    pos <- which(names(dim(obs)) == comp_dim)
    outrows <- is.na(Mean1Dim(obs, pos, narm = FALSE, limits))
    outrows <- InsertDim(outrows, pos, dim(obs)[comp_dim])
    obs[which(outrows)] <- NA
  }

 res <- Apply(list(exp, obs), 
              target_dims = list(c(sdate_dim, memb_dim), 
                                 c(sdate_dim, memb_dim)),
              fun = .Corr, 
              siglev = siglev, method = method, 
              conf = conf, pval = pval, ncores = ncores)
 return(res)
}

.Corr <- function(exp, obs, siglev = siglev, method = method, 
                  conf = conf, pval = pval) {

  # exp: [sdate, member_exp]
  # obs: [sdate, member_obs]
  n_exp <- as.numeric(dim(exp)[2])
  n_obs <- as.numeric(dim(obs)[2])
  
  CORR <- array(dim = c(n_exp = n_exp, n_obs = n_obs))
  eno_expand <- array(dim = c(n_exp = n_exp, n_obs = n_obs))
  p_val <- array(dim = c(n_exp = n_exp, n_obs = n_obs))

  # ens_mean
  for (i in 1:n_obs) {

    CORR[, i] <- sapply(1:n_exp, 
                          function(x) {
    if (any(!is.na(exp[, x])) && sum(!is.na(obs[, i])) > 2) {
cor(exp[, x], obs[, i],
                                       use = "pairwise.complete.obs", 
                                       method = method)
} else {
    CORR[, i] <- NA
}
})
  }

#  if (pval) {
#    for (i in 1:n_obs) {
#      p_val[, i] <- try(sapply(1:n_exp,
#                           function(x) {(cor.test(exp[, x], obs[, i],
#                                         use = "pairwise.complete.obs",
#                                         method = method)$p.value)/2}), silent = TRUE)
#      if (class(p_val[, i]) == 'character') {
#        p_val[, i] <- NA
#      }
#    }
#  }

  if (pval | conf) {
    if (method == "kendall" | method == "spearman") {
      tmp <- apply(obs, 2, rank)
      eno <- Eno(tmp, 1)
#      eno <- Eno(tmp, sdate_dim)  #replace the upper line with this when using new Eno()
    } else if (method == "pearson") {
      eno <- Eno(obs, 1)                          
#      eno <- Eno(obs, sdate_dim)  #replace the upper line with this when using new Eno()
    }
  
    for (i in 1:n_exp) {
      eno_expand[i, ] <- eno
    }
  }
#############old#################
#This doesn't return error but it's diff from cor.test() when method is spearman and kendall
  if (pval) {
    t <-sqrt(CORR * CORR * (eno_expand - 2) / (1 - (CORR ^ 2)))
    p_val <- pt(t, eno_expand - 2, lower.tail = FALSE)
  } 
###################################
  if (conf) {
    conf_low <- (1 - siglev) / 2
    conf_high <- 1 - conf_low
    conflow <- tanh(atanh(CORR) + qnorm(conf_low) / sqrt(eno_expand - 3))
    confhigh <- tanh(atanh(CORR) + qnorm(conf_high) / sqrt(eno_expand - 3))
  }

  if (pval & conf) {
    res <- list(corr = CORR, p_val = p_val, 
                conf_low = conflow, conf_high = confhigh)
  } else if (pval & !conf) {
    res <- list(corr = CORR, p_val = p_val)
  } else if (!pval & conf) {
    res <- list(corr = CORR,
                conf_low = conflow, conf_high = confhigh)
  } else {
    res <- list(corr = CORR)
  }

  return(res) 

}
