#'Compute the Ranked Probability Score
#'
#'The Ranked Probability Score (RPS; Wilks, 2011) 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 have), the RPS 
#'corresponds to the Brier Score (BS; Wilks, 2011), therefore, ranges between 0 
#'and 1.
#'
#'@param exp A named numerical array of the forecast with at least time 
#'  dimension.  
#'@param obs A named numerical array of the observation with at least time 
#'  dimension. The dimensions must be the same as 'exp' except 'memb_dim'.
#'@param time_dim A character string indicating the name of the time dimension.
#'  The default value is 'sdate'.
#'@param memb_dim A character string indicating the name of the member dimension
#'  to compute the probabilities of the forecast. The default value is 'member'.
#'@param prob_thresholds A numeric vector of the relative thresholds (from 0 to
#'  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 of the indices to be taken along 'time_dim' 
#'  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 ncores An integer indicating the number of cores to use for parallel 
#'  computation. The default value is NULL.
#'
#'@return 
#'A numerical array of RPS with the same dimensions as "exp" except the 
#''time_dim' and 'memb_dim' dimensions.
#'
#'@references 
#'Wilks, 2011; https://doi.org/10.1016/B978-0-12-385022-5.00008-7
#'
#'@examples
#'exp <- array(rnorm(1000), dim = c(lat = 3, lon = 2, member = 10, sdate = 50))
#'obs <- array(rnorm(1000), dim = c(lat = 3, lon = 2, sdate = 50))
#'res <- RPS(exp = exp, obs = obs)
#'
#'@import multiApply
#'@importFrom easyVerification convert2prob
#'@export
RPS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', 
                prob_thresholds = c(1/3, 2/3), indices_for_clim = NULL, Fair = FALSE, 
                ncores = NULL, weights = NULL) {
  
  # Check inputs
  ## exp and obs (1)
  if (!is.array(exp) | !is.numeric(exp))
    stop('Parameter "exp" must be a numeric array.')
  if (!is.array(obs) | !is.numeric(obs))
    stop('Parameter "obs" must be a numeric array.')
  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.")
  }
  ## time_dim
  if (!is.character(time_dim) | length(time_dim) != 1)
    stop('Parameter "time_dim" must be a character string.')
  if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) {
    stop("Parameter 'time_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))) {
    stop("Parameter 'memb_dim' is not found in 'exp' dimension.")
  }
  ## 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)]
  if (memb_dim %in% name_obs) {
    name_obs <- name_obs[-which(name_obs == memb_dim)]
  }
  if (!identical(length(name_exp), length(name_obs)) |
      !identical(dim(exp)[name_exp], dim(obs)[name_obs])) {
    stop(paste0("Parameter 'exp' and 'obs' must have same length of ",
                "all dimensions expect 'memb_dim'."))
  }
  ## prob_thresholds
  if (!is.numeric(prob_thresholds) | !is.vector(prob_thresholds) |
      any(prob_thresholds <= 0) | any(prob_thresholds >= 1)) {
    stop("Parameter 'prob_thresholds' must be a numeric vector between 0 and 1.")
  }
  ## indices_for_clim
  if (is.null(indices_for_clim)) {
    indices_for_clim <- 1:dim(obs)[time_dim]
  } else {
    if (!is.numeric(indices_for_clim) | !is.vector(indices_for_clim)) {
      stop("Parameter 'indices_for_clim' must be NULL or a numeric vector.")
    } else if (length(indices_for_clim) > dim(obs)[time_dim] |
               max(indices_for_clim) > dim(obs)[time_dim] |
               any(indices_for_clim) < 1) {
      stop("Parameter 'indices_for_clim' should be the indices of 'time_dim'.")
    }
  }
  ## Fair
  if (!is.logical(Fair)  | length(Fair) > 1) {
    stop("Parameter 'Fair' must be either TRUE or FALSE.")
  }
  ## ncores
  if (!is.null(ncores)) {
    if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 |
      length(ncores) > 1) {
      stop("Parameter 'ncores' must be either NULL or a positive integer.")
    }
  }

  ###############################
 
  # Compute RPS
  if (!memb_dim %in% names(dim(obs))) {
    target_dims_obs <- time_dim
  } else {
    target_dims_obs <- c(time_dim, memb_dim)
  }

  rps <- Apply(data = list(exp = exp, obs = obs), 
               target_dims = list(exp = c(time_dim, memb_dim), 
                                  obs = target_dims_obs),
               output_dims = time_dim,
               fun = .RPS,
               prob_thresholds = prob_thresholds, 
               indices_for_clim = indices_for_clim, Fair = Fair,
               ncores = ncores, weights = weights)$output1

  # Return only the mean RPS
  rps <- MeanDims(rps, time_dim, na.rm = FALSE)
 
  return(rps)
}


