R/draw.colorkey.R

In kongdd/latticeGrob: Lattice Layers Functions

#' convertTri
#'
#' Setting 'open.lower' and 'open.upper' to non-zero makes colorkey end with
#' triangular extensions, indicating open-ended intervals. Set to non-zero by
#' default only if first/last intervals are unbounded (-Inf / +Inf).
#' (NOTE: default should perhaps be 0 for back-compatibility, but currently
#' these are simply not shown in the legend, so probably new behaviour is no
#' worse).
#' When non-zero, controls fraction of key$height to be used for triangles at ends.
#'
#' @param x height of triangle. If x in the range of `[0, 0.25]`, `height` will
#' be ignored.
#' @param inf boolean
#' @param height height of triangle
#'
#' @keywords internal
#' @export
convertTri <- function(x, inf = FALSE, height = 0.05)
{
    if (length(x) == 1) {
        if (is.numeric(x) && (x >= 0 && x <= 0.25)) {
            return(x)
        } else if (is.na(x)) {
            # return(0.05)
            return(height*inf)
        } else if (isTRUE(x)) {
            return(height)
        } else {
            return(0)
        }
    }
    warning("Invalid value of 'tri.upper/tri.lower' ignored.")
    0
}

#' fix non-equispaced colorkey
#'
#' @description Not processed if `key$equispaced` is not true.
#'
#' @param key A `colorkey` object (list), at least with the element of `at`.
#'
#' @example R/examples/ex-draw.colorkey_equispaced.R
#'
#' @keywords internal
#' @export
equispaced_colorkey <- function(key) {
    if (!isTRUE(key$equispaced)) return(key) # not processed

    at <- key$at
    is_equispaced <- length(unique(diff(at[is.finite(at)]))) == 1
    if (!is_equispaced) {
        key$at <- seq_along(at)
        labels_at <- seq_along(at)
        labels <- key$labeller(at)
        if (first(at) == -Inf) {
            key$at[1] <- -Inf
            labels_at <- labels_at[-1]
            labels <- labels[-1]
        }
        if (last(at) == Inf) {
            key$at[length(key$at)] <- Inf
            n <- length(labels_at)
            labels_at <- labels_at[-n]
            labels <- labels[-n]
        }
        names = setdiff(names(key$labels), c("at", "labels"))
        key$labels <- list(at = labels_at, labels = labels) %>%
            c(key$labels[names])
    }
    key
}

#' @keywords internal
#' @export
process.colorkey <- function(
    col = .regions$col,
    alpha = .regions$alpha,
    at,
    labels = NULL,
    labeller  = format,
    # format = "%f",
    pretty = FALSE, equispaced = TRUE,
    tick.number = 7,
    tck = 1,
    width = 2,
    height = 1,
    space = "right",
    raster = FALSE,
    interpolate = FALSE,
    tri.upper = NA,
    tri.lower = NA,
    title = NULL,
    unit = NULL,
    unit.adj = 0.3,
    cex.title = 1,
    axis.line = list(),
    axis.text = list(),
    key.padding = c(0, 0),
    rect = list(col = "black", lwd = 0.3), # rect of legend
    ...)
{
    .regions <- trellis.par.get("regions")
    key = c(mget(ls()), list(...)) # return all parameters
    # change labeller slightly
    key$labeller = function(x) {
        if (is.numeric(x)) labeller(x)  else x
    }
    key
}

# Note: there are two 'at'-s here, one is key$at, which specifies
# the breakpoints of the rectangles, and the other is key$lab$at
# (optional) which is the positions of the ticks. We will use the
# 'at' variable for the latter, 'atrange' for the range of the
# former, and key$at explicitly when needed

