#'Computes Root Mean Square Skill Score
#'
#'Computes the root mean square error skill score between an array of 
#'forecasts 'exp' and an array of observations 'obs'. The two array should 
#'have the same dimensions except along memb_dim, where the length can be 
#'different, with the number of experiments/models for exp (nexp) and 
#'the number of obserational datasets for obs (nobs).\cr
#'RMSSS computes the Root Mean Square Skill Score of each jexp in 1:nexp 
#'against each jobs in 1:nobs which gives nexp x nobs RMSSS for each other 
#'grid point of the matrix (each latitude/longitude/level/leadtime).\cr
#'The RMSSS are computed along the sdate_dim dimension which should correspond
#'to the startdate dimension.\cr
#'.RMSSS provides the same functionality but taking a matrix of ensemble 
#'members as input (exp).
#'
#'@param exp A named numeric array of experimental data which contains at least two
#'  dimensions for memb_dim and sdate_dim.
#'@param obs A named numeric array of observational data which contains at least two
#'  dimensions for memb_dim and sdate_dim. The dimensions should be the same 
#'  as paramter 'exp' except the length of 'memb_dim' dimension. The order of  
#'  dimension can be different.
#'@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 
#'  RMSSS are computed. The default value is 'sdate'.
#'@param pval A logical value indicating whether to compute or not the p-value 
#'  of the test Ho: RMSSS = 0. If pval = TRUE, the insignificant RMSSS will 
#'  return NA. Set TRUE as default.
#'
#'@return An array with dimensions:\cr
#'  c(n_exp, n_obs, stats, all other dimensions of exp except sdate_dim).\cr
#'  If \code{pval = FALSE}, the length of the 3rd dimension 'stats' is 1, 
#'  the RMSSS; if \code{pval = TRUE}, the length is 2, the RMSSS and the 
#'  corresponding p-value.
#'
#'@keywords datagen
#'@author History:\cr
#'0.1  -  2012-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  -  2017-02  (A. Hunter, \email{alasdair.hunter@bsc.es})  -  Adapted to veriApply()
#'3.0  -  2019-12  (A. Ho, \email{an.ho@bsc.es})  -  Adapted to multiApply
#'@examples
#' set.seed(1)
#' exp <- array(rnorm(15), dim = c(dat = 1, time = 3, member = 5))
#' set.seed(2)
#' obs <- array(rnorm(6), dim = c(time = 3, member = 2, dat = 1))
#' res <- RMSSS(exp, obs, sdate_dim = 'time')
#'
#'@rdname RMSSS
#'@import multiApply
#'@export
RMSSS <- function(exp, obs, sdate_dim = 'sdate', memb_dim = 'member', pval = TRUE) {
  
  # 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")
  }
  
  ## 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.")
  }
  
  ## 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.")
  }
  
  ## pval
  if (!is.logical(pval) | length(pval) > 1) {
    stop("Parameter 'pval' must be one logical value.")
  }
  
  ## 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("Parameter 'exp' and 'obs' must have same length of all dimension expect 'memb_dim'.")
  }
  if (dim(exp)[sdate_dim] < 2) {
    stop("The length of sdate_dim must be at least 2 to compute RMSSS.")
  }
 
  ###############################
  # Calculate RMSSS
  
  RMSSS <- Apply(list(exp, obs), 
                 target_dims = list(c(sdate_dim, memb_dim), 
                                    c(sdate_dim, memb_dim)),
                 output_dims = c('nexp', 'nobs', 'stats'),
                 fun = .RMSSS, 
                 pval = pval)$output1
  
  return(RMSSS)
}

#'@rdname RMSSS
#'@importFrom stats pf
#'@export
.RMSSS <- function(exp, obs, pval = TRUE) {
  # exp: [sdate, member_exp]
  # obs: [sdate, member_obs]
  n_exp <- as.numeric(dim(exp)[2])
  n_obs <- as.numeric(dim(obs)[2])
  n_sdate <- as.numeric(dim(exp)[1])
  
  p_val <- array(dim = c(nexp = n_exp, nobs = n_obs))
  rms1 <- array(dim = c(nexp = n_exp, nobs = n_obs))
  eno1 <- array(dim = c(sdate = n_sdate))
  dif1 <- array(dim = c(sdate = n_sdate, n_exp = n_exp, n_obs = n_obs))

  # dif1
  for (i in 1:n_obs) {
    dif1[, , i] <- sapply(1:n_exp, function(x) {exp[, x] - obs[, i]})
  }
  
  # rms1 and eno1
  rms1 <- apply(dif1^2, c(2, 3), mean)^0.5  #array(dim = c(n_exp, n_obs))
  if (pval == TRUE) {
    eno1 <- Eno(dif1, 1) #count effective sample along sdate. dim = c(n_exp, n_obs)
    ##eno1 <- Eno(dif1, sdate_dim) #change to this line when Eno() is done
  }
  
  # rms2 and eno2
  rms2 <- array(colMeans(obs^2)^0.5, dim = c(n_obs = n_obs))
  if (pval == TRUE) {
    eno2 <- Eno(obs, 1)  #dim = n_obs
    ##eno2 <- Eno(obs, sdate_dim) #change to this line when Eno() is done
  }
  
  rms2[which(abs(rms2) <= (max(abs(rms2), na.rm = TRUE) / 1000))] <- max(abs(
    rms2), na.rm = TRUE) / 1000
  
  # use rms1 and rms2 to calculate rmsss
  rmsss <- as.array(sapply(1:n_obs, function(i) {1 - rms1[, i]/rms2[i]}))
  
  # pval
  if (pval == TRUE) {
    F.stat <- as.array(sapply(1:n_obs, 
                              function(i) {
                                (eno2[i] * (rms2[i])^2 / (eno2[i] - 1)) / (eno1[, i] * (rms1[, i])^2 / (eno1[, i] - 1))
                              }))
    
    tmp <- as.array(sapply(1:n_obs, function(i) {
      is.na(eno1[, i]) == FALSE & is.na(eno2[i]) == FALSE & eno1[, i] > 2 & eno2[i] > 2
    }))
    p_val <- as.array(sapply(1:n_obs, 
                             function(i) {
                               1 - pf(F.stat[, i], eno1[, i] - 1, eno2[i] - 1)
                             }))
    
    p_val[which(!tmp)] <- NA
    
    # change not significant rmsss to NA
    rmsss[which(!tmp)] <- NA
    
  }
  
  if (pval == TRUE) {
    res <- array(dim = c(nexp = n_exp, nobs = n_obs, 2))
    res[,,1] <- rmsss
    res[,,2] <- p_val
  } else {
    res <- array(dim = c(nexp = n_exp, nobs = n_obs, 1))
    res[,,1] <- rmsss
  }
  res
}
