#'Compute the Ranked Probability Skill Score
#'
#'The Ranked Probability Skill Score (RPSS; Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7)
#'is the skill score based on the Ranked Probability Score (RPS; Wilks, 2011). It can be used to assess whether
#'a forecast presents an improvement or worsening with respect to a reference forecast. The RPSS ranges between
#'minus infinite and 1. If the RPSS is positive, it indicates that the forecast has higher skill than the 
#'reference forecast, while a negative value means that it has a lower skill. Examples of reference forecasts
#'are the climatological forecast (same probabilities for all categories for all time steps), persistence, a previous model version,
#'and another model. It is computed as RPSS = 1 - RPS_exp / RPS_ref. The statistical significance is obtained based
#'on a Random Walk test at the 95% confidence level (DelSole and Tippett, 2016; https://doi.org/10.1175/MWR-D-15-0218.1)
#'
#'@param exp A numerical array with the forecast with, at least, time dimension. 
#'@param obs A numerical array with the observations with, at least, time dimension. 
#'  The length of the time dimension must be the same as for "exp".
#'@param ref NULL or a numerical array with the reference forecast with, at least, time dimension. 
#'  The length of the time dimension must be the same as for "exp". If it is NULL, the climatological forecast is
#'  used as reference forecast. The default value is NULL.
#'@param prob_thresholds A numeric vector with the relative thresholds (between 0 and 1) between the categories. 
#'  The default value is c(1/3,2/3), which corresponds to tercile equiprobable categories.
#'@param indices_for_clim A vector with the indices to be taken along "time_dim" dimension for computing the thresholds
#'  between the probabilistic categories. If NULL, the whole period is used. The default value is NULL.
#'@param Fair A logical indicating whether to compute the FairRPSS (the potential RPSS that the forecast would have with 
#'an infinite ensemble size). The default value is FALSE.
#'@param time_dim A character string indicating the name of the time dimension.
#'  The default value is 'year'.
#'@param member_dim A character string indicating the name of the member dimension to compute the 
#'  ensemble means of the forecast and reference forecast. If it is NULL, the ensemble means should 
#'  be provided directly to the function. The default value is 'member'.
#'@param ncores An integer indicating the number of cores to use for parallel 
#'  computation. The default value is NULL.
#'
#'@return
#'\item{$rpss}{
#'  A numerical array with the RPSS with the same dimensions as "exp" except the "time_dim" 
#'  and "member_dim" dimensions.
#'}
#'\item{$sign}{
#'  A logical array with the statistical significance of the RPSS with the same dimensions 
#'  as "exp" except the "time_dim" and "member_dim" dimensions.
#'}

#'@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))
#' RPSS(exp = exp, obs = obs) ## climatology as reference forecast
#' RPSS(exp = exp, obs = obs, ref = ref) ## ref as reference forecast
#'
#'@import multiApply
#'@export
RPSS <- function(exp, obs, ref = NULL, prob_thresholds = c(1/3,2/3), indices_for_clim = NULL, Fair = FALSE, time_dim = 'year', member_dim = 'member', ncores = NULL){
  
  ## Checkings
  if (!is.array(exp)){stop('"exp" must be an array.')}
  if (!is.array(obs)){stop('"obs" must be an array.')}
  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(ref)){
    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 (!is.numeric(prob_thresholds) | !is.vector(prob_thresholds) | any(prob_thresholds <= 0) | any(prob_thresholds >= 1)){
    stop('"prob_thresholds" must be a numeric vector with the relative thresholds (from 0 to 1) between the categories.')
  }
  if (is.null(indices_for_clim)){
    indices_for_clim <- 1:as.numeric(dim(obs)[time_dim])
  } else if (!is.numeric(indices_for_clim)){
    stop('"indices_for_clim" must be NULL or a numeric vector.')
  }
  if (!is.logical(Fair)){stop('"Fair" must be TRUE or FALSE.')}
  if (!is.character(time_dim)){stop('"time_dim" must be a string.')}
  if (!is.character(member_dim)){stop('"member_dim" must be a string.')}
  if (!is.null(ncores)){
    if (!is.numeric(ncores) | ncores < 1){stop('"ncores" must be either NULL or a positive integer.')}
  } 
  
  if (!is.null(ref)){ ## using "ref" as reference forecast
    output <- multiApply::Apply(data = list(exp = exp, obs = obs, ref = ref), 
                                target_dims = list(exp = c(time_dim, member_dim), obs = time_dim, ref = c(time_dim, member_dim)),
                                prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim,
                                Fair = Fair, time_dim = time_dim, member_dim = member_dim,
                                fun = .RPSS, ncores = ncores)
  } else { ## using climatology as reference forecast
    output <- multiApply::Apply(data = list(exp = exp, obs = obs), 
                                target_dims = list(exp = c(time_dim, member_dim), obs = time_dim),
                                ref = ref, prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim,
                                Fair = Fair, time_dim = time_dim, member_dim = member_dim,
                                fun = .RPSS, ncores = ncores)
  }
  
  return(output)
}

.RPSS <- function(exp, obs, ref, prob_thresholds, indices_for_clim, Fair, time_dim, member_dim){
  
  ## RPS of the forecast
  rps_exp <- .RPS(exp = exp, obs = obs, prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim, Fair = Fair, time_dim = time_dim, member_dim = member_dim)
  
  ## RPS of the reference forecast
  if (is.null(ref)){ ## using climatology as reference forecast
    obs_probs <- .get_probs(data = obs, type = 'obs', indices_for_quantiles = indices_for_clim, time_dim = time_dim, member_dim = NULL, prob_thresholds = prob_thresholds)
    clim_probs <- .get_probs_clim(prob_thresholds = prob_thresholds, dims = dim(obs_probs), time_dim = time_dim)
    rps_ref <- multiApply::Apply(data = list(probs_exp = clim_probs, probs_obs = obs_probs), target_dims = 'bin',
                                 fun = .RPS_from_probs, n_categories = length(prob_thresholds)+1, Fair = FALSE, ncores = NULL)$output1
  } else { ## using "ref" as reference forecast
    rps_ref <- .RPS(exp = ref, obs = obs, prob_thresholds = prob_thresholds, indices_for_clim = indices_for_clim, Fair = Fair, time_dim = time_dim, member_dim = member_dim)
  }
  
  ## RPSS
  rpss <- 1 - mean(rps_exp) / mean(rps_ref)
  
  ## Significance
  rps_exp <- array(data = rps_exp, dim = c(time = length(rps_exp)))
  rps_ref <- array(data = rps_ref, dim = c(time = length(rps_ref)))
  sign <- s2dv::RandomWalkTest(skill_A = rps_exp, skill_B = rps_ref, time_dim = 'time', ncores = NULL)$signif
  
  return(list(rpss = rpss, sign = sign))
}

.get_probs_clim <- function(prob_thresholds, dims, time_dim){
  
  probs <- array(data = NA, dim = c(bin = length(prob_thresholds)+1))
  probs[1] <- prob_thresholds[1]
  if (length(prob_thresholds) > 1){
    probs[2:(length(probs)-1)] <- diff(prob_thresholds)
  }
  probs[length(probs)] <- 1 - prob_thresholds[length(prob_thresholds)]
  stopifnot(identical(sum(probs),1))
  probs <- s2dv::InsertDim(data = probs, posdim = 2, lendim = dims[[time_dim]], name = time_dim)
  
  return(probs)
}
