R/grid.R

In edzer/sfr: Simple Features for R

#' Convert sf* object to a grob
#'
#' Convert sf* object to an grid graphics object (grob)
#' @param x object to be converted into an object class \code{grob}
#' @param ... passed on to the xxxGrob function, e.g. \code{gp = gpar(col = 'red')}
#' @export
st_as_grob = function(x, ...) UseMethod("st_as_grob")

#' @export
st_as_grob.POINT = function(x, pch = 1, size = unit(1, "char"), default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (anyNA(x))
		nullGrob()
	else
		pointsGrob(x[1], x[2], pch = pch, size = size, default.units = default.units, name = name, gp = gp, vp = vp)
}

#' @export
st_as_grob.MULTIPOINT = function(x, pch = 1, size = unit(1, "char"), default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (nrow(x) == 0)
		nullGrob()
	else
		pointsGrob(x[,1], x[,2], pch = pch, size = size, default.units = default.units, name = name, gp = gp, vp = vp)
}

#' @export
st_as_grob.LINESTRING = function(x, arrow = NULL, default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (nrow(x) == 0)
		nullGrob()
	else
		linesGrob(x[,1], x[,2], arrow = NULL, default.units = default.units, name = name, gp = gp, vp = vp)
}

#' @export
st_as_grob.CIRCULARSTRING = function(x, y, ...) {
	st_as_grob(st_cast(x, "LINESTRING"),  ...)
}

#' @export
st_as_grob.MULTILINESTRING = function(x, arrow = NULL, default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (length(x) == 0)
		nullGrob()
	else {
		get_x = function(x) unlist(sapply(x, function(y) y[,1]))
		get_y = function(x) unlist(sapply(x, function(y) y[,2]))
		polylineGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), arrow = NULL,
			default.units = default.units, name = name, gp = gp, vp = vp)
	}
}

#' @export
st_as_grob.POLYGON = function(x, default.units = "native", rule = "evenodd", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (length(x) == 0)
		nullGrob()
	else {
		get_x = function(x) unlist(sapply(x, function(y) y[,1]))
		get_y = function(x) unlist(sapply(x, function(y) y[,2]))
		pathGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), default.units = default.units, rule = rule, name = name, gp = gp, vp = vp)
	}
}

#' @export
st_as_grob.MULTIPOLYGON = function(x, default.units = "native", rule = "evenodd", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (length(x) == 0)
		nullGrob()
	else {
		get_x = function(x) unlist(sapply(x, function(y) sapply(y, function(z) z[,1])))
		get_y = function(x) unlist(sapply(x, function(y) sapply(y, function(z) z[,2])))
		get_l = function(x) unlist(sapply(x, function(y) vapply(y, nrow, 0L)))
		pathGrob(get_x(x), get_y(x), id.lengths = get_l(x), default.units = default.units, rule = rule, name = name, gp = gp, vp = vp)
	}
}

#' @export
st_as_grob.GEOMETRYCOLLECTION = function(x, ...) {
	if (length(x) == 0)
		nullGrob()
	else
		do.call(grid::grobTree, lapply(x, st_as_grob, ...))
}

#' @export
st_as_grob.MULTISURFACE = st_as_grob.GEOMETRYCOLLECTION

#' @export
st_as_grob.CURVEPOLYGON = st_as_grob.GEOMETRYCOLLECTION

#' @export
st_as_grob.COMPOUNDCURVE = st_as_grob.GEOMETRYCOLLECTION


