R/utils-misc.R

In trevorld/piecepack: Board Game Graphics

#' Miscellaneous `piecepackr` utility functions
#'
#' `cleave()` converts a delimiter separated string into a vector.
#' `inch(x)` is equivalent to `grid::unit(x, "in")`.
#' `is_color_invisible()` tells whether the color is transparent (and hence need not be drawn).
#' @examples
#'  cleave("0.5,0.2,0.4,0.5", float=TRUE)
#'  cleave("black,darkred,#050EAA,,", color=TRUE)
#'
#'  is_color_invisible("transparent")
#'  is_color_invisible(NA)
#'  is_color_invisible("blue")
#'  is_color_invisible("#05AE9C")
#'
#'  if (requireNamespace("grid", quietly = TRUE)) {
#'      identical(inch(1), grid::unit(1, "inch"))
#'  }
#'
#' @name pp_utils
NULL

#' @param col Color
#' @rdname pp_utils
#' @export
is_color_invisible <- function(col) {
    as.logical(grDevices::col2rgb(col, alpha=TRUE)[4, ] == 0)
}

#' @rdname pp_utils
#' @param inches Number representing number of inches
#' @export
inch <- function(inches) unit(inches, "in")

#' @rdname pp_utils
#' @param s String to convert
#' @param sep Delimiter (defaults to ",")
#' @param float If `TRUE` cast to numeric
#' @param color if `TRUE` convert empty strings to `"transparent"`
#' @export
cleave <- function(s, sep=",", float=FALSE, color=FALSE) {
    vec <- str_split(s, sep)
    if (length(vec))
        vec <- vec[[1]]
    if (float) {
        as.numeric(vec)
    } else if (color) {
        gsub("^$", "transparent", vec)
    } else {
        vec
    }
}

cleave2 <- function(s, sep=",", ...) {
    if (length(s) > 1)
        s <- paste(s, collapse=sep)
    cleave(s, sep, ...)
}
col_cleave <- function(s, sep=",") cleave2(s, sep, color=TRUE)
numeric_cleave <- function(s, sep=",") cleave2(s, sep, float=TRUE)

as_picture <- function(grob, width, height) {
    svg_file <- tempfile(fileext=".svg")
    on.exit(unlink(svg_file), add = TRUE)

    current_dev <- grDevices::dev.cur()
    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev), add = TRUE)
    grDevices::svg(svg_file, width=width, height=height, bg="transparent")
    grid.draw(grob)
    invisible(grDevices::dev.off())
    file2grob(svg_file)
}

#' @rdname pp_utils
#' @param file Filename of image
#' @param distort Logical value of whether one should preserve the aspect ratio
#'                or distort to fit the area it is drawn in
#' @export
file2grob <- function(file, distort=TRUE) {
    current_dev <- grDevices::dev.cur()
    if (current_dev > 1) on.exit(grDevices::dev.set(current_dev), add = TRUE)
    format <- tools::file_ext(file)
    if (format %in% c("svgz", "svg")) {
        picture <- grImport2::readPicture(file, warn=FALSE)
    } else if (format == "png") {
        picture <- grDevices::as.raster(png::readPNG(file))
    } else if (format %in% c("jpg", "jpeg")) {
        picture <- grDevices::as.raster(jpeg::readJPEG(file))
    } else {
        assert_suggested("magick")
        picture <- magick::image_read(file)
    }
    if (inherits(picture, "Picture")) {
        ppPictureGrob(picture, distort)
    } else { # grDevices::is.raster(picture) # nolint
        to_rasterGrob(picture, distort)
    }
}

to_rasterGrob <- function(obj, distort=TRUE) {
    if (distort) {
        rasterGrob(grDevices::as.raster(obj), height=unit(1, "npc"), width=unit(1, "npc"), name = "raster")
    } else {
        rasterGrob(grDevices::as.raster(obj), name = "raster")
    }
}

# adds support for a 'vp' viewport plus hiding grob details in `grid.ls()` (i.e. ``grid.revert()`` if "forced")
ppPictureGrob <- function(picture, distort = TRUE, ..., name = NULL, gp = gpar(), vp = NULL) {
    gTree(picture = picture, distort = distort, name = name, gp = gp, vp = vp, cl = "pp_picture")
}

#' @export
makeContent.pp_picture <- function(x) {
    grob <- grImport2::pictureGrob(x$picture, expansion=0, clip="off", distort=x$distort)
    setChildren(x, gList(grob))
}

assert_suggested <- function(package) {
    calling_fn <- deparse(sys.calls()[[sys.nframe()-1]])
    if (!requireNamespace(package, quietly = TRUE)) {
        msg <- c(sprintf("You need to install the suggested package %s to use %s.",
                         sQuote(package), sQuote(calling_fn)),
                 i = sprintf("Use %s.", sQuote(sprintf('install.packages("%s")', package))))
        abort(msg, class = "piecepackr_suggested_package")
    }
}

