#'Diebold-Mariano test
#'
#'Forecast comparison of the skill obtained with 2 forecasts (with respect to a 
#'common observational reference) based on Diebold and Mariano (2012; 
#'https://doi.org/10.2307/1392185)
#'
#'@param skill_A A numerical array of the time series of the scores obtained
#'  with the forecaster A.
#'@param skill_B A numerical array of the time series of the scores obtained
#'  with the forecaster B. The dimensions should be identical as parameter
#'  'skill_A'.
#'@param time_dim A character string indicating the name of the dimension along
#'  which the tests are computed. The default value is 'sdate'.
#'@param test.type A character string indicating the type of significance test.
#'  It can be "two.sided" (to assess whether forecaster A and forecaster B are 
#'  significantly different in terms of skill) or "one.sided" (to assess whether
#'  forecaster A shows significantly better skill than forecaster B using a 
#'  one-sided test for positively oriented scores). The default value is 
#'  "two.sided". 
#'@param alpha A numeric of the significance level to be used in the statistical
#'  significance test (output "sign"). The default value is 0.05.
#'@param N.eff Effective sample size to be used in the statistical significance
#'  test. It can be FALSE (and the length of the time series will be used), a
#'  numeric value (which is used for all cases), or an array with the same 
#'  dimensions as "skill_A" except "time_dim" (for a particular N.eff to be used
#'  for each case). 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 logical multidimensional array with the same dimensions as the score
#' inputs except for the dimension specified in parameter 'time_dim'.
#'
#'@references 
#'Diebold and Mariano (2012): https://doi.org/10.2307/1392185
#'
#'@examples
#' set.seed(1)
#' fcst_A <- array(rnorm(40, 2), dim = c(sdate = 10, lat = 2, lon = 2))
#' fcst_B <- array(rnorm(40), dim = c(sdate = 10, lat = 2, lon = 2))
#' reference <- array(data = 1:40, dim = c(sdate = 10, lat = 2, lon = 2))
#' scores_A <- abs(fcst_A - reference)
#' scores_B <- abs(fcst_B - reference)
#' res1 <- DieboldMarianoTest(skill_A = scores_A, skill_B = scores_B)
#' res2 <- DieboldMarianoTest(skill_A = scores_A, skill_B = scores_B, 
#'                            test.type = 'one.sided')
#'
#'@importFrom multiApply Apply
#'@importFrom SpecsVerification ScoreDiff
#'@importFrom stats pnorm qnorm var
#'@export
DieboldMarianoTest <- function(skill_A, skill_B, time_dim = 'sdate',
                               test.type = "two.sided", alpha = 0.05, 
                               N.eff = FALSE, ncores = NULL) {
  
  ## Check inputs
  if (is.null(skill_A) || is.null(skill_B)) {
    stop("Parameters 'skill_A' and 'skill_B' cannot be NULL.")
  }
  if(!is.numeric(skill_A) || !is.numeric(skill_B)) {
    stop("Parameters 'skill_A' and 'skill_B' must be a numerical array.")
  }
  if (!identical(dim(skill_A), dim(skill_B))) {
    stop("Parameters 'skill_A' and 'skill_B' must have the same dimensions.")
  }
  if(!is.character(time_dim)) {
    stop("Parameter 'time_dim' must be a character string.")
  }
  if (!time_dim %in% names(dim(skill_A)) || !time_dim %in% names(dim(skill_B))) {
    stop("Parameter 'time_dim' is not found in 'skill_A' or 'skill_B' dimensions.")
  }
  if (!(test.type %in% c("two.sided", "one.sided"))) {
    stop("Parameter 'test.type' must be 'two.sided' or 'one.sided'.")
  }
  if (!is.numeric(alpha) || length(alpha) != 1 || alpha >= 1 || alpha <= 0) {
    stop("Parameter 'alpha' must be numeric, of length 1, higher than 0, and lower than 1.")
  }
  if (is.array(N.eff)) {
    if (!is.numeric(N.eff)) {
      stop("Parameter 'N.eff' must be numeric.")
    }
    if (time_dim %in% names(dim(N.eff))) {
      stop("If parameter 'N.eff' is provided as an array, it must not include the 'time_dim' dimension.")
    }
    if (!all(names(dim(N.eff)) %in% names(dim(skill_A))) ||
        any(dim(skill_A)[match(names(dim(N.eff)), names(dim(skill_A)))] != dim(N.eff))) {
      stop("If parameter 'N.eff' is provided as a numerical array, it must have ",
           "the same dimensions as 'skill_A' and 'skill_B' except 'time_dim'.")
    }
  } else if (length(N.eff) != 1 ||
             (!isFALSE(N.eff) && !is.numeric(N.eff) && !is.na(N.eff))) {
    stop("Parameter 'N.eff' must be FALSE, NA, a numeric value, or a numerical array ",
         "with the same dimensions as 'skill_A' and 'skill_B' except 'time_dim'.")
  }
  if (!is.null(ncores)){
    if (length(ncores) > 1 || !is.numeric(ncores) || ncores %% 1 != 0 || ncores <= 0) {
      stop("Parameter 'ncores' must be a positive integer.")
    }
  }
  
  ## Compute the Diebold-Mariano Test
  if (is.array(N.eff)) {
    res <- Apply(data = list(skill_A = skill_A,
                             skill_B = skill_B,
                             N.eff = N.eff),
                 target_dims = list(skill_A = time_dim,
                                    skill_B = time_dim,
                                    N.eff = NULL),
                 fun = .DieboldMarianoTest,  test.type = test.type,
                 alpha = alpha, ncores = ncores)$output1
  } else {
    res <- Apply(data = list(skill_A = skill_A,
                             skill_B = skill_B),
                 target_dims = list(skill_A = time_dim,
                                    skill_B = time_dim),
                 fun = .DieboldMarianoTest, test.type = test.type,
                 alpha = alpha, N.eff = N.eff, ncores = ncores)$output1
  }
  
  return(res)
}