#' Create viewport from sf, sfc or sfg object
#'
#' Create viewport from sf, sfc or sfg object
#' @param x object of class sf, sfc or sfg object
#' @param bbox the bounding box used for aspect ratio
#' @param asp numeric; target aspect ratio (y/x), see Details
#' @param ... parameters passed on to \link[grid]{viewport}
#' @details parameters \code{width}, \code{height}, \code{xscale} and \code{yscale} are set such that aspect ratio is honoured and plot size is maximized in the current viewport; others can be passed as \code{...}
#' @return The output of the call to \link[grid]{viewport}
#' @details If \code{asp} is missing, it is taken as 1, except when \code{isTRUE(st_is_longlat(x))}, in which case it is set to \code{1.0 /cos(y)}, with \code{y} the middle of the latitude bounding box.
#' @examples
#' library(grid)
#' nc = st_read(system.file("shape/nc.shp", package="sf"))
#' grid.newpage()
#' pushViewport(viewport(width = 0.8, height = 0.8))
#' pushViewport(st_viewport(nc))
#' invisible(lapply(st_geometry(nc), function(x) grid.draw(st_as_grob(x, gp = gpar(fill = 'red')))))
#' @export
st_viewport = function(x, ..., bbox = st_bbox(x), asp) {
	xscale = bbox[c(1,3)]
	yscale = bbox[c(2,4)]

	# from rgdal2/R/graphics.R:
	current.viewport.size = function(units = "inches") {
    	vp = current.viewport()
		vi = convertHeight(vp$height, units, valueOnly = TRUE)
		wi = convertWidth(vp$width, units, valueOnly = TRUE)
    	c(width = wi, height = vi)
	}
	current.viewport.aspect = function() {
    	sz = current.viewport.size()
    	sz[2] / sz[1]
	}
	vp.asp = current.viewport.aspect()
	if (missing(asp))
		asp = if (isTRUE(st_is_longlat(x)))
			1.0 / cos((mean(yscale) * pi)/180)
		else
			1.0

   	obj.asp = asp * diff(yscale) / diff(xscale)
	height = obj.asp / vp.asp
   	width = 1
   	width = width / max(width, height)
   	height = height / max(width, height)
	viewport(width = unit(width, "npc"), height = unit(height, "npc"),
    		xscale = unit(xscale, "native"), yscale = unit(yscale, "native"), ...)
}

