R/ColorBar.R

In s2dverification: Set of Common Tools for Forecast Verification

#'Draws a Color Bar
#'
#'Generates a color bar to use as colouring function for map plots and 
#'optionally draws it (horizontally or vertically) to be added to map 
#'multipanels or plots. It is possible to draw triangles at the ends of the 
#'colour bar to represent values that go beyond the range of interest. A 
#'number of options is provided to adjust the colours and the position and 
#'size of the components. The drawn colour bar spans a whole figure region 
#'and is compatible with figure layouts.\cr\cr 
#'The generated colour bar consists of a set of breaks that define the 
#'length(brks) - 1 intervals to classify each of the values in each of the 
#'grid cells of a two-dimensional field. The corresponding grid cell of a 
#'given value of the field will be coloured in function of the interval it 
#'belongs to.\cr\cr
#'The only mandatory parameters are 'var_limits' or 'brks' (in its second 
#'format, see below).
#'
#'@param brks Can be provided in two formats:
#'\itemize{
#'  \item{A single value with the number of breaks to be generated 
#'  automatically, between the minimum and maximum specified in 'var_limits' 
#'  (both inclusive). Hence the parameter 'var_limits' is mandatory if 'brks' 
#'  is provided with this format. If 'bar_limits' is additionally provided, 
#'  values only between 'bar_limits' will be generated. The higher the value 
#'  of 'brks', the smoother the plot will look.}
#'  \item{A vector with the actual values of the desired breaks. Values will 
#'  be reordered by force to ascending order. If provided in this format, no 
#'  other parameters are required to generate/plot the colour bar.}
#'}
#'  This parameter is optional if 'var_limits' is specified. If 'brks' not 
#'  specified but 'cols' is specified, it will take as value length(cols) + 1. 
#'  If 'cols' is not specified either, 'brks' will take 21 as value.
#'@param cols Vector of length(brks) - 1 valid colour identifiers, for each 
#'  interval defined by the breaks. This parameter is optional and will be 
#'  filled in with a vector of length(brks) - 1 colours generated with the 
#'  function provided in 'color_fun' (\code{clim.colors} by default).\cr 'cols' 
#'  can have one additional colour at the beginning and/or at the end with the 
#'  aim to colour field values beyond the range of interest represented in the 
#'  colour bar. If any of these extra colours is provided, parameter 
#'  'triangle_ends' becomes mandatory in order to disambiguate which of the 
#'  ends the colours have been provided for.
#'@param vertical TRUE/FALSE for vertical/horizontal colour bar 
#'  (disregarded if plot = FALSE).
#'@param subsampleg The first of each subsampleg breaks will be ticked on the 
#'  colorbar. Takes by default an approximation of a value that yields a 
#'  readable tick arrangement (extreme breaks always ticked). If set to 0 or 
#'  lower, no labels are drawn. See the code of the function for details or 
#'  use 'extra_labels' for customized tick arrangements.
#'@param bar_limits Vector of two numeric values with the extremes of the 
#'  range of values represented in the colour bar. If 'var_limits' go beyond 
#'  this interval, the drawing of triangle extremes is triggered at the 
#'  corresponding sides, painted in 'col_inf' and 'col_sup'. Either of them 
#'  can be set as NA and will then take as value the corresponding extreme in 
#'  'var_limits' (hence a triangle end won't be triggered for these sides). 
#'  Takes as default the extremes of 'brks' if available, else the same values 
#'  as 'var_limits'.
#'@param var_limits Vector of two numeric values with the minimum and maximum 
#'  values of the field to represent. These are used to know whether to draw 
#'  triangle ends at the extremes of the colour bar and what colour to fill 
#'  them in with. If not specified, take the same value as the extremes of 
#'  'brks'. Hence the parameter 'brks' is mandatory if 'var_limits' is not 
#'  specified.
#'@param triangle_ends Vector of two logical elements, indicating whether to 
#'  force the drawing of triangle ends at each of the extremes of the colour 
#'  bar. This choice is automatically made from the provided 'brks', 
#'  'bar_limits', 'var_limits', 'col_inf' and 'col_sup', but the behaviour 
#'  can be manually forced to draw or not to draw the triangle ends with this 
#'  parameter. If 'cols' is provided, 'col_inf' and 'col_sup' will take 
#'  priority over 'triangle_ends' when deciding whether to draw the triangle 
#'  ends or not.
#'@param col_inf Colour to fill the inferior triangle end with. Useful if 
#'  specifying colours manually with parameter 'cols', to specify the colour 
#'  and to trigger the drawing of the lower extreme triangle, or if 'cols' is 
#'  not specified, to replace the colour automatically generated by ColorBar().
#'@param col_sup Colour to fill the superior triangle end with. Useful if 
#'  specifying colours manually with parameter 'cols', to specify the colour 
#'  and to trigger the drawing of the upper extreme triangle, or if 'cols' is 
#'  not specified, to replace the colour automatically generated by ColorBar().
#'@param color_fun Function to generate the colours of the color bar. Must 
#'  take an integer and must return as many colours. The returned colour vector 
#'  can have the attribute 'na_color', with a colour to draw NA values. This 
#'  parameter is set by default to clim.palette().
#'@param plot Logical value indicating whether to only compute its breaks and 
#'  colours (FALSE) or to also draw it on the current device (TRUE).
#'@param draw_ticks Whether to draw ticks for the labels along the colour bar 
#' (TRUE) or not (FALSE). TRUE by default. Disregarded if 'plot = FALSE'.
#'@param draw_separators Whether to draw black lines in the borders of each of 
#'  the colour rectancles of the colour bar (TRUE) or not (FALSE). FALSE by 
#'  default. Disregarded if 'plot = FALSE'.
#'@param triangle_ends_scale Scale factor for the drawn triangle ends of the 
#'  colour bar, if drawn at all. Takes 1 by default (rectangle triangle 
#'  proportional to the thickness of the colour bar). Disregarded if 
#'  'plot = FALSE'.
#'@param extra_labels Numeric vector of extra labels to draw along axis of 
#'  the colour bar. The number of provided decimals will be conserved. 
#'  Disregarded if 'plot = FALSE'.
#'@param title Title to draw on top of the colour bar, most commonly with the 
#'  units of the represented field in the neighbour figures. Empty by default.
#'@param title_scale Scale factor for the 'title' of the colour bar. 
#'  Takes 1 by default.
#'@param label_scale Scale factor for the labels of the colour bar. 
#'  Takes 1 by default.
#'@param tick_scale Scale factor for the length of the ticks of the labels 
#'  along the colour bar. Takes 1 by default.
#'@param extra_margin Extra margins to be added around the colour bar, 
#'  in the format c(y1, x1, y2, x2). The units are margin lines. Takes 
#'  rep(0, 4) by default.
#'@param label_digits Number of significant digits to be displayed in the 
#'  labels of the colour bar, usually to avoid too many decimal digits 
#'  overflowing the figure region. This does not have effect over the labels 
#'  provided in 'extra_labels'. Takes 4 by default.
#'@param ... Arguments to be passed to the method. Only accepts the following 
#'  graphical parameters:\cr adj ann ask bg bty cex.lab cex.main cex.sub cin 
#'  col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig fin 
#'  font font.axis font.lab font.main font.sub lend lheight ljoin lmitre lty 
#'  lwd mai mex mfcol mfrow mfg mkh oma omd omi page pch pin plt pty smo srt 
#'  tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog.\cr For more 
#' information about the parameters see `par`.
#'
#'@return 
#'\item{brks}{
#'  Breaks used for splitting the range in intervals.
#'}
#'\item{cols}{
#'  Colours generated for each of the length(brks) - 1 intervals. 
#'  Always of length length(brks) - 1.
#'}
#'\item{col_inf}{
#'  Colour used to draw the lower triangle end in the colour 
#'  bar (NULL if not drawn at all).
#'}
#'\item{col_sup}{
#'  Colour used to draw the upper triangle end in the colour 
#'  bar (NULL if not drawn at all).
#'}
#'
#'@keywords hplot
#'@author History:\cr
#'  0.1 - 2012-04  (V. Guemas) - Original code\cr
#'  0.2 - 2013-04  (I. Andreu-Burillo) - Vert option\cr
#'  1.0 - 2013-09  (N. Manubens) - Formatting to CRAN\cr
#'  1.1 - 2013-09  (C. Prodhomme) - Add cex option\cr
#'  1.2 - 2016-08  (N. Manubens) - New ColorBar\cr
#'                 (V. Torralba)
#'@examples
#'cols <- c("dodgerblue4", "dodgerblue1", "forestgreen", "yellowgreen", "white",
#'          "white", "yellow", "orange", "red", "saddlebrown")
#'lims <- seq(-1, 1, 0.2)
#'ColorBar(lims, cols)
#'@importFrom grDevices col2rgb rgb
#'@export
ColorBar <- function(brks = NULL, cols = NULL, vertical = TRUE, 
                     subsampleg = NULL, bar_limits = NULL, var_limits = NULL, 
                     triangle_ends = NULL, col_inf = NULL, col_sup = NULL, 
                     color_fun = clim.palette(), plot = TRUE, 
                     draw_ticks = TRUE, draw_separators = FALSE, 
                     triangle_ends_scale = 1, extra_labels = NULL, 
                     title = NULL, title_scale = 1, 
                     label_scale = 1, tick_scale = 1, 
                     extra_margin = rep(0, 4), label_digits = 4, ...) {
  # Required checks
  if ((is.null(brks) || length(brks) < 2) && is.null(bar_limits) && is.null(var_limits)) {
    stop("At least one of 'brks' with the desired breaks, 'bar_limits' or ",
         "'var_limits' must be provided to generate the colour bar.")
  }

  # Check brks
  if (!is.null(brks)) {
    if (!is.numeric(brks)) {
      stop("Parameter 'brks' must be numeric if specified.")
    } else if (length(brks) > 1) {
      reorder <- sort(brks, index.return = TRUE)
      if (!is.null(cols)) {
        cols <- cols[reorder$ix[which(reorder$ix <= length(cols))]]
      }
      brks <- reorder$x
    } 
  }

  # Check bar_limits
  if (!is.null(bar_limits)) {
    if (!(all(is.na(bar_limits) | is.numeric(bar_limits)) && (length(bar_limits) == 2))) {
      stop("Parameter 'bar_limits' must be a vector of two numeric elements or NAs.")
    }
  }

  # Check var_limits
  if (!is.null(var_limits)) {
    if (!(is.numeric(var_limits) && (length(var_limits) == 2))) {
      stop("Parameter 'var_limits' must be a numeric vector of length 2.")
    } else if (any(is.na(var_limits))) {
      stop("Parameter 'var_limits' must not contain NA values.")
    } else if (any(is.infinite(var_limits))) {
      stop("Parameter 'var_limits' must not contain infinite values.")
    }
  }

  # Check cols
  if (!is.null(cols)) {
    if (!is.character(cols)) {
      stop("Parameter 'cols' must be a vector of character strings.")
    } else if (any(!sapply(cols, .IsColor))) {
      stop("Parameter 'cols' must contain valid colour identifiers.")
    }
  }

  # Check color_fun
  if (!is.function(color_fun)) {
    stop("Parameter 'color_fun' must be a colour-generator function.")
  }

  # Check integrity among brks, bar_limits and var_limits
  if (is.null(brks) || (length(brks) < 2)) {
    if (is.null(brks)) {
      if (is.null(cols)) {
        brks <- 21
      } else {
        brks <- length(cols) + 1
      }
    }
    if (is.null(bar_limits) || any(is.na(bar_limits))) {
      # var_limits is defined
      if (is.null(bar_limits)) {
        bar_limits <- c(NA, NA)
      }
      half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1)  
      bar_limits[which(is.na(bar_limits))] <- c(var_limits[1] - half_width, var_limits[2] + half_width)[which(is.na(bar_limits))]
      brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
    } else if (is.null(var_limits)) {
      # bar_limits is defined
      var_limits <- bar_limits
      half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1)  
      brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
      var_limits[1] <- var_limits[1] + half_width / 50
    } else {
      # both bar_limits and var_limits are defined
      brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
    }
  } else if (is.null(bar_limits)) {
    if (is.null(var_limits)) {
      # brks is defined
      bar_limits <- c(head(brks, 1), tail(brks, 1))
      var_limits <- bar_limits
      half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (length(brks) - 1)  
      var_limits[1] <- var_limits[1] + half_width / 50
    } else {
      # brks and var_limits are defined
      bar_limits <- c(head(brks, 1), tail(brks, 1))
    }
  } else {
    # brks and bar_limits are defined
    # or
    # brks, bar_limits and var_limits are defined
    if (head(brks, 1) != bar_limits[1] || tail(brks, 1) != bar_limits[2]) {
      stop("Parameters 'brks' and 'bar_limits' are inconsistent.")
    }
  }   
  
  # Check col_inf
  if (!is.null(col_inf)) {
    if (!.IsColor(col_inf)) {
      stop("Parameter 'col_inf' must be a valid colour identifier.")
    }
  }  

  # Check col_sup
  if (!is.null(col_sup)) {
    if (!.IsColor(col_sup)) {
      stop("Parameter 'col_sup' must be a valid colour identifier.")
    }
  }

  # Check triangle_ends
  if (!is.null(triangle_ends) && (!is.logical(triangle_ends) || length(triangle_ends) != 2)) {
    stop("Parameter 'triangle_ends' must be a logical vector with two elements.")
  }
  teflc <- triangle_ends_from_limit_cols <- c(!is.null(col_inf), !is.null(col_sup))
  if (is.null(triangle_ends) && is.null(col_inf) && is.null(col_sup)) {
    triangle_ends <- c(FALSE, FALSE)
    if (bar_limits[1] >= var_limits[1]) {
      triangle_ends[1] <- TRUE
    }
    if (bar_limits[2] < var_limits[2]) {
      triangle_ends[2] <- TRUE
    }
  } else if (!is.null(triangle_ends) && is.null(col_inf) && is.null(col_sup)) {
    triangle_ends <- triangle_ends
  } else if (is.null(triangle_ends) && (!is.null(col_inf) || !is.null(col_sup))) {
    triangle_ends <- teflc
  } else if (any(teflc != triangle_ends)) {
    if (!is.null(brks) && length(brks) > 1 && !is.null(cols) && length(cols) >= length(brks)) {
      triangle_ends <- teflc
    } else if (!is.null(cols)) {
      triangle_ends <- teflc
    } else {
      triangle_ends <- triangle_ends
    }
  }
  if (plot) {
    if ((bar_limits[1] >= var_limits[1]) && !triangle_ends[1]) {
      .warning("There are variable values smaller or equal to the lower limit ",
               "of the colour bar and the lower triangle end has been ",
               "disabled. These will be painted in the colour for NA values.")
    }
    if ((bar_limits[2] < var_limits[2]) && !triangle_ends[2]) {
      .warning("There are variable values greater than the higher limit ",
               "of the colour bar and the higher triangle end has been ",
               "disabled. These will be painted in the colour for NA values.")
    }
  }

  # Generate colours if needed
  if (is.null(cols)) {
    cols <- color_fun(length(brks) - 1 + sum(triangle_ends))
    attr_bk <- attributes(cols)
    if (triangle_ends[1]) {
      if (is.null(col_inf)) col_inf <- head(cols, 1)
      cols <- cols[-1]
    }
    if (triangle_ends[2]) {
      if (is.null(col_sup)) col_sup <- tail(cols, 1)
      cols <- cols[-length(cols)]
    }
    attributes(cols) <- attr_bk
  } else if ((length(cols) != (length(brks) - 1))) {
    stop("Incorrect number of 'brks' and 'cols'. There must be one more break than the number of colours.")
  }

  # Check vertical
  if (!is.logical(vertical)) {
    stop("Parameter 'vertical' must be TRUE or FALSE.")
  }

  # Check extra_labels
  if (is.null(extra_labels)) {
    extra_labels <- numeric(0)
  }
  if (!is.numeric(extra_labels)) {
    stop("Parameter 'extra_labels' must be numeric.")
  } else {
    if (any(extra_labels > bar_limits[2]) || any(extra_labels < bar_limits[1])) {
      stop("Parameter 'extra_labels' must not contain ticks beyond the color bar limits.")
    }
  }
  extra_labels <- sort(extra_labels)

  # Check subsampleg
  primes <- function(x) {
    # Courtesy of Chase. See http://stackoverflow.com/questions/6424856/r-function-for-returning-all-factors
    x <- as.integer(x)
    div <- seq_len(abs(x))
    factors <- div[x %% div == 0L]
    factors <- list(neg = -factors, pos = factors)
    return(factors)
  }
  remove_final_tick <- FALSE
  added_final_tick <- TRUE
  if (is.null(subsampleg)) {
    subsampleg <- 1
    while (length(brks) / subsampleg > 15 - 1) {
      next_factor <- primes((length(brks) - 1) / subsampleg)$pos
      next_factor <- next_factor[length(next_factor) - ifelse(length(next_factor) > 2, 1, 0)]
      subsampleg <- subsampleg * next_factor
    }
    if (subsampleg > (length(brks) - 1) / 4) {
      subsampleg <- max(1, round(length(brks) / 4))
      extra_labels <- c(extra_labels, bar_limits[2])
      added_final_tick <- TRUE
      if ((length(brks) - 1) %% subsampleg < (length(brks) - 1) / 4 / 2) {
        remove_final_tick <- TRUE
      }
    }
  } else if (!is.numeric(subsampleg)) {
    stop("Parameter 'subsampleg' must be numeric.")
  }
  subsampleg <- round(subsampleg)
  draw_labels <- TRUE
  if ((subsampleg) < 1) {
    draw_labels <- FALSE
  }

  # Check plot
  if (!is.logical(plot)) {
    stop("Parameter 'plot' must be logical.")
  }

  # Check draw_separators
  if (!is.logical(draw_separators)) {
    stop("Parameter 'draw_separators' must be logical.")
  }

  # Check triangle_ends_scale
  if (!is.numeric(triangle_ends_scale)) {
    stop("Parameter 'triangle_ends_scale' must be numeric.")
  }

  # Check draw_ticks
  if (!is.logical(draw_ticks)) {
    stop("Parameter 'draw_ticks' must be logical.")
  }

  # Check title
  if (is.null(title)) {
    title <- ''
  }
  if (!is.character(title)) {
    stop("Parameter 'title' must be a character string.")
  }

  # Check title_scale
  if (!is.numeric(title_scale)) {
    stop("Parameter 'title_scale' must be numeric.")
  }

  # Check label_scale
  if (!is.numeric(label_scale)) {
    stop("Parameter 'label_scale' must be numeric.")
  }

  # Check tick_scale
  if (!is.numeric(tick_scale)) {
    stop("Parameter 'tick_scale' must be numeric.")
  }

  # Check extra_margin
  if (!is.numeric(extra_margin) || length(extra_margin) != 4) {
    stop("Parameter 'extra_margin' must be a numeric vector of length 4.")
  }

  # Check label_digits
  if (!is.numeric(label_digits)) {
    stop("Parameter 'label_digits' must be numeric.")
  }
  label_digits <- round(label_digits)

  # Process the user graphical parameters that may be passed in the call
  ## Graphical parameters to exclude
  excludedArgs <- c("cex", "cex.axis", "col", "lab", "las", "mar", "mgp", "new", "ps")
  userArgs <- .FilterUserGraphicArgs(excludedArgs, ...)

  #
  #  Plotting colorbar
  # ~~~~~~~~~~~~~~~~~~~
  #
  if (plot) {
    pars_to_save <- c('mar', 'cex', names(userArgs), 'mai', 'mgp', 'las', 'xpd')
    saved_pars <- par(pars_to_save) 
    par(mar = c(0, 0, 0, 0), cex = 1)
    image(1, 1, t(t(1)), col = rgb(0, 0, 0, 0), axes = FALSE, xlab = '', ylab = '')
    # Get the availale space
    figure_size <- par('fin')
    cs <- par('csi')
    # This allows us to assume we always want to plot horizontally
    if (vertical) {
      figure_size <- rev(figure_size)
    }
#    pannel_to_redraw <- par('mfg')
#    .SwitchToFigure(pannel_to_redraw[1], pannel_to_redraw[2])
    # Load the user parameters
    par(new = TRUE)
    par(userArgs)
    # Set up color bar plot region
    margins <- c(0.0, 0, 0.0, 0)
    cex_title <- 1 * title_scale
    cex_labels <- 0.9 * label_scale
    cex_ticks <- -0.3 * tick_scale
    spaceticklab <- max(-cex_ticks, 0)
    if (vertical) {
      margins[1] <- margins[1] + (1.2 * cex_labels * 3 + spaceticklab) * cs
      margins <- margins + extra_margin[c(4, 1:3)] * cs
    } else {
      margins[1] <- margins[1] + (1.2 * cex_labels * 1 + spaceticklab) * cs
      margins <- margins + extra_margin * cs
    }
    if (title != '') {
      margins[3] <- margins[3] + (1.0 * cex_title) * cs
    }
    margins[3] <- margins[3] + sqrt(figure_size[2] / (margins[1] + margins[3])) * 
                               figure_size[2] / 6 * ifelse(title != '', 0.5, 0.8)
    # Set side margins
    margins[2] <- margins[2] + figure_size[1] / 16
    margins[4] <- margins[4] + figure_size[1] / 16
    triangle_ends_prop <- 1 / 32 * triangle_ends_scale 
    triangle_ends_cex <- triangle_ends_prop * figure_size[2]
    if (triangle_ends[1]) {
      margins[2] <- margins[2] + triangle_ends_cex
    }
    if (triangle_ends[2]) {
      margins[4] <- margins[4] + triangle_ends_cex
    }
    ncols <- length(cols)
    # Set up the points of triangles
    # Compute the proportion of horiz. space occupied by one plot unit
    prop_unit <- (1 - (margins[2] + margins[4]) / figure_size[1]) / ncols
    # Convert triangle height to plot inits
    triangle_height <- triangle_ends_prop / prop_unit
    left_triangle <- list(x = c(1, 1 - triangle_height, 1) - 0.5,
                          y = c(1.4, 1, 0.6))
    right_triangle <- list(x = c(ncols, ncols + triangle_height, ncols) + 0.5,
                           y = c(1.4, 1, 0.6))
    # Draw the color squares and title
    if (vertical) {
      par(mai = c(margins[2:4], margins[1]), 
          mgp = c(0, spaceticklab + 0.2, 0), las = 1)
      d <- 4
      image(1, 1:ncols, t(1:ncols), axes = FALSE, col = cols, 
            xlab = '', ylab = '')
      title(ylab = title, line = cex_title * (0.2 + 0.1), cex.lab = cex_title)
      # Draw top and bottom border lines    
      lines(c(0.6, 0.6), c(1 - 0.5, ncols + 0.5))
      lines(c(1.4, 1.4), c(1 - 0.5, ncols + 0.5))
      # Rotate triangles
      names(left_triangle) <- rev(names(left_triangle))
      names(right_triangle) <- rev(names(right_triangle))
    } else {
      # The term - cex_labels / 4 * (3 / cex_labels - 1) was found by
      # try and error
      par(mai = margins, 
          mgp = c(0, cex_labels / 2 + spaceticklab 
                     - cex_labels / 4 * (3 / cex_labels - 1), 0),
          las = 1)
      d <- 1
      image(1:ncols, 1, t(t(1:ncols)), axes = FALSE, col = cols, 
            xlab = '', ylab = '')
      title(title, line = cex_title * (0.2 + 0.1), cex.main = cex_title)
      # Draw top and bottom border lines    
      lines(c(1 - 0.5, ncols + 0.5), c(0.6, 0.6))
      lines(c(1 - 0.5, ncols + 0.5), c(1.4, 1.4))
      tick_length <- -0.4
    }
    # Draw the triangles
    par(xpd = TRUE)
    if (triangle_ends[1]) {
      # Draw left triangle
      polygon(left_triangle$x, left_triangle$y, col = col_inf, border = NA)
      lines(left_triangle$x, left_triangle$y)       
    }
    if (triangle_ends[2]) {
      # Draw right triangle
      polygon(right_triangle$x, right_triangle$y, col = col_sup, border = NA)
      lines(right_triangle$x, right_triangle$y)
    }
    par(xpd = FALSE)

    # Put the separators
    if (vertical) {
      if (draw_separators) {
        for (i in 1:(ncols - 1)) {
          lines(c(0.6, 1.4), c(i, i) + 0.5)
        }
      }
      if (draw_separators || is.null(col_inf)) {
        lines(c(0.6, 1.4), c(0.5, 0.5))
      }
      if (draw_separators || is.null(col_sup)) {
        lines(c(0.6, 1.4), c(ncols + 0.5, ncols + 0.5))
      }
    } else {
      if (draw_separators) {
        for (i in 1:(ncols - 1)) {
          lines(c(i, i) + 0.5, c(0.6, 1.4))
        }
      }
      if (draw_separators || is.null(col_inf)) {
        lines(c(0.5, 0.5), c(0.6, 1.4))
      }
      if (draw_separators || is.null(col_sup)) {
        lines(c(ncols + 0.5, ncols + 0.5), c(0.6, 1.4))
      }
    }
    # Put the ticks
    plot_range <- length(brks) - 1
    var_range <- tail(brks, 1) - head(brks, 1)
    extra_labels_at <- ((extra_labels - head(brks, 1)) / var_range) * plot_range + 0.5
    at <- seq(1, length(brks), subsampleg)
    labels <- brks[at]
    # Getting rid of next-to-last tick if too close to last one
    if (remove_final_tick) {
      at <- at[-length(at)]
      labels <- labels[-length(labels)]
    }
    labels <- signif(labels, label_digits)
    if (added_final_tick) {
      extra_labels[length(extra_labels)] <- signif(tail(extra_labels, 1), label_digits)
    }
    at <- at - 0.5
    at <- c(at, extra_labels_at)
    labels <- c(labels, extra_labels)
    tick_reorder <- sort(at, index.return = TRUE)
    at <- tick_reorder$x
    if (draw_labels) {
      labels <- labels[tick_reorder$ix]
    } else {
      labels <- FALSE
    }
    axis(d, at = at, tick = draw_ticks, labels = labels, cex.axis = cex_labels, tcl = cex_ticks)
    par(saved_pars)
  }
  invisible(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup))
}