R/graphics.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

#' @title Create a group of named graphic devices
#' @param ... named expressions to launch devices
#' @param env environment to evaluate expressions
#' @param attributes named list; names correspond to device names and values
#' are attributes to set to the devices
#' @param dev which device to search for attributes
#' @param which which attribute to obtain
#' @param ifnotfound value to return if attribute is not found
#' @return A list of functions to query, control, and switch between devices
#' @examples
#' \dontrun{ ## Unix-specific example
#'
#' # Create multiple named devices, setting attributes to the second graph
#' devs <- dev_create(
#'   line = X11(), points = x11(),
#'   attributes = list(points = list(pch = 16))
#' )
#'
#' # switch to device named "points"
#'
#' devs$dev_which('points')
#'
#' # Plot points, with pch given as preset
#' plot(1:10, pch = get_dev_attr(which = 'pch', ifnotfound = 1))
#'
#' # switch to "line" device
#' devs$dev_switch('line')
#' plot(1:100, type='l')
#'
#' # Create another group with conflict name
#' dev_another <- dev_create(line = X11())
#'
#' # Query device name with 'line'
#' dev_another$dev_which('line')  # 4
#' devs$dev_which('line')  # 2, doesn't conflict with the new groups
#'
#' dev.list()
#' # close one or more device
#' dev_another$dev_off('line')
#' dev.list()
#'
#' # close all devices
#' devs$dev_off()
#' dev.list()
#'
#' }
#' @name graphic-devices
NULL

#' @rdname graphic-devices
#' @export
dev_create <- function(..., env = parent.frame(), attributes = list()){
  quos <- rlang::quos(..., .ignore_empty = 'all', .named = TRUE)
  devs <- get0(".Devices", envir = baseenv(), ifnotfound = list("null device"), inherits = FALSE)
  n_devs <- unlist(devs)
  n_devs <- sum(n_devs != "")

  private_id <- rand_string(6)

  nms <- names(quos)

  # create devices
  for(ii in seq_along(quos)){
    quo <- quos[[ii]]
    rlang::eval_tidy(quo, env = env)
    devs <- get0(".Devices", envir = baseenv(), ifnotfound = list("null device"), inherits = FALSE)
    n <- sum(unlist(devs) != "")
    if( n > n_devs ){
      attr(devs[[n_devs + 1]], 'dipsaus_dev_name') <- paste0(private_id, nms[[ii]])
      opt <- attributes[[nms[[ii]]]]
      if(is.null(opt)) {
        opt <- list()
      }
      attr(devs[[n_devs + 1]], 'dipsaus_dev_attr') <- opt
    }
    # To CRAN Team who reaches this line
    #
    # The following line violates CRAN policy, as pointed by
    # Kurt Hornik <Kurt.Hornik@wu.ac.at> and
    # Paul Murrell <paul@stat.auckland.ac.nz>
    # on 03/10/2021, that ".Devices" is altered in baseenv()
    #
    # However, currently there is no substitute as the default grDevice package
    # does not allow labeling the devices. One of the issues is that device
    # list will be altered when user close the graphics and create new ones.
    # If some one close one (A) and open another device (B)
    # it is possible that B is mistaken as A, resulting in 2 figures blending
    # into each other. There are other issues, but this one is significant.
    #
    # After discussion, I was allowed to keep my code until native supports are
    # provided
    #
    #
    # Original Email:
    #     >>>>> Paul Murrell writes:
    #
    #     > Hi
    #     > On 15/03/21 10:58 am, Zhengjia Wang wrote:
    #       >> Hi, Paul,
    #       >> Thanks for clarification. Allowing reference by label is all I was
    #       >> asking for. dipsaus only adds one attribute as the label to each device,
    #       >> and the grouping was done using the label prefix. But in general, there
    #       >> are many ways to group the devices as long as I can reference by labels.
    #
    #     > Ok.  That sounds good.  I will look at implementing something for you
    #     > to try out.
    #
    #     Perfect.
    #
    #       >> For now, would you mind if I still keep this function in the package
    #       >> until the new feature is published? There are some projects that use
    #       >> this function to export graphs to multiple files, and I don't want them
    #       >> to get headaches for the sudden changes. However, I can always add a
    #       >> warning to dev_create so that other CRAN packages know to avoid
    #       >> importing this function. Once I can reference devices by labels in the
    #       >> newer versions of R, I'll fix this issue ASAP.
    #
    #     > I'll leave that up to the CRAN guys.
    #
    #     Yep, that should be fine for now.
    #
    #     Best
    #     -k
    #
    assign('.Devices', devs, envir = baseenv())
    n_devs <- n
  }

  dev_which <- function(dev_name){
    stopifnot2(length(dev_name) == 1 && is.character(dev_name), msg = 'dev_name must be a string')
    devs <- get0(".Devices", envir = baseenv(), ifnotfound = list("null device"), inherits = FALSE)
    for(ii in seq_along(devs)){
      if(ii == 1) next()
      dev <- devs[[ii]]
      if( dev != '' ){
        nm <- attr(dev, 'dipsaus_dev_name')
        if(isTRUE(paste0(private_id, dev_name) == nm)){
          return(ii)
        }
      }
    }
    return(NA)
  }

  dev_switch <- function(dev_name){
    ii <- dev_which(dev_name)
    if(!is.na(ii)){
      grDevices::dev.set(ii)
      return(TRUE)
    }
    return(FALSE)
  }

  dev_names <- function(){
    # only returns active device names
    devs <- get0(".Devices", envir = baseenv(), ifnotfound = list("null device"), inherits = FALSE)
    re <- lapply(devs, function(dev){
      dev_name <- attr(dev, 'dipsaus_dev_name')
      id <- str_sub(dev_name, end = 6)
      if(length(id) == 1 && isTRUE(id == private_id)){
        return(str_sub(dev_name, start = 7))
      }else{
        NULL
      }
    })
    unlist(re)
  }

  dev_off <- function(devnames){
    if(missing(devnames)){
      devnames <- dev_names()
    }
    for(nm in devnames){
      ii <- dev_which(nm)
      if(!is.na(ii)){
        grDevices::dev.off(ii)
      }
    }
    invisible()
  }

  dev_attributes <- function(dev_name){
    ii <- dev_which(dev_name)
    if(!is.na(ii)){
      devs <- get0(".Devices", envir = baseenv(), ifnotfound = list("null device"), inherits = FALSE)
      return(attr(devs[[ii]], 'dipsaus_dev_attr'))
    }
    return(NULL)
  }

  re <- fastmap2()
  re$dev_which <- dev_which
  re$dev_switch <- dev_switch
  re$dev_names <- dev_names
  re$dev_off <- dev_off
  re$dev_attributes <- dev_attributes
  return(re)
}

#' @rdname graphic-devices
#' @export
get_dev_attr <- function(which, dev = grDevices::dev.cur(), ifnotfound = NULL){
  devs <- get0(".Devices", envir = baseenv(), ifnotfound = list("null device"), inherits = FALSE)
  if(length(devs) < dev){
    return(ifnotfound)
  }
  attrs <- attr(devs[[dev]], 'dipsaus_dev_attr')

  if(missing(which)){
    # return the whole attributes

    if(is.null(attrs)){
      return(ifnotfound)
    } else {
      return(attrs)
    }

  } else {

    # return the item within attr
    if(which %in% names(attrs)){
      return(attrs[[which]])
    } else {
      return(ifnotfound)
    }
  }
}