.RPS <- function(exp, obs, prob_thresholds = c(1/3, 2/3), 
                 indices_for_clim = NULL, Fair = FALSE, weights = NULL) {
  # exp: [sdate, memb]
  # obs: [sdate, (memb)]

  exp_probs <- .get_probs(data = exp, indices_for_quantiles = indices_for_clim, 
                          prob_thresholds = prob_thresholds, weights = weights)
  # exp_probs: [bin, sdate] 
  obs_probs <- .get_probs(data = obs, indices_for_quantiles = indices_for_clim, 
                          prob_thresholds = prob_thresholds)
  # obs_probs: [bin, sdate]

  probs_exp_cumsum <- apply(exp_probs, 2, cumsum)
  probs_obs_cumsum <- apply(obs_probs, 2, cumsum)
  rps <- apply((probs_exp_cumsum - probs_obs_cumsum)^2, 2, sum)
  # rps: [sdate]

  if (Fair) { # FairRPS
    ## adjustment <- rowSums(-1 * (1/R - 1/R.new) * ens.cum * (R - ens.cum)/R/(R - 1)) [formula taken from SpecsVerification::EnsRps]
    R <- dim(exp)[2]  #memb
    R_new <- Inf
    adjustment <- (-1) / (R - 1) * probs_exp_cumsum * (1 - probs_exp_cumsum)
    adjustment <- apply(adjustment, 2, sum)
    rps <- rps + adjustment
  }

  return(rps)
}

.get_probs <- function(data, indices_for_quantiles, prob_thresholds, weigths = NULL) {
  # if exp: [sdate, memb]
  # if obs: [sdate, (memb)]

  # Add dim [memb = 1] to obs if it doesn't have memb_dim
  if (length(dim(data)) == 1) dim(data) <- c(dim(data), 1)

  # Absolute thresholds
  if (is.null(weights)){
    quantiles <- quantile(x = as.vector(data[indices_for_quantiles, ]), probs = prob_thresholds, type = 8, na.rm = TRUE)
  } else {
    # linear approach to compute weighted distribution thresholds.
    sorted_data, sorted_weights <- .sorted_distributions(data[indices_for_quantiles, ], weights[indices_for_quantiles, ])
    # approach 1 (interpolate from discrete cumulative weights distribution. NOT type 8)
    cumulative_weights <- cumsum(sorted_weights) - 0.5 * sorted_weights
    cumulative_weights <- cumulative_weights - cumulative_weights[1] # fix the 0
    cumulative_weights <- cumulative_weights / cumulative_weights[length(cumulative_weights)] # fix the 1
    quantiles <- interp1(cumulative_weights, sorted_data, c(1/3,2/3), "cubic")
    # approach 2 (interpolate from the polynomial fit of the cumulative weights distribution)
    fit_model <- lm(cumsum(sorted_weights) ~ poly(sorted_data,10)) # order 10, but we should think what order we want to use
    predicted.intervals <- predict(fit_model,data.frame(x=sorted_data))
    quantiles <- interp1(predicted.intervals, sorted_data, c(1/3,2/3), "cubic")
  }
  # Probabilities
  probs <- array(dim = c(bin = length(quantiles) + 1, dim(data)[1])) # [bin, sdate]
  for (i_time in 1:dim(data)[1]) {
    if (is.null(weights)){
      if (anyNA(data[i_time, ])) {
        probs[, i_time] <- rep(NA, dim = length(quantiles) + 1)
      } else {
        probs[, i_time] <- colMeans(easyVerification::convert2prob(data[i_time, ], threshold = quantiles))
      }
    } else {
      sorted_data, sorted_weights <- .sorted_distributions(data[i_time, ], weights[i_time, ])

      fit_model <- lm(cumsum(sorted_weights) ~ poly(sorted_data,10))
      predicted.intervals <- predict(fit_model,data.frame(x=sorted_data))
      integrated_probs <- interp1(sorted_data, predicted.intervals, quantiles, "cubic")
      probs[, i_time] <- c(integrated_probs[1], integrated_probs[2]-integrated_probs[1], 1-integrated_probs[2])
    }

  }

  return(probs)
}

.sorted_distributions <- function(data_vector, weights_vector){
      weights_vector <- as.vector(weights_vector)
      data_vector <- as.vector(data_vector)
      weights_vector <- weights_vector / sum(weights_vector) # normalize to 1
      sorter <- order(data_vector)
      sorted_data <- data_vector[sorter]
      sorted_weights <- weights_vector[sorter]
      return(sorted_data, sorted_weights)
}