# base R's Cairo/Quartz devices as well as {ragg} / {svglite} / {vdiffr} devices
# should support Unicode without complaint
# Notably `pdf()` is a device that does not...
# Any other devices to add?
device_supports_unicode <- function() {
    device <- names(grDevices::dev.cur())
    unicode_devices <- c("agg_capture", "agg_jpeg", "agg_ppm", "agg_png", "agg_record", "agg_tiff", # {ragg}
                         "devSVG", "devSVG_vdiffr", # {svglite} / {vdiffr}
                         "quartz", "quartz_off_screen", # Quartz
                         "cairo_pdf", "cairo_ps", "svg", "X11cairo") # Cairo
    if (any(vapply(unicode_devices, function(x) grepl(paste0("^", x), device),
                   FUN.VALUE = logical(1L)))) {
        TRUE
    } else if (device %in% c("bmp", "jpeg", "png", "tiff")) {
        # on unix non-"cairo" type have different device names from "cairo" type
        # but on Windows can't distinguish between `type = "windows"` or `type = "cairo"`
        # Windows device doesn't support new patterns feature
        if (getRversion() >= "4.2.0") {
            "LinearGradient" %in% grDevices::dev.capabilities()$patterns
        } else {
            .Platform$OS.type == "unix"
        }
    } else {
        FALSE
    }
}


# From `{gridpattern}`
update_alpha_col <- function (color, alpha = NA_real_) {
    n <- max(lengths(list(color, alpha)))
    color <- rep_len(color, n)
    alpha <- rep_len(alpha, n)
    m <- grDevices::col2rgb(color, alpha = TRUE)/255
    m[4, ] <- ifelse(is.na(alpha), m[4, ], alpha)
    apply(m, 2, function(x) grDevices::rgb(x[1], x[2], x[3], x[4]))
}

# From `{oblicubes}`
cheap_darken <- function(color, amount) {
  mat <- col2rgb(color, alpha = TRUE)
  mat[1:3, ] <- mat[1:3, ] * (1 - amount)
  rgb(mat[1, ], mat[2, ], mat[3, ], mat[4, ], maxColorValue = 255)
}

as_fill_stroke_grob <- function(grob, fill, col = "black", lwd = 1.5) {
    if (has_fill_strokes()) {
        gp <- gpar(fill = fill, col = col, lwd = lwd)
        fillStrokeGrob(grob, gp = gp)
    } else {
        fs_inform()
        grob
    }
}

has_transformations <- function() {
    getRversion() >= '4.2.0' && isTRUE(dev.capabilities()$transformations)
}

has_fill_strokes <- function() {
    getRversion() >= '4.2.0' && isTRUE(dev.capabilities()$paths)
}

has_radial_gradients <- function() {
    getRversion() >= '4.1.0' &&
        isTRUE("RadialGradient" %in% dev.capabilities("patterns")$patterns)
}

at_inform <- function(fallback = "picture") {
    if(isFALSE(getOption("piecepackr.at.inform")))
        return(invisible(NULL))

    msg <- "Affine transformation support not detected in the active graphics device."
    if (fallback == "picture")
        msg <- paste(msg, "Falling back to rendering piece side with `grImport2::pictureGrob(..., distort=TRUE)`.")
    else
        msg <- paste(msg, "Falling back to rendering piece side with a `grid::polygonGrob()`.")
    if (getRversion() < '4.2.0') {
        msg <- c(msg,
                 i = paste("Current R is version `%s`", getRversion()),
                 i = "Affine transformation support requires R version 4.2 or greater.")
    } else {
        msg <- c(msg,
                 i = "`dev.capabilities()$transformations` is not `TRUE`.",
                 i = "Perhaps try one of the cairo devices like `png(..., type='cairo')` or `cairo_pdf()`.")
    }
    msg <- c(msg,
             i = "These messages can be disabled via `options(piecepackr.at.inform = FALSE)`.",
             i = 'These messages can be suppressed via `suppressMessages(expr, classes = "piecepackr_affine_transformation")`.')
    inform(msg, class = "piecepackr_affine_transformation")
}

fs_inform <- function() {
    if(isFALSE(getOption("piecepackr.fs.inform")))
        return(invisible(NULL))

    msg <- paste("Stroking and filling path support not detected in the active graphics device.",
                 "Falling back to rendering glyph with a `grid::textGrob()`.")
    if (getRversion() < '4.2.0') {
        msg <- c(msg,
                 i = paste("Current R is version `%s`", getRversion()),
                 i = "Stroking and filling path support requires R version 4.2 or greater.")
    } else {
        msg <- c(msg,
                 i = "`dev.capabilities()$paths` is not `TRUE`.",
                 i = "Perhaps try one of the cairo devices like `png(..., type='cairo')` or `cairo_pdf()`.")
    }
    msg <- c(msg,
             i = "These messages can be disabled via `options(piecepackr.fs.inform = FALSE)`.",
             i = 'These messages can be suppressed via `suppressMessages(expr, classes = "piecepackr_fill_stroke")`.')
    inform(msg, class = "piecepackr_fill_stroke")
}

rgr_inform <- function() {
    if(isFALSE(getOption("piecepackr.rgr.inform")))
        return(invisible(NULL))

    msg <- paste("Radial gradient support not detected in the active graphics device.",
                 "Falling back to rendering without a gradient.")
    if (getRversion() < '4.1.0') {
        msg <- c(msg,
                 i = paste("Current R is version `%s`", getRversion()),
                 i = "Radial gradient support requires R version 4.1 or greater.")
    } else {
        msg <- c(msg,
                 i = '`"RadialGradient" not in `dev.capabilities()$patterns`.',
                 i = "Perhaps try one of the cairo devices like `png(..., type='cairo')` or `cairo_pdf()`.")
    }
    msg <- c(msg,
             i = "These messages can be disabled via `options(piecepackr.rgr.inform = FALSE)`.",
             i = 'These messages can be suppressed via `suppressMessages(expr, classes = "piecepackr_radial_gradient")`.')
    inform(msg, class = "piecepackr_radial_gradient")
}