.DieboldMarianoTest <- function(skill_A, skill_B, N.eff, alpha,
                                test.type = "two.sided") {
  if (isFALSE(N.eff)) N.eff <- NA
  if (anyNA(skill_A) || anyNA(skill_B)){
    return(NA)
  } else {
    if (test.type == "one.sided") {
      ## one-sided
      score_diff <- ScoreDiff(scores = skill_A, scores.ref = skill_B,
					       N.eff = N.eff, conf.level = 1 - alpha,
					       handle.na = 'na.fail')
      return(score_diff[3] < alpha)
    } else {
    ## two-sided
      score_diff <- .SpecsVerification_ScoreDiff_twosided(scores = skill_A,
				scores.ref = skill_B, N.eff = N.eff,
				conf.level = 1 - alpha, handle.na = 'na.fail')
    return(score_diff[3] < alpha/2)
    }
  }
}

.SpecsVerification_ScoreDiff_twosided <- function (scores, scores.ref, N.eff = NA,
						  conf.level = 0.95, handle.na = "na.fail") {
  N.eff <- N.eff[1L]
  stopifnot(N.eff > 0 || is.na(N.eff))
  stopifnot(length(scores) == length(scores.ref))
  if (handle.na == "na.fail") {
    if (any(is.na(c(scores, scores.ref)))) {
      stop("missing values")
    }
  }
  else if (handle.na == "use.pairwise.complete") {
    nna <- !is.na(scores) & !is.na(scores.ref)
    if (all(nna == FALSE)) {
      stop("there are no complete pairs of scores")
    }
    scores <- scores[nna]
    scores.ref <- scores.ref[nna]
  }
  else {
    stop("unknown 'handle.na' argument")
  }
  if (is.na(N.eff)) {
    N.eff <- length(scores)
  }
  d <- scores.ref - scores
  d.bar <- abs(mean(d)) ## abs() to get the significance also for the negative RPSS
  var.d <- var(d)
  d.bar.sd <- sqrt(var.d/N.eff)
  if (d.bar.sd > 0) {
    p.value <- pnorm(d.bar/d.bar.sd, lower.tail = FALSE)
  }
  else {
    p.value <- NA
  }
  if (conf.level <= 0 || conf.level >= 1) {
    conf.level <- NA
  }
  if (is.na(conf.level)) {
    ci <- c(NA, NA)
  }
  else {
    alpha <- (1 - conf.level)/2
    ci <- qnorm(p = c(alpha, 1 - alpha), mean = d.bar, sd = d.bar.sd)
  }
  ret <- c(score.diff = d.bar, score.diff.sd = d.bar.sd, p.value = p.value, 
           L = ci[1], U = ci[2])
  return(ret)
}