#' @export
st_as_grob.sfc_POINT <- function(x, pch = 1, size = unit(1, "char"), default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (any(is_e <- st_is_empty(x))) {
		gp = gp[!is_e]
		x = x[!is_e]
	}
	if (length(x)) {
		x <- matrix(unlist(x, use.names = FALSE), ncol = length(x))
		pointsGrob(x[1, ], x[2, ], pch = pch, size = size,
				   default.units = default.units, name = name, gp = gp, vp = vp)
	} else
		nullGrob()
}
#' @export
#' @importFrom grid gpar
st_as_grob.sfc_MULTIPOINT <- function(x, pch = 1, size = unit(1, "char"), default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (any(is_e <- st_is_empty(x))) {
		gp = gp[!is_e]
		x = x[!is_e]
	}
	if (length(x)) {
		x <- unclass(x)
		n_points <- vapply(x, nrow, integer(1))
		gp <- expand_gp(gp, n_points)
		if (length(pch) != 1) pch <- rep(rep(pch, length.out = length(x)), n_points)
		if (length(size) != 1) size <- rep(rep(size, length.out = length(x)), n_points)
		x <- do.call(rbind, x)
		pointsGrob(x[, 1], x[, 2], pch = pch, size = size, 
				   default.units = default.units, name = name, gp = gp, vp = vp)
	} else
		nullGrob()
}
#' @export
st_as_grob.sfc_LINESTRING <- function(x, arrow = NULL, default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (any(is_e <- st_is_empty(x))) {
		gp = gp[!is_e]
		x = x[!is_e]
	}
	if (length(x)) {
		x <- unclass(x)
		n_points <- vapply(x, nrow, integer(1))
		x <- do.call(rbind, x)
		polylineGrob(x[, 1], x[, 2], id.lengths = n_points, arrow = arrow, 
					 default.units = default.units, name = name, gp = gp, vp = vp)
	} else
		nullGrob()
}
#' @export
st_as_grob.sfc_MULTILINESTRING <- function(x, arrow = NULL, default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (any(is_e <- st_is_empty(x))) {
		gp = gp[!is_e]
		x = x[!is_e]
	}
	if (length(x)) {
		x <- unclass(x)
		n_lines <- vapply(x, length, integer(1))
		gp <- expand_gp(gp, n_lines)
		if (!is.null(arrow) && length(arrow) != 1) arrow <- rep(rep(arrow, length.out = length(x)), n_lines)
		x <- unlist(x, recursive = FALSE)
		n_points <- vapply(x, nrow, integer(1))
		x <- do.call(rbind, x)
		polylineGrob(x[, 1], x[, 2], id.lengths = n_points, arrow = arrow, 
					 default.units = default.units, name = name, gp = gp, vp = vp)
	} else
		nullGrob()
}
#' @export
st_as_grob.sfc_POLYGON <- function(x, rule = "evenodd", default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (utils::packageVersion("grid") < "3.6") {
		return(scalar_grobs(x, rule = rule, default.units = default.units, name = name, gp = gp, vp = vp, ...)) # nocov
	}
	if (any(is_e <- st_is_empty(x))) {
		gp = gp[!is_e]
		x = x[!is_e]
	}
	if (length(x)) {
		x <- unclass(x) # nocov start
		n_poly <- vapply(x, length, integer(1))
		x <- unlist(x, recursive = FALSE)
		n_points <- vapply(x, nrow, integer(1))
		n_paths <- tapply(n_points, rep(seq_along(n_poly), n_poly), sum)
		x <- do.call(rbind, x)
		pathGrob(x[, 1], x[, 2], id.lengths = n_points, pathId.lengths = n_paths, 
				 rule = rule, default.units = default.units, name = name, gp = gp, vp = vp) # nocov end
	} else
		nullGrob()
}
#' @export
st_as_grob.sfc_MULTIPOLYGON <- function(x, rule = "evenodd", default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
	if (utils::packageVersion("grid") < "3.6") {
		return(scalar_grobs(x, rule = rule, default.units = default.units, name = name, gp = gp, vp = vp, ...)) # nocov
	}
	if (any(is_e <- st_is_empty(x))) {
		gp = gp[!is_e]
		x = x[!is_e]
	}
	if (length(x)) {
		x <- unclass(x) # nocov start
		n_poly <- vapply(x, length, integer(1))
		gp <- expand_gp(gp, n_poly)
		x <- unlist(x, recursive = FALSE)
		n_poly <- vapply(x, length, integer(1))
		x <- unlist(x, recursive = FALSE)
		n_points <- vapply(x, nrow, integer(1))
		n_paths <- tapply(n_points, rep(seq_along(n_poly), n_poly), sum)
		x <- do.call(rbind, x)
		pathGrob(x[, 1], x[, 2], id.lengths = n_points, pathId.lengths = n_paths, 
				 rule = rule, default.units = default.units, name = name, gp = gp, vp = vp) # nocov end
	} else
		nullGrob()
}
#' @export
st_as_grob.sfc_CIRCULARSTRING <- function(x, ...) {
	st_as_grob(st_cast(x, 'LINESTRING'), ...) # nocov
}
#' @export
#' @importFrom grid gList
st_as_grob.sfc <- function(x, pch = 1, size = unit(1, "char"), arrow = NULL, gp = gpar(), ...) {
	old_length <- length(x)
	x <- st_cast_sfc_default(x)
	ids <- attr(x, 'ids')
	if (!is.null(ids)) {
		# x was a geometrycollection that has been unlisted. Need to match gpar
		if (length(pch) > 1) {
			pch <- rep(rep_len(pch, old_length), ids)
		}
		if (length(size) > 1) {
			size <- rep(rep_len(size, old_length), ids)
		}
		if (length(arrow) > 1) {
			arrow <- rep(rep_len(arrow, old_length), ids)
		}
		for (par in names(gp)) {
			if (length(gp[[par]]) > 1) {
				gp[[par]] <- rep(rep_len(gp[[par]], old_length), ids)
			}
		}
	}
	if (class(x)[1] %in% c('sfc_MULTIPOINT', 'sfc_MULTILINESTRING', 'sfc_MULTIPOLYGON'))
		st_as_grob(x, pch = pch, size = size, arrow = arrow, gp = gp, ...)
	else
		scalar_grobs(x, pch, size, arrow, gp, ...)
}

scalar_grobs <- function(x, pch = 1, size = unit(1, "char"), arrow = NULL, gp = gpar(), ...) {
	gp <- split_gp(gp, length(x))
	pch <- rep(pch, length.out = length(x))
	size <- rep(size,  length.out = length(x))
	if (!is.null(arrow)) arrow <- rep(arrow, length.out = length(x))
	do.call(gList, lapply(seq_along(x), function(i) {
		st_as_grob(x[[i]], pch = pch[i], size = size[i], arrow = arrow[i], gp = gp[[i]], ...)
	}))
}

expand_gp <- function(gp, n) {
	if (length(gp) == 0) return(gp)
	gp <- unclass(gp)
	n_gp <- vapply(gp, length, integer(1))
	gp[n_gp > 1] <- lapply(gp[n_gp > 1], rep, n)
	`class<-`(gp, 'gpar')
}
split_gp <- function(gp, n) {
	gp <- unclass(gp)
	gp <- lapply(gp, rep_len, n)
	lapply(seq_len(n), function(i) {
		`class<-`(lapply(gp, `[`, i), 'gpar')
	})
}