#'Compute the Ranked Probability Score
#'
#'The Ranked Probability Score (RPS; Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7) is defined 
#'as the sum of the squared differences between the cumulative forecast probabilities (computed from the ensemble 
#'members) and the observations (defined as 0% if the category did not happen and 100% if it happened). It can be
#'used to evaluate the skill of multi-categorical probabilistic forecasts. The RPS ranges between 0 (perfect 
#'forecast) and n-1 (worst possible forecast), where n is the number of categories. In the case of a forecast 
#'divided into two categories (the lowest number of categories that a probabilistic forecast can provide), the 
#'RPS corresponds to the Brier Score (BS; Wilks, 2011) and, therefore, ranges between 0 and 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 indices_for_clim A vector with the indices to be taken along "time_dim" dimension for computing the thresholds
#'  between the probabilistic categories.
#'@param n_categories An integer with the number of probabilistic categories. The default value is 3 (tercile categories).
#'@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 
#'  A numerical array with the RPS 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))
#' obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, year = 50))
#' RPS(exp, obs, indices_for_clim = 1:50)
#'
#'@import multiApply
#'@importFrom easyVerification convert2prob
#'@export
RPS <- function(exp, obs, indices_for_clim, n_categories = 3, 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.numeric(n_categories) | n_categories < 2){stop('"n_categories" must be an integer greater than 1.')}
  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.')}
  }
  
  ## RPS
  rps <- multiApply::Apply(data = list(exp = exp, obs = obs), 
                           target_dims = list(exp = c(time_dim, member_dim), obs = time_dim),
                           n_categories = n_categories, indices_for_clim = indices_for_clim,
                           Fair = Fair, time_dim = time_dim, member_dim = member_dim,
                           fun = .RPS, ncores = ncores)$output1
  
  ## Returning only the mean RPS
  rps <- multiApply::Apply(data = rps, target_dims = time_dim, fun = mean, na.rm = FALSE, ncores = ncores)$output1
  
  return(rps)
}

.RPS <- function(exp, obs, n_categories, indices_for_clim, Fair = FALSE, time_dim = 'year', member_dim = 'member'){
  
  exp_probs <- .get_probs(data = exp, type = 'exp', indices_for_quartiles = indices_for_clim, 
                          time_dim = time_dim, member_dim = member_dim, n_categories = n_categories)$probs
  
  obs_probs <- .get_probs(data = obs, type = 'obs', indices_for_quartiles = indices_for_clim, 
                          time_dim = time_dim, member_dim = NULL, n_categories = n_categories)$probs
  
  rps <- multiApply::Apply(data = list(probs_exp = exp_probs, probs_obs = obs_probs), target_dims = 'bin',
                           fun = .RPS_from_probs, n_categories = n_categories, Fair = Fair, 
                           n_members = as.numeric(dim(exp)[member_dim]), ncores = NULL)$output1
  return(rps)
}

.get_probs <- function(data, type, indices_for_quartiles, time_dim, member_dim, n_categories){
  
  if (type == 'exp'){
    target_dims_quantiles = c(time_dim, member_dim)
    target_dims_probs = list(member_dim, 'bin')
  } else if (type == 'obs'){
    target_dims_quantiles = time_dim
    target_dims_probs = list(NULL,'bin')
  } else {stop("Parameter 'type' must be 'exp' or 'obs'")}
  
  quantiles <- multiApply::Apply(data = ClimProjDiags::Subset(x = data, along = time_dim, indices = indices_for_quartiles), 
                                 target_dims = target_dims_quantiles, 
                                 fun = .quantile_aux, n_categories = n_categories, 
                                 output_dims = 'bin', ncores = NULL)$output1
  
  probs <- multiApply::Apply(data = list(data = data, quantiles = quantiles),
                             target_dims = target_dims_probs,
                             fun = .c2p, 
                             output_dims = 'bin', ncores = NULL)$output1
  
  return(list('probs' = probs, 'quantiles' = quantiles))
}

.quantile_aux = function(data, n_categories){
  data = as.vector(data)
  q = quantile(x = data, probs = 1:(n_categories - 1) / n_categories, type = 8, na.rm = TRUE)
  return(q)
}

.c2p <- function(data, quantiles) {
  if (anyNA(data)){
    output <- array(data = NA, dim = length(quantiles) + 1)
  } else {
    output <- colMeans(easyVerification::convert2prob(as.vector(data), threshold = as.vector(quantiles)))
  }
  return(output)
}


.RPS_from_probs <- function(probs_exp, probs_obs, n_categories, Fair, n_members){
  
  rps <- NULL
  for (i in 1:n_categories){
    rps[i] <- (cumsum(probs_exp)[i]-cumsum(probs_obs)[i])^2 ## (Wilks 2011, pp.348-350)
  }
  rps <- sum(rps)
  
  if (Fair == TRUE){ ## FairRPS
    ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps]
    R <- n_members
    R_new <- Inf 
    probs_cum <- cumsum(probs_exp)
    adjustment <- -1 / (R-1) * probs_cum * (1 - probs_cum)
    adjustment <- sum(adjustment)
    rps <- rps + adjustment
  }
  
  return(rps)
}
