############### FUNCTIONS FOR SCORECARDS ################


## Define metric names

.met_names <- function(metrics, var.units) { # metrics is a object with the names of the metrics to be displayed
  result <- list()
  if ('mean_bias' %in% metrics) {
    result <- append(result, list('mean_bias' = paste0('Mean bias (', var.units,')')))
  }
  if ('enscorr' %in% metrics) {
    result <- append(result, list('enscorr' = 'Correlation'))
  }
  if ('rps' %in% metrics ) {
    result <- append(result, list('rps' = 'RPS'))
  } 
  if ('frps' %in% metrics ) {
    result <- append(result, list('frps' = 'Fair RPS'))
  } 
  if ('rpss' %in% metrics) {
    result <- append(result, list('rpss' = 'RPSS'))
  } 
  if ('rpss_score_aggr' %in% metrics) {
    result <- append(result, list('rpss_score_aggr' = 'RPSS'))
  } 
  if ('frpss' %in% metrics) {
    result <- append(result, list('frpss' = 'Fair RPSS'))
  }
  if ('crps' %in% metrics) {
    result <- append(result, list('crps' = 'CRPS'))
  } 
  if ('crpss' %in% metrics) {
    result <- append(result, list('crpss' = 'CRPSS'))
  }
  if ('crpss_score_aggr' %in% metrics) {
    result <- append(result, list('crpss_score_aggr' = 'CRPSS'))
  } 
  if ('bss10' %in% metrics) {
    result <- append(result, list('bss10' = 'Brier skill score 10%'))
  }
  if ('bss90' %in% metrics) {
    result <- append(result, list('bss90' = 'Brier skill score 90%'))
  }
  if ('enssprerr' %in% metrics ) {
    result <- append(result, list('enssprerr' = 'Spread-to-error ratio'))
  } 
  if ('rmsss' %in% metrics ) {
    result <- append(result, list('rmsss' = 'RMSSS'))
  } 
  return(result)
}  



## Define metrics breaks for each input metric