#' draw.colorkey
#' 
#' @inheritParams lattice::draw.colorkey
#' 
#' @example R/examples/ex-draw.colorkey.R
#' @import lattice
#' @export
draw.colorkey <- function(key, draw = FALSE, vp = NULL)
{
    # labeller = check_labeller(key$labeller)
    if (!is.list(key)) stop("key must be a list")
    key <- do.call(process.colorkey, key)
    key %<>% equispaced_colorkey()

    axis.line <- updateList(trellis.par.get("axis.line"), key$axis.line)
    axis.text <- updateList(trellis.par.get("axis.text"), key$axis.text)

    key$axis.line <- axis.line
    # layout_name <- ifelse(key$space %in% c("top", "bottom"), "layout.heights", "layout.widths")
    # colorkey.title.padding   <- lattice.options()[[layout_name]]$colorkey.title.padding
    # colorkey.title.padding$x <- colorkey.title.padding$x *
    #     trellis.par.get(layout_name)$colorkey.title.padding
    ## made FALSE later if labels explicitly specified
    check.overlap <- TRUE

    # Getting the locations/dimensions/centers of the rectangles
    key$at <- sort(key$at) ## should check if ordered
    numcol <- length(key$at)-1
    #     numcol.r <- length(key$col)
    #     key$col <-
    #         if (is.function(key$col)) key$col(numcol)
    #         else if (numcol.r <= numcol) rep(key$col, length.out = numcol)
    #         else key$col[floor(1+(1:numcol-1)*(numcol.r-1)/(numcol-1))]
    key$col <- level.colors(x = seq_len(numcol) - 0.5,
                     at = seq_len(numcol + 1) - 1,
                     col.regions = key$col,
                     colors = TRUE)

    ## FIXME: need to handle DateTime classes properly
    atrange <- range(key$at, finite = TRUE)
    scat <- as.numeric(key$at) ## problems otherwise with DateTime objects (?)

    if (key$raster && !isTRUE(all.equal(diff(range(diff(scat))), 0)))
        warning("'at' values are not equispaced; output may be wrong")

    ## recnum <- length(scat)-1
    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
    lineheight <- axis.text$lineheight
    rot <- 0

    # The following code assumes names key$lab and key$lab$lab (which
    # may have been used in user code), whereas documentation says
    # key$labels and key$labels$labels.  To make both work without
    # 'partial matching' warnings, we rename key$labels to key$lab
    # etc.
    if (!is.null(key[["labels"]])) {
        key[["lab"]] <- key[["labels"]]
        key[["labels"]] <- NULL
        if (is.list(key[["lab"]]) && !is.null(key[["lab"]][["labels"]])) {
            key[["lab"]][["lab"]] <- key[["lab"]][["labels"]]
            key[["lab"]][["labels"]] <- NULL
        }
    }

    lab = key$lab
    if (is.null(lab)) {
        if (key$pretty) {
            at <- lpretty(atrange, key$tick.number)
            at <- at[at >= atrange[1] & at <= atrange[2]]
        } else {
            # scat <- as.numeric(key$at) ## problems otherwise with DateTime objects (?)
            at <- as.numeric(key$at)
        }
        labels <- key$labeller(at) # , trim = TRUE
    } else if (is.characterOrExpression(lab) && length(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 lpretty(atrange, key$tick.number)
        at <- at[at >= atrange[1] & at <= atrange[2]]
        labels <- if (!is.null(key$lab$lab)) {
            check.overlap <- FALSE
            key$labeller(key$lab$lab)
        } else key$labeller(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$rot))  rot  <- key$lab$rot
        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$lineheight)) lineheight <- key$lab$lineheight
    } else stop("malformed colorkey")

    labscat <- at
    do.labels <- (length(labscat) > 0)

    ## Tri
    height.Tri <- key$height/numcol
    open.lower <- convertTri(key$tri.lower, scat[1] == -Inf, height = height.Tri)
    open.upper <- convertTri(key$tri.upper, scat[length(scat)] == Inf, height.Tri)
    key.rect   <- 1 - open.lower - open.upper

    # legend
    just = switch(key$space,
        right  = if (rot == -90) c("center", "bottom") else c("left", "center"),
        left   = if (rot == 90) c("center", "bottom") else c("right", "center"),
        top    = if (rot == 0) c("center","bottom") else c("left", "center"),
        bottom = if (rot == 0) c("center", "top") else c("right", "center"))

    # add unit label, 20190924
    if (!(is.null(key$unit) || key$unit == "")){
        nlab <- length(labels)
        delta <- labscat[nlab] - labscat[nlab - 1]
        labscat[nlab+1] <- labscat[nlab] + delta*key$unit.adj
        labels[nlab+1]  <- sprintf("%s", key$unit)
    }

    if (key$space %in% c('right', 'left')) {
        vp_label <- viewport(yscale = atrange)
        x_lab = rep(0, length(labscat))
        y_lab = labscat
    } else {
        vp_label <- viewport(xscale = atrange)
        y_lab = rep(0, length(labscat))
        x_lab = labscat
    }

    labelsGrob <-
        if (do.labels)
            textGrob(label = labels,
                     x = x_lab, y = y_lab, vp = vp_label,
                     default.units = "native",
                     check.overlap = check.overlap,
                     just = just, rot = rot,
                     name = trellis.grobname("labels", type="colorkey"),
                     gp = gpar(col = col, cex = cex,
                              fontfamily = fontfamily,
                              fontface = chooseFace(fontface, font),
                              lineheight = lineheight))
        else nullGrob()

    # layout
    grobwidth <- ifelse(key$space %in% c("top", "bottom"), "grobheight", "grobwidth")
    width_lab <- do.labels/length(labels)
    # For bottom and top, `lgd_width` is height
    widths.x    <- c(0.6*key$width, do.labels*(0.3 + key$tck*0.3), width_lab)
    widths_unit <- c("lines", "lines", grobwidth)
    widths_data <- list(NULL, NULL, labelsGrob)

    lgd_width   <- unit(widths.x, widths_unit, data = widths_data) # for 'right' and 'bottom'
    if (key$space %in% c('left', 'top')) lgd_width <- rev(lgd_width)

    heights.x <- c(0.5*(1 - key$height) + key$key.padding[1],
                 key$height*c(open.upper, key.rect, open.lower),
                 0.5*(1 - key$height) + key$key.padding[2])

    lgd_height <- unit(heights.x, rep("null", 5))

    if (key$space %in% c("right", "left")) {
        key.layout <- grid.layout(nrow = 5, ncol = 3, respect = TRUE,
                        heights = lgd_height,
                        widths = lgd_width)
    } else if (key$space %in% c("top", "bottom")) {
        key.layout <- grid.layout(nrow = 3, ncol = 5, respect = TRUE,
                        heights = lgd_width,
                        widths  = lgd_height)
    }

    key.gf <- key_gf(key, key.layout, vp, vp_label, reccentre, recdim, FALSE)
    key.gf <- key_triangle(key.gf, key, open.lower, open.upper)

    key.gf <- key_border(key.gf, key, open.lower, open.upper)
    key.gf <- key_label(key.gf, key, labscat, labelsGrob, vp_label)

    if (draw) {
        grid.newpage()
        grid.draw(key.gf)
    }
    key.gf
}

#' @export
#' @rdname draw.colorkey
draw.colorkey2 <- draw.colorkey

updateList <- function(x, val) {
    if (is.null(x)) x <- list()
    modifyList(x, val)
}

is.characterOrExpression <- function(x){
    is.character(x) || is.expression(x) || is.call(x) || is.symbol(x)
}

lpretty <- function(x, ...){
    eps <- 1e-10
    at <- pretty(x[is.finite(x)], ...)
    ifelse(abs(at-round(at, 3))<eps, round(at, 3), at)
}

chooseFace <- function(fontface = NULL, font = 1) {
    if (is.null(fontface)) font else fontface
}