Skip to content

Instantly share code, notes, and snippets.

@r2evans

r2evans/NDC_cache.R

Created Mar 26, 2018
Embed
What would you like to do?
#' NDC caching for cross-facet plot elements
#'
#' Useful when using [layout()] and drawing things *between* different
#' plots. Motivated by https://stackoverflow.com/q/49464991/3358272.
#'
#' @details
#'
#' When adding plot "things" (lines, points, arrows) between facets of
#' a `layout` combination, in addition to `x` and `y`, you simply
#' provide the plot number within the sequence. (Since this is the
#' sequence of calls to `NDC$add()`, if a plot is created without a
#' subsequent call to `NDC$add()`, then the sequencing will not be
#' identical with what `layout` considered to be the plot numbers.)
#'
#' If the `plotnum` is `NA`, then the coordinates are passed through
#' unmodified, which might be useful when adding elements to the
#' current plot. The use of `xpd=TRUE` will result in the element
#' being clipped at the limits of the current figure (individual facet
#' of the layout), whereas `xpd=NA` will allow the element to plot
#' over other facets outside of the current figure's region.
#'
#' Extensions (TODO):
#'
#' - enable revisiting a particular plot, perhaps for the purposes of
#' adding simple graphics and/or using `locator` within that region;
#' this can be done now, but if other params such as 'mar' are
#' non-standard, we need to store more to reconstruct it
#'
#' @param plotnum integer, the nth plot within the layout sequence;
#' can be referenced anytime after a plot has been started; if `NA`,
#' then the respective `x` an `y` will be passed through unmodified,
#' which might be useful when adding something to the current plot;
#' see 'Details'
#' @param x,y numeric, coordinates within a specific plot's coordinate
#' system that need to be converted into something that can be used
#' in a full-frame plot (e.g., post-`layout` use of `plot.frame()`)
#' @return - `add()`, `reset()` return nothing - `peek()` returns the
#' current (internal) set of cached data - `convert()` returns a
#' list with 'x' and 'y', converted into the coordinates of the
#' current plot (which might be `plot.frame()` but not necessarily)
#' @md
#' @examples
#' \dontrun{
#'
#' ### overlay a new plot.frame() over the finished layout
#'
#' NDC$reset()
#' layout( matrix( 1:2 , nrow=2 ) )
#' plot( x=c(1,2) , y=c(1,2) , main="Plot 1" )
#' points(y~x, data=pointfrom, pch=16, col='red')
#' # this stores enough information to be able to back-calculate
#' # the user coordinates in a follow-on plot
#' NDC$add()
#' plot( x=c(10,20) , y=c(10,20) , main="Plot 2" )
#' points(y~x, data=pointto, pch=16, col='red')
#' NDC$add()
#' par(fig=c(0:1,0:1), new=TRUE)
#' plot.new()
#' with(NDC$convert(c(1, 2), c(1.1, 17), c(1.3, 19)),
#' arrows(x[1], y[1], x[2], y[2]))
#'
#' ### add the element while the final plot is still current
#' NDC$reset()
#' layout( matrix( 1:2 , nrow=2 ) )
#' plot( x=c(1,2) , y=c(1,2) , main="Plot 1" )
#' points(y~x, data=pointfrom, pch=16, col='red')
#' NDC$add()
#' plot( x=c(10,20) , y=c(10,20) , main="Plot 2" )
#' points(y~x, data=pointto, pch=16, col='red')
#' # no additional call to NDC$add()
#' # highlight the current figure/facet
#' box('figure', col='red', lwd=2)
#' # first, show xpd=TRUE and figure-clipping
#' with(NDC$convert(c(1, NA), c(1.2, 18), c(1.2, 18)),
#' arrows(x[1], y[1], x[2], y[2], lwd=5, col='gray', xpd=TRUE))
#' # second, show xpd=NA and device-clipping
#' with(NDC$convert(c(1, NA), c(1.2, 18), c(1.2, 18)),
#' arrows(x[1], y[1], x[2], y[2], xpd=NA))
#'
#' ### third example, 2D layout
#'
#' NDC$reset()
#' layout(matrix(1:4, nrow=2))
#' plot(1)
#' NDC$add()
#' plot(11)
#' NDC$add()
#' plot(21)
#' NDC$add()
#' plot(31)
#' NDC$add()
#' with(NDC$convert(1:4, c(1,1,1,1), c(1,11,21,31)), {
#' arrows(x[1], y[1], x[2], y[2], xpd=NA)
#' arrows(x[2], y[2], x[3], y[3], xpd=NA)
#' arrows(x[3], y[3], x[4], y[4], xpd=NA)
#' })
#'
#' }
NDC <- local({
.data <- NULL
peek <- function() return(.data)
reset <- function() {
.data <<- data.frame(num=0L,
usrx1=0, usrx2=0, usry1=0, usry2=0,
ndcx1=0, ndcx2=0, ndcy1=0, ndcy2=0)[0,]
}
# setplot <- function(i) {
# # this is only robust if we store other par's, such as "mar"
# with(.data[i,,drop=FALSE], par(fig=..., mar=..., usr=...))
# }
add <- function() {
thisnum <- max(0L, .data$num) + 1L
usr <- par('usr')
z <- setNames(c(thisnum, usr, par('fig'),
grconvertX(usr[1:2], 'user', 'ndc'),
grconvertY(usr[3:4], 'user', 'ndc')),
c('num', 'usrx1','usrx2','usry1','usry2',
'figx1','figx2','figy1','figy2',
'ndcx1','ndcx2','ndcy1','ndcy2'))
d <- as.data.frame(as.list(z))
.data <<- rbind(.data, d)
}
convert <- function(plotnum, x, y, usr = par('usr')) {
if (any(plotnum < 1L | max(.data$num) < plotnum, na.rm = TRUE))
stop('wrong number of plots stored')
n <- length(plotnum)
if (length(x) != n || length(y) != n)
stop('unequal vector length')
d <- merge(
data.frame(num=plotnum, newx=x, newy=y),
.data, by = "num",
all.x = TRUE
)
# if num is NA, then just return the respective 'x' and 'y'
with(d, list(
x = ifelse(is.na(num), x,
grconvertX(ndcx1 + (ndcx2 - ndcx1) * (newx - usrx1) / (usrx2 - usrx1),
'ndc', 'user')),
y = ifelse(is.na(num), y,
grconvertY(ndcy1 + (ndcy2 - ndcy1) * (newy - usry1) / (usry2 - usry1),
'ndc', 'user'))
))
}
reset()
l <- sapply(ls(), base::get, envir=environment(), simplify=FALSE)
class(l) <- c("NDC")
l
})
print.NDC <- function(x, ...) print(x$peek())
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment