########################################
# drawOpenKey v0.2
########################################
# drawOpenKey is a modification of:
# draw.colorkey
#
# original code from lattice, reference:
# Deepayan Sarkar (2010). lattice: Lattice Graphics.
# R package version 0.18-5.
# http://r-forge.r-project.org/projects/lattice/
#
# additional code by Karl Ropkins, allows:
# some crude header and footer labelling
# text formatting by openair::quickText
# addition plot style and layout control
########################################

########################################
# The help, advice and extreme patience
# of Deepayan Sarkar are also gratefully
# acknowledged
########################################



#' Scale key handling for openair
#'
#' General function for producing scale keys for other openair functions.  The
#' function is a crude modification of the draw.colorkey function developed by
#' Deepayan Sarkar as part of the lattice package, and allows additional key
#' labelling to added, and provides some additional control of the appearance
#' and scaling.
#'
#' The \code{drawOpenKey} function produces scale keys for other openair
#' functions.
#'
#' Most \code{drawOpenKey} options are identical to those of
#' \code{lattice::draw.colorkey}.  For example, scale key size and position
#' are controlled via \code{height}, \code{width} and \code{space}. Likewise,
#' the axis labelling can be set in and formatted by \code{labels}. See
#' \code{\link{draw.colorkey}} for further details.
#'
#' Additional scale labelling may be added above and below the scale using
#' \code{header} and \code{footer} options within \code{key}. As in other
#' \code{openair} functions, automatic text formatting can be enabled via
#' \code{auto.key}.
#'
#' (Note: Currently, the formatting of \code{header} and \code{footer} text
#' are fixed to the same style as \code{labels} (the scale axis) and cannot be
#' defined locally.)
#'
#' The relationship between \code{header}, \code{footer} and the scale key
#' itself can be controlled using \code{fit} options. These can be set in
#' \code{key$fit} to apply uniform control or individually in
#' \code{key$header$fit} and/or \code{key$footer$fit} to control locally.
#'
#' The appearance of the scale can be controlled using \code{plot.style}.
#'
#' @param key List defining the scale key structure to be produced. Most
#'   options are identical to original \code{draw.colorkey} function.
#'
#' Original \code{draw.colorkey} options:
#'
#' \code{space} location of the scale key ("left", "right", "top" or
#'   "bottom").  Defaults to "right".
#'
#' \code{col} vector of colours, used in scale key.
#'
#' \code{at} numeric vector specifying where the colors change. Must be of
#'   length 1 more than the col vector.
#'
#' \code{labels} a character vector for labelling the at values, or more
#'   commonly, a list describing characteristics of the labels. This list may
#'   include components \code{labels}, \code{at}, \code{cex}, \code{col},
#'   \code{rot}, \code{font}, \code{fontface} and \code{fontfamily}.
#'
#' \code{tick.number} approximate number of ticks.
#'
#' \code{width} width of the key.
#'
#' \code{height} height of key.
#'
#' Note: \code{width} and \code{height} refer to the key dimensions.
#'   \code{height} is the length of the key along the plot axis it is
#'   positioned against, and \code{width} is the length perpendicular to that.
#'
#' Additional options include:
#'
#' \code{header} a character vector of extra text to be added above the key,
#'   or a list describing some characteristics of the \code{header}. This list
#'   may include components \code{header}, the character vector of header
#'   labels, \code{tweaks}, a list of local controls, e.g. 'gap' and 'balance'
#'   for spacing relative to scale and footer, respectively, \code{auto.text},
#'   \code{TRUE/FALSE} option to apply \code{quickText}, and \code{slot}, a
#'   numeric vector setting the size of the text boxes \code{header} text is
#'   placed in.
#'
#' \code{footer} as in \code{header} but for labels below the scale key.
#'
#' Notes: \code{header} and \code{footer} formatting can not be set locally,
#'   but instead are matched to those set in \code{labels}. \code{drawOpenKey}
#'   allows for up to six additional labels (three above and three below scale
#'   key). Any additional text is ignored.
#'
#' \code{tweak, auto.text, slot} as in \code{header} and \code{footer} but
#'   sets all options uniformly. This also overwrites anything in
#'   \code{header} and/or \code{footer}.
#'
#' \code{fit} the fit method to be applied to the header, scale key and footer
#'   when placing the scale key left or right of the plot. Options include:
#'   'all', 'soft' and 'scale'.  The default 'all' fits header, key and footer
#'   into \code{height} range. The alternative 'scale' fits only the key
#'   within \code{height}. (This means that keys keep the same proportions
#'   relative to the main plot regardless of positioning but that header and
#'   footer may exceed plot dimensions if \code{height} and/or \code{slots}
#'   are too large.
#'
#' \code{plot.style} a character vector of key plotting style instructions:
#'   Options currently include: 'paddle', 'ticks' and 'border'. 'paddle'
#'   applies the incremental paddle layout used by \code{winRose}. 'ticks'
#'   places ticks between the labels scale key. 'border' places a border about
#'   the scale key. Any combination of these may be used but if none set,
#'   scale key defaults to \code{c("ticks", "border")} for most plotting
#'   operations or \code{c("paddle")} for \code{windRose}.
#'

#' @param draw Option to return the key object or plot it directly.  The
#'   default, FALSE, should always be used within openair calls.
#' @param vp View port to be used when plotting key. The default, NULL, should
#'   always be used within openair calls.
#'
#' (Note: \code{drawOpenKey} is a crude modification of
#'   \code{lattice::draw.colorkey}, that provides labelling options for
#'   \code{openair} plot scale keys. Some aspects of the function are in
#'   development and may to subject to change. Therefore, it is recommended
#'   that you use parent \code{openair} function controls, e.g.
#'   \code{key.position}, \code{key.header}, \code{key.footer} options, where
#'   possible.  \code{drawOpenKey} may obviously be used in other plots but it
#'   is recommended that \code{draw.colorkey} itself be used wherever this
#'   type of additional scale labelling is not required.)
#' @export
#' @return The function is a modification of \code{lattice::draw.colorkey} and
#'   returns a scale key using a similar mechanism to that used in in the
#'   original function as developed by Deepayan Sarkar.
#' @note We gratefully acknowledge the considerable help and advice of
#'   Deepayan Sarkar.
#' @author \code{draw.colorkey} is part of the \code{lattice} package,
#'   developed by Deepayan Sarkar.
#'
#' Additional modifications by Karl Ropkins.
#' @seealso Functions using \code{drawOpenKey} currently include
#'   \code{\link{windRose}}, \code{\link{pollutionRose}}.
#'
#' For details of the original function, see \code{\link{draw.colorkey}}
#' @references Deepayan Sarkar (2010). lattice: Lattice Graphics. R package
#'   version 0.18-5.  http://r-forge.r-project.org/projects/lattice/
#' @examples
#'
#'
#' ##########
#' #example 1
#' ##########
#'
#' #paddle style scale key used by windRose
#'
#' windRose(mydata,)
#'
#' #adding text and changing style and position via key
#'
#' #note:
#' #some simple key control also possible directly
#' #For example, below does same as
#' #windRose(mydata, key.position="right")
#'
#' windRose(mydata,
#'    key =list(space="right")
#' )
#'
#' #however:
#' #more detailed control possible working with
#' #key and drawOpenKey. For example,
#'
#' windRose(mydata,
#'    key = list(header="Title", footer="wind speed",
#'               plot.style = c("ticks", "border"),
#'               fit = "all", height = 1,
#'               space = "top")
#' )
#'
#'
drawOpenKey <- function(key, draw = FALSE, vp = NULL) {

  ################
  # quick end if key obviously not right
  ################
  if (!is.list(key)) {
    stop(
      "In drawOpenKey(...) key must be a list",
      call. = FALSE
    )
  }

  ################
  # special case
  # windRose colour key
  ################
  if (is.null(key$at)) {
    if (is.null(key$labels)) {
      stop(
        "In drawOpenKey(...) neither 'at' nor 'labels' in key",
        "\n\tplease suppied at least one",
        call. = FALSE
      )
    } else {
      if (is.list(key$labels)) {
        if (is.null(key$labels$labels)) {
          stop(
            "In drawOpenKey(...) unable to recover missing 'at' in key",
            "\n\tplease check 'labels' structure or add 'at'",
            call. = FALSE
          )
        }
        key$at <- 0:length(key$labels$labels)
        if (is.null(key$labels$at)) {
          key$labels$at <- 1:length(key$labels$labels) - 0.5
        }
      } else {
        key$at <- 0:length(key$labels)
        key$labels <- list(
          labels = key$labels,
          at = 1:length(key$labels) - 0.5
        )
      }
    }
  }

  ################
  # process key
  # modification of sk
  ################
  process.key <- function(col = regions$col, alpha = regions$alpha,
                          at, tick.number = 7, width = 2, height = 1, space = "right",
                          plot.style = c("ticks", "border"),
                          ...) {
    regions <- trellis.par.get("regions")
    list(
      col = col, alpha = alpha, at = at, tick.number = tick.number,
      width = width, height = height, space = space,
      plot.style = plot.style,
      ...
    )
  }
  axis.line <- trellis.par.get("axis.line")
  axis.text <- trellis.par.get("axis.text")
  key <- do.call("process.key", key)

  ###############
  # test space
  # otherwise drops without creating key.gf
  # COULD default to one?
  ###############
  temp <- c("right", "left", "top", "bottom")
  if (!key$space %in% temp) {
    stop(
      " In drawOpenKey(...):", "\n\tkey.position (space) argument in key not recognised",
      "\n\tplease use one of:\n\t\"", paste(
        temp,
        sep = "", collapse = "\", \""
      ), "\"",
      call. = FALSE
    )
  }

  ###############
  # original sk key handling
  # with
  # modified error messaging
  ###############
  check.overlap <- TRUE
  key$at <- sort(key$at)
  numcol <- length(key$at) - 1
  key$col <- level.colors(x = seq_len(numcol) - 0.5, at = seq_len(numcol +
    1) - 1, col.regions = key$col, colors = TRUE)
  atrange <- range(key$at, finite = TRUE)
  scat <- as.numeric(key$at)
  reccentre <- (scat[-1] + scat[-length(scat)]) / 2
  recdim <- diff(scat)
  cex <- axis.text$cex
  col <- axis.text$col
  font <- axis.text$font
  fontfamily <- axis.text$fontfamily
  fontface <- axis.text$fontface
  rot <- 0
  if (is.null(key$lab)) {
    at <- pretty(atrange, key$tick.number)
    at <- at[at >= atrange[1] & at <= atrange[2]]
    labels <- format(at, trim = TRUE)
  } else if ((is.character(key$lab) | is.expression(key$lab) | is.numeric(key$lab))
  && length(key$lab) == length(key$at)) {
    check.overlap <- FALSE
    at <- key$at
    labels <- key$lab
  } else if (is.list(key$lab)) {
    at <- if (!is.null(key$lab$at)) {
      key$lab$at
    } else {
      pretty(atrange, key$tick.number)
    }
    at <- at[at >= atrange[1] & at <= atrange[2]]
    labels <- if (!is.null(key$lab$lab)) {
      check.overlap <- FALSE
      key$lab$lab
    } else {
      format(at, trim = TRUE)
    }
    if (!is.null(key$lab$cex)) {
      cex <- key$lab$cex
    }
    if (!is.null(key$lab$col)) {
      col <- key$lab$col
    }
    if (!is.null(key$lab$font)) {
      font <- key$lab$font
    }
    if (!is.null(key$lab$fontface)) {
      fontface <- key$lab$fontface
    }
    if (!is.null(key$lab$fontfamily)) {
      fontfamily <- key$lab$fontfamily
    }
    if (!is.null(key$lab$rot)) {
      rot <- key$lab$rot
    }
  } else {
    stop(
      "In drawOpenKey(...) unexpected labels structure in key",
      "\n\tplease check 'labels' structure",
      "\n\tor see 'labels' in ?drawOpenKey",
      call. = FALSE
    )
  }
  labscat <- at
  rot <- 0

  #############
  # header set up
  #############
  if (is.null(key$hea)) {
    key$hea <- list(header = "")
  }
  if (is.character(key$hea) | is.numeric(key$hea) | is.expression(key$hea)) {
    key$hea <- list(header = key$hea)
  }
  if (is.list(key$hea)) {
    h.text <- if (is.null(key$hea$hea)) "" else key$hea$hea
    h.tweaks <- if (is.null(key$hea$twe)) c("gap", "balance") else key$hea$twe
    h.auto.text <- if (is.null(key$hea$auto.text)) TRUE else key$hea$auto.text
    h.slot <- if (is.null(key$hea$slot)) 0.05 else key$hea$slot
  } else {
    stop(
      "In drawOpenKey(...) unexpected header structure in key",
      "\n\tplease check 'header' structure",
      "\n\tor see 'header' in ?drawOpenKey",
      call. = FALSE
    )
  }

  ############
  # footer setup
  ############
  if (is.null(key$foo)) {
    key$foo <- list(footer = "")
  }
  if (is.character(key$foo) | is.numeric(key$foo) | is.expression(key$foo)) {
    key$foo <- list(footer = key$foo)
  }
  if (is.list(key$foo)) {
    f.text <- if (is.null(key$foo$foo)) "" else key$foo$foo
    f.tweaks <- if (is.null(key$foo$twe)) c("gap", "balance") else key$foo$twe
    f.auto.text <- if (is.null(key$foo$auto.text)) TRUE else key$foo$auto.text
    f.slot <- if (is.null(key$foo$slot)) 0.05 else key$foo$slot
  } else {
    stop(
      "In drawOpenKey(...) unexpected footer structure in key",
      "\n\tplease check 'footer' structure",
      "\n\tor see 'footer' in ?drawOpenKey",
      call. = FALSE
    )
  }

  #################
  # higher level handling
  # auto.text, slot, tweak,
  #################
  if (!is.null(key$auto.text)) {
    if (is.logical(key$auto.text)) {
      h.auto.text <- key$auto.text
      f.auto.text <- key$auto.text
    }
  }
  if (!is.null(key$slot)) {
    if (is.numeric(key$slot)) {
      h.slot <- key$slot
      f.slot <- key$slot
    }
  }
  if (!is.null(key$twe)) {
    if (is.vector(key$twe)) {
      h.tweaks <- key$twe
      f.tweaks <- key$twe
    }
  }

  ###############
  # size text boxes, balance and gap
  # for
  # top and bottom only
  ###############
  h.text <- if (length(h.text) < 3) {
    c(rep("", 3 - length(h.text)), h.text)
  } else {
    h.text[1:3]
  }
  h.slots <- ifelse(as.character(h.text) != "", h.slot, 0)
  f.text <- c(f.text, rep("", 3))[1:3]
  f.slots <- ifelse(as.character(f.text) != "", f.slot, 0)
  if (sum(h.slots) > sum(f.slots) & "balance" %in% f.tweaks) {
    f.slots[3] <- f.slots[3] + sum(h.slots) - sum(f.slots)
  }
  if (sum(f.slots) > sum(h.slots) & "balance" %in% h.tweaks) {
    h.slots[1] <- h.slots[1] + sum(f.slots) - sum(h.slots)
  }
  g.slots <- c(
    if ("gap" %in% h.tweaks & sum(c(h.slots, f.slots)) > 0) h.slot else 0,
    if ("gap" %in% f.tweaks & sum(c(h.slots, f.slots)) > 0) f.slot else 0
  )

  #############
  # scale fit
  # scale, soft and all
  # default all
  #############
  s.slot <- 1 - sum(c(h.slots, f.slots, g.slots))
  s.offsets <- c(0, 0)
  if (!is.null(key$fit)) {
    if (is.character(key$fit)) {
      if (key$fit == "soft") {
        s.slot <- 1 - (sum(c(h.slots, f.slots, g.slots)) / 2)
      }
      if (key$fit == "scale") {
        s.slot <- 1
        s.offsets <- c(
          sum(c(h.slots, g.slots[1])),
          sum(c(f.slots, g.slots[2]))
        )
      }
    } else {
      stop(
        "In drawOpenKey(...) unexpected fit structure in key",
        "\n\tplease check 'fit' structure",
        "\n\tor see 'fit' in ?drawOpenKey",
        call. = FALSE
      )
    }
  }

  ############
  # paddle style
  # recwd rescaling
  #############
  recwd <- if ("paddle" %in% key$plot.style) {
    recwd <- seq(0.2, 1, length.out = length(key$at) - 1)
  } else {
    recwd <- rep(1, length(key$at) - 1)
  }

  #####################
  # right scale
  # size checks text see sac struff
  # positions
  # adds ticks and borders if requested
  #####################
  if (key$space == "right") {
    h.text <- if (is.character(h.text)) {
      lapply(h.text, function(x) quickText(x, h.auto.text))
    } else {
      list(h.text[1], h.text[2], h.text[3])
    }
    f.text <- if (is.character(f.text)) {
      lapply(f.text, function(x) quickText(x, h.auto.text))
    } else {
      list(f.text[1], f.text[2], f.text[3])
    }
    # sac stuff handles spacing needed for headers, scale and footers
    sac.text <- c(
      labels, f.text[[1]], f.text[[2]], f.text[[3]],
      h.text[[1]], h.text[[2]], h.text[[3]]
    )
    SacGrob <- textGrob(
      label = sac.text, x = rep(0, length(sac.text)),
      y = at, vp = viewport(yscale = atrange), default.units = "native",
      check.overlap = check.overlap, just = if (rot == -90) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    heights.x <- c(
      ((1 - key$height) / 2) - (key$height * s.offsets[1]),
      key$height * h.slots[1], key$height * h.slots[2], key$height * h.slots[3],
      key$height * g.slots[1], (key$height * s.slot), key$height * g.slots[2],
      key$height * f.slots[1], key$height * f.slots[2], key$height * f.slots[3],
      ((1 - key$height) / 2) - (key$height * s.offsets[2])
    )
    heights.units <- rep("null", 11)
    temp <- if ("ticks" %in% key$plot.style) 0.6 else 0.3
    widths.x <- c(0.6 * key$width, temp, 1)
    widths.units <- c("lines", "lines", "grobwidth")
    widths.data <- list(NULL, NULL, SacGrob)
    key.layout <- grid.layout(nrow = 11, ncol = 3, heights = unit(
      heights.x,
      heights.units
    ), widths = unit(
      widths.x, widths.units,
      data = widths.data
    ), respect = TRUE)
    key.gf <- frameGrob(layout = key.layout, vp = vp)
    add.header.footer <- function(key.gf, text, key.row, key.col) {
      keyGrob <- textGrob(
        label = text, x = c(0),
        y = c(0.5), vp = viewport(yscale = c(0, 1)), default.units = "native",
        check.overlap = check.overlap, just = if (rot == -90) {
          c("center", "bottom")
        } else {
          c("left", "center")
        }, rot = rot, gp = gpar(
          col = col,
          cex = cex, fontfamily = fontfamily, fontface = chooseFace(
            fontface,
            font
          )
        )
      )
      placeGrob(key.gf, keyGrob, row = key.row, col = key.col)
    }
    key.gf <- add.header.footer(key.gf, h.text[[1]], 2, 3)
    key.gf <- add.header.footer(key.gf, h.text[[2]], 3, 3)
    key.gf <- add.header.footer(key.gf, h.text[[3]], 4, 3)
    key.gf <- add.header.footer(key.gf, f.text[[1]], 8, 3)
    key.gf <- add.header.footer(key.gf, f.text[[2]], 9, 3)
    key.gf <- add.header.footer(key.gf, f.text[[3]], 10, 3)
    key.gf <- placeGrob(key.gf, textGrob(
      label = labels, x = rep(0, length(at)),
      y = at, vp = viewport(yscale = atrange), default.units = "native",
      check.overlap = check.overlap, just = if (rot == -90) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    ), row = 6, col = 3)
    key.gf <- placeGrob(key.gf, rectGrob(
      x = rep(0.5, length(reccentre)),
      y = reccentre, default.units = "native", vp = viewport(yscale = atrange),
      height = recdim, width = recwd, gp = gpar(
        fill = key$col, col = "transparent",
        alpha = key$alpha
      )
    ), row = 6, col = 1)
    if ("border" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, rectGrob(gp = gpar(
        col = axis.line$col,
        lty = axis.line$lty, lwd = axis.line$lwd, alpha = axis.line$alpha,
        fill = "transparent"
      )), row = 6, col = 1)
    }
    if ("ticks" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, segmentsGrob(
        x0 = rep(
          0,
          length(labscat)
        ), y0 = labscat, x1 = rep(0.4, length(labscat)),
        y1 = labscat, vp = viewport(yscale = atrange), default.units = "native",
        gp = gpar(
          col = axis.line$col, lty = axis.line$lty,
          lwd = axis.line$lwd
        )
      ), row = 6, col = 2)
    }
  }

  #####################
  # left scale
  # size checks text see sac struff
  # positions
  # adds ticks and borders if requested
  #####################
  else if (key$space == "left") {
    h.text <- if (is.character(h.text)) {
      lapply(h.text, function(x) quickText(x, h.auto.text))
    } else {
      list(h.text[1], h.text[2], h.text[3])
    }
    f.text <- if (is.character(f.text)) {
      lapply(f.text, function(x) quickText(x, h.auto.text))
    } else {
      list(f.text[1], f.text[2], f.text[3])
    }
    # sac stuff handles spacing needed for headers, scale and footers
    sac.text <- c(
      labels, f.text[[1]], f.text[[2]], f.text[[3]],
      h.text[[1]], h.text[[2]], h.text[[3]]
    )
    SacGrob <- textGrob(
      label = sac.text, x = rep(0, length(sac.text)),
      y = at, vp = viewport(yscale = atrange), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 90) {
        c("center", "bottom")
      } else {
        c("right", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    heights.x <- c(
      ((1 - key$height) / 2) - (key$height * s.offsets[1]),
      key$height * h.slots[1], key$height * h.slots[2], key$height * h.slots[3],
      key$height * g.slots[1], (key$height * s.slot), key$height * g.slots[2],
      key$height * f.slots[1], key$height * f.slots[2], key$height * f.slots[3],
      ((1 - key$height) / 2) - (key$height * s.offsets[2])
    )
    heights.units <- rep("null", 11)
    temp <- if ("ticks" %in% key$plot.style) 0.6 else 0.3
    widths.x <- c(1, temp, 0.6 * key$width)
    widths.units <- c("grobwidth", "lines", "lines")
    widths.data <- list(SacGrob, NULL, NULL)
    key.layout <- grid.layout(nrow = 11, ncol = 3, heights = unit(
      heights.x,
      heights.units
    ), widths = unit(
      widths.x, widths.units,
      data = widths.data
    ), respect = TRUE)
    key.gf <- frameGrob(layout = key.layout, vp = vp)
    add.header.footer <- function(key.gf, text, key.row, key.col) {
      keyGrob <- textGrob(
        label = text, x = c(1),
        y = c(0.5), vp = viewport(yscale = c(0, 1)), default.units = "native",
        check.overlap = check.overlap, just = if (rot == 90) {
          c("center", "bottom")
        } else {
          c("right", "center")
        }, rot = rot, gp = gpar(
          col = col,
          cex = cex, fontfamily = fontfamily, fontface = chooseFace(
            fontface,
            font
          )
        )
      )
      placeGrob(key.gf, keyGrob, row = key.row, col = key.col)
    }
    key.gf <- add.header.footer(key.gf, h.text[[1]], 2, 1)
    key.gf <- add.header.footer(key.gf, h.text[[2]], 3, 1)
    key.gf <- add.header.footer(key.gf, h.text[[3]], 4, 1)
    key.gf <- add.header.footer(key.gf, f.text[[1]], 8, 1)
    key.gf <- add.header.footer(key.gf, f.text[[2]], 9, 1)
    key.gf <- add.header.footer(key.gf, f.text[[3]], 10, 1)
    key.gf <- placeGrob(
      key.gf,
      textGrob(
        label = labels, x = rep(1, length(at)),
        y = at, vp = viewport(yscale = atrange), default.units = "native",
        check.overlap = check.overlap, just = if (rot == 90) {
          c("center", "bottom")
        } else {
          c("right", "center")
        }, rot = rot, gp = gpar(
          col = col,
          cex = cex, fontfamily = fontfamily, fontface = chooseFace(
            fontface,
            font
          )
        )
      )
      ,
      row = 6, col = 1
    )
    key.gf <- placeGrob(key.gf, rectGrob(
      x = rep(0.5, length(reccentre)),
      y = reccentre, default.units = "native", vp = viewport(yscale = atrange),
      height = recdim, width = recwd, gp = gpar(
        fill = key$col, col = "transparent",
        alpha = key$alpha
      )
    ), row = 6, col = 3)
    if ("border" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, rectGrob(gp = gpar(
        col = axis.line$col,
        lty = axis.line$lty, lwd = axis.line$lwd, alpha = axis.line$alpha,
        fill = "transparent"
      )), row = 6, col = 3)
    }
    if ("ticks" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, segmentsGrob(
        x0 = rep(
          0.5,
          length(labscat)
        ), y0 = labscat, x1 = rep(1, length(labscat)),
        y1 = labscat, vp = viewport(yscale = atrange), default.units = "native",
        gp = gpar(
          col = axis.line$col, lty = axis.line$lty,
          lwd = axis.line$lwd
        )
      ), row = 6, col = 2)
    }
  }

  #####################
  # top scale
  # positions
  # adds ticks and borders if requested
  #####################
  else if (key$space == "top") {
    f.text <- f.text[as.character(f.text) != ""]
    f.text <- if (is.character(f.text)) {
      quickText(paste(f.text, collapse = "  "), f.auto.text)
    } else {
      as.expression(parse(text = paste(f.text, collapse = "~~")))
    }
    h.text <- h.text[as.character(h.text) != ""]
    h.text <- if (is.character(h.text)) {
      quickText(paste(h.text, collapse = "  "), f.auto.text)
    } else {
      as.expression(parse(text = paste(h.text, collapse = "~~")))
    }
    labelsGrob <- textGrob(
      label = labels, y = rep(0, length(at)),
      x = at, vp = viewport(xscale = atrange), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 0) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    keyGrob <- textGrob(
      label = f.text, y = c(0),
      x = c(0.5), vp = viewport(xscale = c(0, 1)), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 0) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    keyGrob2 <- textGrob(
      label = h.text, y = c(0),
      x = c(0.5), vp = viewport(xscale = c(0, 1)), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 0) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    widths.x <- c((1 - key$height) / 2, key$height, (1 - key$height) / 2)
    widths.units <- rep("null", 3)
    temp <- c(0, 0, 0, 0.3)
    if (sum(f.slots[1:2]) > 0 & sum(h.slots[2:3]) == 0) {
      temp[1:3] <- c(0, 1, 1.5)
    }
    if (sum(f.slots[1:2]) == 0 & sum(h.slots[2:3]) > 0) {
      temp[1:3] <- c(1, 0, 1.5)
    }
    if (sum(f.slots[1:2]) > 0 & sum(h.slots[2:3]) > 0) {
      temp[1:3] <- c(1, 1.5, 1.5)
    }
    if (sum(f.slots[1:2]) == 0 & sum(h.slots[2:3]) == 0) {
      temp[1:3] <- c(1, 1, 1)
    }
    if ("ticks" %in% key$plot.style) {
      temp[4] <- 0.6
    }
    heights.x <- c(temp[1], temp[2], temp[3], temp[4], 0.6 * key$width)
    heights.units <- c("grobheight", "grobheight", "grobheight", "lines", "lines")
    heights.data <- list(keyGrob2, keyGrob, labelsGrob, NULL, NULL)
    key.layout <- grid.layout(nrow = 5, ncol = 3, heights = unit(
      heights.x,
      heights.units,
      data = heights.data
    ), widths = unit(
      widths.x,
      widths.units
    ), respect = TRUE)
    key.gf <- frameGrob(layout = key.layout, vp = vp)
    key.gf <- placeGrob(key.gf, rectGrob(
      y = rep(0.5, length(reccentre)),
      x = reccentre, default.units = "native", vp = viewport(xscale = atrange),
      width = recdim, height = recwd, gp = gpar(
        fill = key$col, col = "transparent",
        alpha = key$alpha
      )
    ), row = 5, col = 2)
    if ("border" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, rectGrob(gp = gpar(
        col = axis.line$col,
        lty = axis.line$lty, lwd = axis.line$lwd, alpha = axis.line$alpha,
        fill = "transparent"
      )), row = 5, col = 2)
    }
    if ("ticks" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, segmentsGrob(
        y0 = rep(
          0,
          length(labscat)
        ), x0 = labscat, y1 = rep(0.4, length(labscat)),
        x1 = labscat, vp = viewport(xscale = atrange), default.units = "native",
        gp = gpar(
          col = axis.line$col, lty = axis.line$lty,
          lwd = axis.line$lwd
        )
      ), row = 4, col = 2)
    }
    key.gf <- placeGrob(key.gf, labelsGrob, row = 3, col = 2)
    key.gf <- placeGrob(key.gf, keyGrob, row = 2, col = 2)
    key.gf <- placeGrob(key.gf, keyGrob2, row = 1, col = 2)
  }

  #####################
  # bottom scale
  # positions
  # adds ticks and borders if requested
  #####################
  else if (key$space == "bottom") {
    f.text <- f.text[as.character(f.text) != ""]
    f.text <- if (is.character(f.text)) {
      quickText(paste(f.text, collapse = "  "), f.auto.text)
    } else {
      as.expression(parse(text = paste(f.text, collapse = "~~")))
    }
    h.text <- h.text[as.character(h.text) != ""]
    h.text <- if (is.character(h.text)) {
      quickText(paste(h.text, collapse = "  "), f.auto.text)
    } else {
      as.expression(parse(text = paste(h.text, collapse = "~~")))
    }
    temp <- c(0.3, 1, 0, 0)
    if (sum(f.slots[1:2]) > 0 & sum(h.slots[2:3]) == 0) {
      temp[2:4] <- c(1, 1, 1.5)
    }
    if (sum(f.slots[1:2]) == 0 & sum(h.slots[2:3]) > 0) {
      temp[2:4] <- c(1, 1.5, 1)
    }
    if (sum(f.slots[1:2]) > 0 & sum(h.slots[2:3]) > 0) {
      temp[2:4] <- c(1, 1.5, 1.5)
    }
    if (sum(f.slots[1:2]) == 0 & sum(h.slots[2:3]) == 0) {
      temp[2:4] <- c(1, 1, 1)
    }
    if ("ticks" %in% key$plot.style) {
      temp[1] <- 0.6
    }
    labelsGrob <- textGrob(
      label = labels, y = rep(0, length(at)),
      x = at, vp = viewport(xscale = atrange), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 0) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    keyGrob <- textGrob(
      label = h.text, y = c(0),
      x = c(0.5), vp = viewport(xscale = c(0, 1)), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 0) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    keyGrob2 <- textGrob(
      label = f.text, y = c(0),
      x = c(0.5), vp = viewport(xscale = c(0, 1)), default.units = "native",
      check.overlap = check.overlap, just = if (rot == 0) {
        c("center", "bottom")
      } else {
        c("left", "center")
      }, rot = rot, gp = gpar(
        col = col,
        cex = cex, fontfamily = fontfamily, fontface = chooseFace(
          fontface,
          font
        )
      )
    )
    widths.x <- c((1 - key$height) / 2, key$height, (1 - key$height) / 2)
    widths.units <- rep("null", 3)
    heights.x <- c(0.6 * key$width, temp[1], temp[2], temp[3], temp[4])
    heights.units <- c("lines", "lines", "grobheight", "grobheight", "grobheight")
    heights.data <- list(NULL, NULL, labelsGrob, keyGrob, keyGrob2)
    key.layout <- grid.layout(nrow = 5, ncol = 3, heights = unit(
      heights.x,
      heights.units,
      data = heights.data
    ), widths = unit(
      widths.x,
      widths.units
    ), respect = TRUE)
    key.gf <- frameGrob(layout = key.layout, vp = vp)
    key.gf <- placeGrob(key.gf, rectGrob(
      y = rep(0.5, length(reccentre)),
      x = reccentre, default.units = "native", vp = viewport(xscale = atrange),
      width = recdim, height = recwd, gp = gpar(
        fill = key$col, col = "transparent",
        alpha = key$alpha
      )
    ), row = 1, col = 2)
    if ("ticks" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, segmentsGrob(
        y0 = rep(
          1,
          length(labscat)
        ), x0 = labscat, y1 = rep(0.6, length(labscat)),
        x1 = labscat, vp = viewport(xscale = atrange), default.units = "native",
        gp = gpar(
          col = axis.line$col, lty = axis.line$lty,
          lwd = axis.line$lwd
        )
      ), row = 2, col = 2)
    }
    if ("border" %in% key$plot.style) {
      key.gf <- placeGrob(frame = key.gf, rectGrob(gp = gpar(
        col = axis.line$col,
        lty = axis.line$lty, lwd = axis.line$lwd, alpha = axis.line$alpha,
        fill = "transparent"
      )), row = 1, col = 2)
    }
    key.gf <- placeGrob(key.gf, labelsGrob, row = 3, col = 2)
    key.gf <- placeGrob(key.gf, keyGrob, row = 4, col = 2)
    key.gf <- placeGrob(key.gf, keyGrob2, row = 5, col = 2)
  }

  ##############
  # outputs
  ##############
  if (draw) {
    grid.draw(key.gf)
  }
  key.gf
}
