NDC_cache.R

#' 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())