.met_breaks <- function(metrics, breaks_bias) { # metrics is a object with the names of the metrics to be displayed
  result <- list()
  if ('mean_bias' %in% metrics) {
    result <- append(result, list('mean_bias' = breaks_bias))
  }
  if ('enscorr' %in% metrics) {
    result <- append(result, list('enscorr' = c(-1, -0.8, -0.6, -0.4, -0.2, 0, 0.2, 0.4, 0.6, 0.8, 1)))
  }
  if ('rps' %in% metrics ) {
    result <- append(result, list('rps' = c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.8, 1)))
  } 
  if ('frps' %in% metrics ) {
    result <- append(result, list('frps' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  } 
  if ('rpss' %in% metrics) {
    result <- append(result, list('rpss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  } 
  if ('rpss_score_aggr' %in% metrics) {
    result <- append(result, list('rpss_score_aggr' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  } 
  if ('frpss' %in% metrics) {
    result <- append(result, list('frpss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  }
  if ('crps' %in% metrics) {
    result <- append(result, list('crps' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  } 
  if ('crpss' %in% metrics) {
    result <- append(result, list('crpss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  }
  if ('crpss_score_aggr' %in% metrics) {
    result <- append(result, list('crpss_score_aggr' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  } 
  if ('bss10' %in% metrics) {
    result <- append(result, list('bss10' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  }
  if ('bss90' %in% metrics) {
    result <- append(result, list('bss90' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  }
  if ('enssprerr' %in% metrics ) {
    result <- append(result, list('enssprerr' = c(0, 0.6, 0.7, 0.8, 0.9, 1, 1.2, 1.4, 1.6, 1.8, 2)))
  } 
  if ('rmsss' %in% metrics ) {
    result <- append(result, list('rmsss' = c(-0.5, -0.4, -0.3, -0.2, -0.1, 0, 0.1, 0.2, 0.3, 0.4, 0.5)))
  } 
  return(result)
}  

## Define legend lower limit color

.legend_col_inf <- function(metrics, colorunder) { 
  result <- list()
  if ('mean_bias' %in% metrics) {
    result <- append(result, list('mean_bias' = colorunder))
  }
  if ('enscorr' %in% metrics) {
    result <- append(result, list('enscorr' = NULL))
  }
  if ('rps' %in% metrics ) {
    result <- append(result, list('rps' = NULL))
  } 
  if ('frps' %in% metrics ) {
    result <- append(result, list('frps' = NULL))
  } 
  if ('rpss' %in% metrics) {
    result <- append(result, list('rpss' = colorunder))
  } 
  if ('rpss_score_aggr' %in% metrics) {
    result <- append(result, list('rpss_score_aggr' = colorunder))
  } 
  if ('frpss' %in% metrics) {
    result <- append(result, list('frpss' = colorunder))
  }
  if ('crps' %in% metrics) {
    result <- append(result, list('crps' = NULL))
  } 
  if ('crpss' %in% metrics) {
    result <- append(result, list('crpss' = colorunder))
  }
  if ('crpss_score_aggr' %in% metrics) {
    result <- append(result, list('crpss_score_aggr' = colorunder))
  } 
  if ('bss10' %in% metrics) {
    result <- append(result, list('bss10' = colorunder))
  }
  if ('bss90' %in% metrics) {
    result <- append(result, list('bss90' = colorunder))
  }
  if ('enssprerr' %in% metrics ) {
    result <- append(result, list('enssprerr' = NULL))
  } 
  if ('rmsss' %in% metrics ) {
    result <- append(result, list('rmsss' = colorunder))
  } 
  return(result)
}  


## Define legend upper limit color

.legend_col_sup <- function(metrics, colorsup) { 
  result <- list()
  if ('mean_bias' %in% metrics) {
    result <- append(result, list('mean_bias' = colorsup))
  }
  if ('enscorr' %in% metrics) {
    result <- append(result, list('enscorr' = NULL))
  }
  if ('rps' %in% metrics ) {
    result <- append(result, list('rps' = NULL))
  } 
  if ('frps' %in% metrics ) {
    result <- append(result, list('frps' = NULL))
  } 
  if ('rpss' %in% metrics) {
    result <- append(result, list('rpss' = colorsup))
  } 
  if ('rpss_score_aggr' %in% metrics) {
    result <- append(result, list('rpss_score_aggr' = colorsup))
  } 
  if ('frpss' %in% metrics) {
    result <- append(result, list('frpss' = colorsup))
  }
  if ('crps' %in% metrics) {
    result <- append(result, list('crps' = colorsup))
  } 
  if ('crpss' %in% metrics) {
    result <- append(result, list('crpss' = colorsup))
  }
  if ('crpss_score_aggr' %in% metrics) {
    result <- append(result, list('crpss_score_aggr' = colorsup))
  } 
  if ('bss10' %in% metrics) {
    result <- append(result, list('bss10' = colorsup))
  }
  if ('bss90' %in% metrics) {
    result <- append(result, list('bss90' = colorsup))
  }
  if ('enssprerr' %in% metrics ) {
    result <- append(result, list('enssprerr' = colorsup))
  } 
  if ('rmsss' %in% metrics ) {
    result <- append(result, list('rmsss' = colorsup))
  } 
  return(result)
}  




## Output file name to save scorecard
.Filename <- function(system = NULL, reference = NULL, model = NULL, eval.name = NULL, 
                      var = NULL, start.year = NULL, end.year = NULL, scorecard.type = NULL, 
                      region = NULL, fileout.label = NULL, output.path = NULL) {
  
  ## Remove . from names
  system <- gsub('.','', system, fixed = T)
  reference <- gsub('.','', reference, fixed = T)
  
  period <- paste0(start.year, "-", end.year)

  if (scorecard.type == 1 || scorecard.type == 2 || scorecard.type == 3 || scorecard.type == 4 ) {
    scorecard_save_path <- paste0(output.path, 
                                  "/scorecard-", scorecard.type, "_", system, "_", 
                                  reference, "_", var, "_", period,
                                  fileout.label, ".png")
  } else {
    scorecard_save_path <- paste0(output.path, 
                                  "/scorecard-", scorecard.type, "_multi-", 
                                  tolower(model), "_", eval.name, "_",
                                  var, "_", period, "_", region,
                                  fileout.label, ".png")
  }
  
  return(scorecard_save_path)
}

# Scorecards function to assign background color of table cells, 
# color of text in table and to bold the text.
#
# It will return a list  with 2 arrays: 
# (1) metric.color, A 2-dimensional array with character strings containing the 
# color codes for each cell background.
# (2) metric.text.color, A 2-dimensional array with character strings 
# containing the color codes for each cell text.
.SCTableColors <- function(table, n.col, n.subcol, n.row, n.subrow, 
                           legend.breaks, palette, colorunder, colorsup) {
  # Define rows and columns
  n.rows <- n.row * n.subrow
  n.columns <- n.col * n.subcol

  ## Set table background colors
  metric.color <- array(colorunder, c(n.row * n.subrow, n.columns)) 
  metric.text.color <- array("#2A2A2A", c(n.row * n.subrow , n.columns)) 
  # metric.text.bold <- array(TRUE, c(n.row * n.subrow , n.columns - 2)) ## Setting all values to bold
  
  ## Define cell and text colors to show in table
  for (i in 1:n.col) {
    metric.int <- legend.breaks[[i]]
    for (rr in 1:n.rows) {
      for (j in 1:n.subcol) {
        for (pp in 1:(length(metric.int) - 1)) {
          if (is.nan(table[rr,((i - 1) * n.subcol + j)])) {
            metric.color[rr,((i - 1) * n.subcol + j)] <- "gray"
          } else {
            if (table[rr,((i - 1) * n.subcol + j)] >= 
                metric.int[pp] && table[rr,((i - 1) * n.subcol + j)] <= 
                metric.int[pp+1]) {
              metric.color[rr,((i - 1) * n.subcol + j)] <- palette[[i]][pp] #palette[pp]
            } 
            if (table[rr,((i - 1) * n.subcol + j)] < metric.int[1]) {
              metric.color[rr,((i - 1) * n.subcol + j)] <- colorunder[i]
            }
            if (table[rr,((i - 1) * n.subcol + j)] >= 
                metric.int[length(metric.int)]) {
              metric.color[rr,((i - 1) * n.subcol + j)] <- colorsup[i]
            } 
          }
          ## color text in white and bold if background is white or dark blue or dark red:
          if (is.nan(table[rr,((i - 1) * n.subcol + j)]) ||
              (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == 1 && 
                       table[rr,((i - 1) * n.subcol + j)] < metric.int[2]) ||
              (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == 2 && 
                       table[rr,((i - 1) * n.subcol + j)] < metric.int[3]) ||
              (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == (length(metric.int) - 1) && 
                       table[rr,((i - 1) * n.subcol + j)] >= metric.int[length(metric.int) - 1]) ||
              (!is.nan(table[rr,((i - 1) * n.subcol + j)]) && pp == (length(metric.int) - 2) && 
                       table[rr,((i - 1) * n.subcol + j)] >= metric.int[length(metric.int) - 2])) {
            metric.text.color[rr,((i - 1) * n.subcol + j)] <- "white"
            #metric.text.bold[rr,((i - 1) * n.subcol + j)] <- TRUE
          }
        }
      }
    }
  }
  
  return(list(metric.color = metric.color, 
              metric.text.color = metric.text.color))
  
}

# Scorecards function to create the color bar legends for the required metrics
# and paste them below the scorecard table
.SCLegend <- function(legend.breaks, palette, colorunder, colorsup,
                      label.scale, legend.width, legend.height,
                      legend.white.space, fileout) {
  
  ## Create color bar legends for each metric
  for (i in 1:length(palette)) {
    png(filename = paste0(fileout, '_tmpLegend', i, '.png'), width = legend.width, 
        height = legend.height) 
    ColorBar(brks = legend.breaks[[i]], cols = palette[[i]], vertical = FALSE, 
             label_scale = label.scale, col_inf = colorunder[[i]], 
             col_sup = colorsup[[i]]) 
    dev.off()
    if (i == 1) {
      ## Add white space to the left of the first color bar legend
      system(paste0('convert ', fileout, '_tmpLegend1.png -background white -splice ', 
                    legend.white.space, 'x0 ', fileout, '_tmpScorecardLegend.png'))
    } else {
      system(paste0('convert +append ', fileout, '_tmpScorecardLegend.png ',
                    fileout, '_tmpLegend', i, '.png ', fileout, 
                    '_tmpScorecardLegend.png'))
    }
  }
  unlink(paste0(fileout,'_tmpLegend*.png'))
}

# Function to calculate color bar breaks for bias metric
.SCBiasBreaks <- function(data){
  
  bias.minmax_max <- quantile(data, 0.98, na.rm = TRUE)
  bias.minmax_min <- quantile(data, 0.02, na.rm = TRUE)
  bias.max <- max(abs(bias.minmax_min), abs(bias.minmax_max))
  
  ## one point more than the colors below (the intervals)
  bias.int <- bias.max * c(-1, -0.8, -0.6, -0.4, -0.2, 0, 0.2, 0.4, 0.6, 0.8, 1) 
  
  ## round to 2 significance figures
  bias.int <- signif(bias.int, digits = 2)
  
  return(bias.int)
}

# Function to calculate color bar breaks for CRPS metric
.SCCrpsBreaks <- function(data){
  
  crps.max <- quantile(data, 0.98, na.rm = TRUE)
  
  crps.int <- crps.max * c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1) 
  
  ## round to 2 significance figures
  crps.int <- signif(crps.int, digits = 2)
  
  return(crps.int)
}

# Auxiliary function to get the names of the longitude coordinate
.KnownLonNames <- function() {
  known_lon_names <- c('lon', 'lons', 'longitude', 'x', 'i', 'nav_lon')
}

# Auxiliary function to get the names of the latitude coordinate
.KnownLatNames <- function() {
  known_lat_names <- c('lat', 'lats', 'latitude', 'y', 'j', 'nav_lat')
}
