R/standalone-guess_has_R4.1_features.R

In gridpattern: 'grid' Pattern Grobs

# ---
# repo: trevorld/gridpattern
# file: standalone-guess_has_R4.1_features.R
# last-updated: 2023-08-02
# license: https://spdx.org/licenses/MIT-0.html
# imports: [grDevices, utils]
# ---
#
# nocov start
#
# You may copy this source into your own R package
# by either using `usethis::use_standalone("trevorld/gridpattern", "standalone-guess_has_R4.1_features.R")`
# or simply copying this file into your `R` directory and adding `grDevices` and `utils` to the `Imports` of
# your `DESCRIPTION` file.

#' Guess whether "active" graphics device supports
#' the grid graphics features introduced in R v4.1.
#'
#' `guess_has_R4.1_features()` guesses whether "active" graphics device supports
#' the grid graphics features introduced in R v4.1.  If it guesses it does
#' it returns `TRUE` else `FALSE`.
#'
#' @param features Character vector of features to guess support for.
#'                 Will return `TRUE` only if guesses support for all requested features.\describe{
#'                 \item{"clippingPaths"}{Supports clipping path feature}
#'                 \item{"gradients"}{Supports (both linear and radial) gradient feature}
#'                 \item{"masks"}{Supports (alpha) mask feature}
#'                 \item{"patterns"}{Supports (tiling) pattern feature}
#'                 }
#' @seealso \url{https://www.stat.auckland.ac.nz/~paul/Reports/GraphicsEngine/definitions/definitions.html}
#'   for more info about the new grid graphics features introduced in R v4.1.
#' @return `TRUE` if we guess all `features` are supported else `FALSE`
#' @examples
#'   # If R version (weakly) greater than 4.1 should be TRUE
#'   pdf(tempfile(fileext = ".pdf"))
#'   print(guess_has_R4.1_features())
#'   invisible(dev.off())
#'
#'   # Should be FALSE
#'   postscript(tempfile(fileext = ".ps"))
#'   print(guess_has_R4.1_features())
#'   invisible(dev.off())
#'
#' @keywords internal
#' @noRd
guess_has_R4.1_features <- function(
	features = c("clippingPaths", "gradients", "masks", "patterns")
) {
	if (getRversion() < "4.1.0") {
		return(FALSE)
	}

	# In R 4.2 `dev.capabilities()` can confirm/deny R 4.1 graphic feature support
	# if active graphics device has implemented this feature
	if (getRversion() >= "4.2.0") {
		dev_capabilities <- grDevices::dev.capabilities()
		if (confirm_via_dev_capabilities(features, dev_capabilities)) {
			return(TRUE)
		}
		if (deny_via_dev_capabilities(features, dev_capabilities)) {
			return(FALSE)
		}
	}

	device <- names(grDevices::dev.cur())
	if (device %in% c("cairo_pdf", "cairo_ps", "pdf", "svg", "X11cairo")) {
		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"`
		.Platform$OS.type == "unix"
	} else if (device %in% c("agg_jpeg", "agg_ppm", "agg_png", "agg_tiff")) {
		utils::packageVersion("ragg") >= "1.2.0"
	} else if (device == "devSVG") {
		# `vdiffr:::svglite()` has name "devSVG_vdiffr" since v1.0.6
		utils::packageVersion("svglite") >= "2.1.0"
	} else {
		FALSE
	}
}

# Will always return FALSE if called within R 4.1
# or if graphics device hasn't been updated to provide this information
# even if the device had been updated to provide R 4.1 graphic feature support
confirm_via_dev_capabilities <- function(
	features = c("clippingPaths", "gradients", "masks", "patterns"),
	dev_capabilities = grDevices::dev.capabilities()
) {
	for (feature in features) {
		if (!confirm_feature(feature, dev_capabilities)) {
			return(FALSE)
		}
	}
	TRUE
}

confirm_feature <- function(feature, dev_capabilities) {
	switch(
		feature,
		clippingPaths = isTRUE(dev_capabilities$clippingPaths),
		gradients = all(c("LinearGradient", "RadialGradient") %in% dev_capabilities$patterns),
		masks = "alpha" %in% dev_capabilities$masks,
		patterns = "TilingPattern" %in% dev_capabilities$patterns
	)
}

# Will return `TRUE` if `dev.capabilities()` explicitly indicates
# the given features are not supported (versus merely missing a positive indication)
deny_via_dev_capabilities <- function(
	features = c("clippingPaths", "gradients", "masks", "patterns"),
	dev_capabilities = grDevices::dev.capabilities()
) {
	for (feature in features) {
		if (deny_feature(feature, dev_capabilities)) {
			return(TRUE)
		}
	}
	FALSE
}

deny_feature <- function(feature, dev_capabilities) {
	switch(
		feature,
		clippingPaths = isFALSE(dev_capabilities$clippingPaths),
		gradients = !is.na(dev_capabilities$patterns) &&
			!all(c("LinearGradient", "RadialGradient") %in% dev_capabilities$patterns),
		masks = !is.na(dev_capabilities$masks) && !("alpha" %in% dev_capabilities$masks),
		patterns = !is.na(dev_capabilities$patterns) &&
			!("TilingPattern" %in% dev_capabilities$patterns)
	)
}

# nocov end