#'Scorecards function create simple scorecards by region (types 1 & 3)
#' 
#'@description This function creates a scorecard for a single system and 
#'reference combination, showing data by region and forecast month.
#'  
#'@param data A multidimensional array containing spatially aggregated metrics 
#'  data with dimensions: metric, region, sdate and ftime.
#'@param sign A multidimensional boolean array with the same dimensions as 
#'  'data', indicting which values to be highlighted. If set to NULL no values 
#'  will be highlighted.
#'@param row.dim A character string indicating the dimension name to show in the 
#'  rows of the plot.
#'@param subrow.dim A character string indicating the dimension name to show in 
#'  the sub-rows of the plot.
#'@param col.dim A character string indicating the dimension name to show in the 
#'  columns of the plot.
#'@param subcol.dim A character string indicating the dimension name to show in  
#'  the sub-columns of the plot.
#'@param legend.dim  A character string indicating the dimension name to use for 
#'  the legend.
#'@param row.names A vector of character strings with row display names.
#'@param subrow.names A vector of character strings with sub-row display names.
#'@param col.names A vector of character strings with column display names.
#'@param subcol.names A vector of character strings with sub-column display 
#'  names.
#'@param row.title A character string for the title of the row names.
#'@param subrow.title A character string for the title of the sub-row names.
#'@param table.title A character string for the title of the plot.
#'@param table.subtitle A character string for the sub-title of the plot.
#'@param legend.breaks A vector of numerics or a list of vectors of numerics,
#'  containing the breaks for the legends. If a vector is given as input, then 
#'  these breaks will be repeated for each legend.dim. A list of vectors can be 
#'  given as input if the legend.dims require different breaks. This parameter 
#'  is required even if the legend is not plotted, to define the colors in the 
#'  scorecard table.
#'@param plot.legend A logical value to determine if the legend is plotted.
#'@param legend.width A numeric value to define the width of the legend bars.
#'@param legend.height A numeric value to define the height of the legend bars.
#'@param label.scale A numeric value to define the size of the legend labels.
#'@param palette A vector of character strings or a list of vectors of 
#'  character strings containing the colors to use in the legends. If a vector 
#'  is given as input, then these colors will be used for each legend.dim. A 
#'  list of vectors can be given as input if different colors are desired for 
#'  the legend.dims. This parameter must be included even if the the legend is 
#'  not plotted, to define the colors in the scorecard table.
#'@param colorunder A character string or of vector of character strings 
#'  defining the colors to use for data values with are inferior to the lowest 
#'  breaks value. This parameter will also plot a inferior triangle in the 
#'  legend bar. The parameter can be set to NULL if there are no inferior values.
#'  If a character string is given this color will be applied to all legend.dims.
#'@param colorsup A character string or of vector of character strings 
#'  defining the colors to use for data values with are superior to the highest 
#'  breaks value. This parameter will also plot a inferior triangle in the 
#'  legend bar. The parameter can be set to NULL if there are no superior values.
#'  If a character string is given this color will be applied to all legend.dims. 
#'@param legend.white.space A numeric value defining the initial starting 
#'  position of the legend bars, the white space infront of the legend is 
#'  calculated from the left most point of the table as a distance in cm.
#'@param round.decimal A numeric indicating to which decimal point the data 
#'  is to be displayed in the scorecard table. Default is 2.
#'@param font.size A numeric indicating the font size on the scorecard table.
#'@param col1.width A numeric value defining the width of the first table column
#'  in cm.
#'@param col2.width A numeric value defining the width of the second table 
#'  column in cm.
#'@param columns.width A numeric value defining the width all columns within the 
#'  table in cm (excluding the first and second columns containing the titles).
#'@param fileout A path of the location to save the scorecard plots.
#' 
#'@return An image file containing the scorecard.
#'@example 
#'data <- array(rnorm(1000), dim = c('sdate' = 12, 'metric' = 4, 'region' = 3, 
#'                                   'time' = 6)) 
#'row.names <- c('Tropics', 'Extra-tropical NH', 'Extra-tropical SH')
#'col.names <- c('Mean bias (K)', 'Correlation', 'RPSS','CRPSS')
#'SCPlotScorecard(data = data, row.names = row.names, col.names = col.names, 
#'                subcol.names =  month.abb[as.numeric(1:12)],
#'                row.title = 'Region', subrow.title = 'Forecast Month', 
#'                col.title = 'Start date', 
#'                table.title = "Temperature of ECMWF System 5", 
#'                table.subtitle = "(Ref: ERA5 1994-2016)", 
#'                fileout = 'test.png')
#'
#'@import kableExtra
#'@import s2dv
#'@import ClimProjDiags
#'@export
SCPlotScorecard <- function(data, sign = NULL, 
                            row.dim = 'region', subrow.dim = 'time',
                            col.dim = 'metric', subcol.dim = 'sdate',
                            legend.dim = 'metric', row.names = NULL,
                            subrow.names = NULL, col.names = NULL,
                            subcol.names = NULL, row.title = NULL,
                            subrow.title = NULL, col.title = NULL,
                            table.title = NULL, table.subtitle = NULL,
                            legend.breaks = NULL, plot.legend = TRUE,
                            label.scale = NULL, legend.width = NULL,
                            legend.height = NULL, palette = NULL,
                            colorunder = NULL, colorsup = NULL,
                            round.decimal = 2, font.size = 1.1,
                            legend.white.space = NULL, 
                            col1.width = NULL, col2.width = NULL,
                            columns.width = 1.2,
                            fileout = './scorecard.png') {
  # Input parameter checks
  ## Check data
  if (!is.array(data)) {
    stop("Parameter 'data' must be a numeric array.")
  }
  ## Check sign
  if (is.null(sign)){
    sign <- array(F, dim = dim(data))
  } else {
    if (!is.array(sign)) {
      stop("Parameter 'sign' must be a boolean array or NULL.")
    }
  }
  ## Check row.dim
  if (!is.character(row.dim)) {
    stop("Parameter 'row.dim' must be a character string.")
  }
  if (!row.dim %in% names(dim(data))) {
    stop("Parameter 'row.dim' is not found in 'data' dimensions.")
  }
  ## Check row.names
  if (!is.null(row.names)) {
    if (length(row.names) != as.numeric(dim(data)[row.dim])) {
      stop("Parameter 'row.names' must have the same length of dimension 'row.dims'.")
    }
  } else {
    row.names <- as.character(1:dim(data)[row.dim])
  }
  ## Check subrow.dim
  if (!is.character(subrow.dim)) {
    stop("Parameter 'subrow.dim' must be a character string.")
  }
  if (!subrow.dim %in% names(dim(data))) {
    stop("Parameter 'subrow.dim' is not found in 'data' dimensions.")
  }
  ## Check subrow.names
  if (!is.null(subrow.names)) {
    if (length(subrow.names) != as.numeric(dim(data)[subrow.dim])) {
      stop("Parameter 'subrow.names' must have the same length of dimension 'subrow.dims'.")
    }
  } else {
    subrow.names <- as.character(1:dim(data)[subrow.dim])
  }
  ## Check col.dim
  if (!is.character(col.dim)) {
    stop("Parameter 'col.dim' must be a character string.")
  }
  if (!col.dim %in% names(dim(data))) {
    stop("Parameter 'col.dim' is not found in 'data' dimensions.")
  }
  ## Check col.names
  if (!is.null(col.names)) {
    if (length(col.names) != as.numeric(dim(data)[col.dim])) {
      stop("Parameter 'col.names' must have the same length of dimension 'col.dims'.")
    }
  } else {
    col.names <- as.character(1:dim(data)[col.dim])
  }
  ## Check subcol.dim
  if (!is.character(subcol.dim)) {
    stop("Parameter 'subcol.dim' must be a character string.")
  }
  if (!subcol.dim %in% names(dim(data))) {
    stop("Parameter 'subcol.dim' is not found in 'data' dimensions.")
  }
  ## Check subcol.names
  if (!is.null(subcol.names)) {
    if (length(subcol.names) != as.numeric(dim(data)[subcol.dim])) {
      stop("Parameter 'subcol.names' must have the same length of dimension 'subcol.dims'.")
    }
  } else {
    subcol.names <- as.character(1:dim(data)[subcol.dim])
  }
  ## Check legend.dim
  if (!is.character(legend.dim)) {
    stop("Parameter 'legend.dim' must be a character string.")
  }
  if (!legend.dim %in% names(dim(data))) {
    stop("Parameter 'legend.dim' is not found in 'data' dimensions.")
  }
  ## Check row.title inputs
  if (!is.null(row.title)) {
    if (!is.character(row.title)) {
      stop("Parameter 'row.title must be a character string.")
    }
  } else {
    row.title <- ""
  }
  ## Check subrow.title
  if (!is.null(subrow.title)) {
    if (!is.character(subrow.title)) {
      stop("Parameter 'subrow.title must be a character string.")
    }
  } else {
    subrow.title <- ""
  }
  ## Check col.title
  if (!is.null(col.title)) {
    if (!is.character(col.title)) {
      stop("Parameter 'col.title must be a character string.")
    }
  } else {
    col.title <- ""
  }
  ## Check table.title
  if (!is.null(table.title)) {
    if (!is.character(table.title)) {
      stop("Parameter 'table.title' must be a character string.")
    }
  } else {
    table.title <- ""
  }
  ## Check table.subtitle
  if (!is.null(table.subtitle)) {
    if (!is.character(table.subtitle)) {
      stop("Parameter 'table.subtitle' must be a character string.")
    }
  } else {
    table.subtitle <- ""
  }
  # Check legend.breaks
  if (is.vector(legend.breaks) && is.numeric(legend.breaks)) {
    legend.breaks <- rep(list(legend.breaks), as.numeric(dim(data)[legend.dim]))
  } else if (is.null(legend.breaks)) {
    legend.breaks <- rep(list(seq(-1, 1, 0.2)), as.numeric(dim(data)[legend.dim]))
  } else if (inherits(legend.breaks, 'list')) {
    stopifnot(length(legend.breaks) == as.numeric(dim(data)[legend.dim]))
  } else {
    stop("Parameter 'legend.breaks' must be a numeric vector, a list or NULL.")
  }
  ## Check plot.legend
  if (!inherits(plot.legend, 'logical')) {
    stop("Parameter 'plot.legend' must be a logical value.")
  }
  ## Check label.scale
  if (is.null(label.scale)) {
    label.scale <- 1.4
  } else {
    if (!is.numeric(label.scale) | length(label.scale) != 1) {
      stop("Parameter 'label.scale' must be a numeric value of length 1.")
    }
  }
  ## Check legend.width
  if (is.null(legend.width)) {
    legend.width <- length(subcol.names) * 46.5
  } else {
    if (!is.numeric(legend.width) | length(legend.width) != 1) {
      stop("Parameter 'legend.width' must be a numeric value of length 1.")
    }
  }
  if (is.null(legend.height)) {
    legend.height <- 50
  } else {
    if (!is.numeric(legend.height) | length(legend.height) != 1) {
      stop("Parameter 'legend.height' must be a numeric value of length 1.")
    }
  }
  ## Check colour palette input
  if (is.vector(palette)) {
    palette <- rep(list(palette), as.numeric(dim(data)[legend.dim]))
  } else if (is.null(palette)) {
    palette <- rep(list(c('#2D004B', '#542789', '#8073AC', '#B2ABD2', '#D8DAEB', 
                          '#FEE0B6', '#FDB863', '#E08214', '#B35806', '#7F3B08')), 
                        as.numeric(dim(data)[legend.dim]))
  } else if (inherits(palette, 'list')) {
    stopifnot(length(palette) == as.numeric(dim(data)[legend.dim]))
  } else {
    stop("Parameter 'palette' must be a numeric vector, a list or NULL.")
  }
  ## Check colorunder
  if (is.null(colorunder)) {
    colorunder <- rep("#04040E",as.numeric(dim(data)[legend.dim]))
  } else if (is.character(colorunder) && length(colorunder) == 1) {
    colorunder <- rep(colorunder, as.numeric(dim(data)[legend.dim]))
  } else if (is.character(colorunder) && 
             length(colorunder) != as.numeric(dim(data)[legend.dim])) {
    stop("Parameter 'colorunder' must be a numeric vector, a list or NULL.")
  }
  ## Check colorsup
  if (is.null(colorsup)) {
    colorsup <- rep("#730C04", as.numeric(dim(data)[legend.dim]))
  } else if (is.character(colorsup) && length(colorsup) == 1) {
    colorsup <- rep(colorsup,as.numeric(dim(data)[legend.dim]))
  } else if (is.character(colorsup) && 
             length(colorsup) != as.numeric(dim(data)[legend.dim])) {
    stop("Parameter 'colorsup' must be a numeric vector, a list or NULL.")
  }
  ## Check round.decimal
  if (is.null(round.decimal)) {
    round.decimal <- 2
  } else if (!is.numeric(round.decimal) | length(round.decimal) != 1) {
    stop("Parameter 'round.decimal' must be a numeric value of length 1.")
  }
  ## Check font.size
  if (is.null(font.size)) {
    font.size <- 1
  } else if (!is.numeric(font.size) | length(font.size) != 1) {
    stop("Parameter 'font.size' must be a numeric value of length 1.")
  }
  ## Check legend white space
  if (is.null(legend.white.space)){
    legend.white.space <- 6
  } else {
    legend.white.space <- legend.white.space
  }
  ## Check col1.width
  if (is.null(col1.width)) {
    if (max(nchar(row.names)) == 1 ) {
      col1.width <- max(nchar(row.names))
    } else {
      col1.width <- max(nchar(row.names))/4
    }
  } else if (!is.numeric(col1.width)) {
    stop("Parameter 'col1.width' must be a numeric value of length 1.")
  }  
  ## Check col2.width
  if (is.null(col2.width)) {
    if (max(nchar(subrow.names)) == 1 ) {
      col2.width <- max(nchar(subrow.names))
    } else {
      col2.width <- max(nchar(subrow.names))/4
    }
  } else if (!is.numeric(col2.width)) {
    stop("Parameter 'col2.width' must be a numeric value of length 1.")
  }

  
  # Get dimensions of inputs
  n.col.names <- length(col.names) 
  n.subcol.names <- length(subcol.names)
  n.row.names <- length(row.names)
  n.subrow.names <- length(subrow.names)
  
  # Define table size
  n.rows <- n.row.names * n.subrow.names 
  n.columns <- 2 + (n.col.names * n.subcol.names)
  
  # Column names
  row.names.table <- rep("", n.rows)
  for (row in 1:n.row.names) {
    row.names.table[floor(n.subrow.names/2) + (row - 1) * n.subrow.names] <- row.names[row]
  }
  
  # Define scorecard table titles
  column.titles <- c(row.title, subrow.title, rep(c(subcol.names), n.col.names))
  
  # Round data
  data <- round(data, round.decimal)
  
  # Define data inside the scorecards table
  for (row in 1:n.row.names) {
    table_temp <- data.frame(table_column_2 = as.character(subrow.names))
    for (col in 1:n.col.names) {
      table_temp <- data.frame(table_temp, 
                               Reorder(data = Subset(x = data, along = c(col.dim, row.dim), 
                                                     indices = list(col, row), drop = 'selected'), 
                               order = c(subrow.dim, subcol.dim)))
    }
    if (row == 1) {
      table_data <- table_temp
    } else {
      table_data <- rbind(table_data, table_temp)
    }
  }

    # All data for plotting in table
  table <- data.frame(table_column_1 = row.names.table, table_data)
  table_temp <- array(unlist(table[3:n.columns]), dim = c(n.rows, n.columns - 2))
  
  # Define colors to show in table
  table_colors  <- .SCTableColors(table = table_temp,
                                  n.col = n.col.names, n.subcol = n.subcol.names,
                                  n.row = n.row.names, n.subrow = n.subrow.names, 
                                  legend.breaks = legend.breaks, palette = palette, 
                                  colorunder = colorunder, colorsup = colorsup)
  
  metric.color <- table_colors$metric.color
  metric.text.color <- table_colors$metric.text.color
  # metric.text.bold <- table_colors$metric.text.bold
  
  # Remove temporary table
  rm(table_temp)

  ## Format values to underline in table
  metric.underline <- MergeDims(sign, c(subcol.dim, col.dim) , rename_dim = 'col', na.rm =F)
  metric.underline <- MergeDims(metric.underline, c(subrow.dim, row.dim) , rename_dim = 'row', na.rm =F)
  
  options(stringsAsFactors = FALSE) 
  title <- data.frame(c1 = table.title, c2 = n.columns)
  subtitle <- data.frame(c1 = table.subtitle, c2 = n.columns)
  header.names <- as.data.frame(data.frame(c1 = c("", col.names), 
                                           c2 = c(2, rep(n.subcol.names, n.col.names))))
  header.names2 <- as.data.frame(data.frame(c1 = c("", paste0(rep(col.title, n.col.names))), 
                                            c2 = c(2, rep(n.subcol.names, n.col.names))))
  title.space <- data.frame(c1 = "\n", c2 = n.columns)
  
  # Hide NA values in table
  options(knitr.kable.NA = '')
  
  # Create HTML table
  table.html.part <- list()
  table.html.part[[1]] <- kbl(table, escape = F, col.names = column.titles, align = rep("c", n.columns)) %>%
                          kable_paper("hover", full_width = F, font_size = 14 * font.size) %>%
                          add_header_above(header = header.names2, font_size = 16 * font.size) %>%
                          add_header_above(header = title.space, font_size = 10 * font.size) %>%
                          add_header_above(header = header.names, font_size = 20 * font.size) %>%
                          add_header_above(header = title.space, font_size = 10 * font.size) %>%
                          add_header_above(header = subtitle, font_size = 16 * font.size, align = "left") %>% 
                          add_header_above(header = title.space, font_size = 10 * font.size) %>%
                          add_header_above(header = title, font_size = 22 * font.size, align = "left")
  
  for (i in 1:n.col.names) { 
    for (j in 1:n.subcol.names) { 
      my.background <- metric.color[, (i - 1) * n.subcol.names + j]
      my.text.color <- metric.text.color[, (i - 1) * n.subcol.names + j]
      my.underline <- metric.underline[, (i - 1) * n.subcol.names + j]
      # my.bold <- metric.text.bold[(i - 1) * n.subcol.names + j]
      
      table.html.part[[(i - 1) * n.subcol.names + j + 1]] <-
        column_spec(table.html.part[[(i - 1) * n.subcol.names + j]], 
                    2 + n.subcol.names * (i - 1) + j, 
                    background = my.background[1:n.rows], 
                    color = my.text.color[1:n.rows], 
                    underline = my.underline[1:n.rows],
                    bold = T) ## strsplit(toString(bold), ', ')[[1]]
    }
  }

  # Define position of table borders
  column.borders <- NULL
  for (i in 1:n.col.names) {
    column.spacing <- (n.subcol.names * i) + 2
    column.borders <- c(column.borders, column.spacing)
  }
  
  n.last.list <- n.col.names * n.subcol.names + 1

  table.html <- column_spec(table.html.part[[n.last.list]], 1, bold = TRUE, width_min = paste0(col1.width, 'cm')) %>%
                column_spec(2, bold = TRUE,  width_min = paste0(col2.width, 'cm')) %>%
                column_spec(3:n.columns, width_min = paste0(columns.width, 'cm')) %>% 
                column_spec(c(1, 2, column.borders), border_right = "2px solid black") %>% 
                column_spec(1, border_left = "2px solid black") %>%
                column_spec(n.columns, border_right = "2px solid black") %>%
                row_spec(seq(from = 0, to = n.subrow.names * n.row.names, by = n.subrow.names), 
                         extra_css = "border-bottom: 2px solid black", hline_after = TRUE)
  
  if (plot.legend == TRUE) {
    # Save the scorecard (without legend)
    save_kable(table.html, file = paste0(fileout, '_tmpScorecard.png'), vheight = 1)
    
    # White space for legend
    legend.white.space <- 37.8 * legend.white.space ## converting pixels to cm
    
    # Create and save color bar legend
    scorecard_legend <- .SCLegend(legend.breaks = legend.breaks,
                                  palette = palette,
                                  colorunder = colorunder,
                                  colorsup = colorsup,
                                  label.scale = label.scale,
                                  legend.width = legend.width,
                                  legend.height = legend.height,
                                  legend.white.space = legend.white.space,
                                  fileout = fileout)
    
    # Add the legends below the scorecard table 
    system(paste0('convert -append ', fileout, '_tmpScorecard.png ', fileout, 
                  '_tmpScorecardLegend.png ', fileout))
    # Remove temporary scorecard table
    unlink(paste0(fileout, '_tmpScorecard*.png'))
  }
  if (plot.legend == FALSE) {
    save_kable(table.html, file = fileout)
  } 
}
