R/code-append.R

In dgkf/scriptgloss: Functionality for creating static scripts from shiny apps

#' Add code to code block
#'
#' @param x existing code block to append to
#' @param code additional list of code to append
#' @param after position at which to append code
#'
#' @return the initial code block with additional code inserted at specified
#'   \code{after} position
#'
#' @examples
#' code1 <- quote({
#'   a <- 1
#'   b <- 2
#'   e <- 5
#' })
#'
#' code2 <- quote({
#'   c <- 3
#'   d <- 4
#' })
#'
#' scriptgloss:::append_code(code1, as.list(code2)[-1], 2)
#'
append_code <- function(x, code, after = length(x)) {
  if (!length(code)) return(x)
  append(as.list(x), as.list(code), after)
}



#' Append declarations to code block
#'
#' @description appends all ellipses or dots arguments to code at specified
#'   location, reconstructing code to initialize variables in the code block.
#'
#' @param x code block to append to
#' @param ... a named list of variables to create declarations for. currently
#'   only objects of a subset of types get instantiated: 
#'   \itemize{
#'   \item{reactivevalues (via \code{\link[shiny]{reactiveValuesToList}()})}
#'   \item{atomic} 
#'   \item{numeric} 
#'   \item{character}
#'   }
#' @param after position at which to insert declaration code
#' @param dots alternative passing of ellipses arguments
#'
#' @return reconstructed code with declarations inserted
#'
#' @examples
#' \dontrun{
#' # for example purposes, we can disable checcking of a running shiny instance
#' # as a safeguard against calling `reactiveValuesToList` outside of shiny
#' options(scriptgloss.testmode = TRUE)
#' 
#' code <- quote({
#'   a <- tolower(a)
#'   b <- b[[1]]
#'   c <- tolower(c)
#'   print(sprintf('this is %s %dst %s', a, b, c))
#' })
#'
#' scriptgloss:::append_declaration(as.list(code)[-1], 
#'     a = 'my', 
#'     b = list(1,2,3),
#'     c = 'example', after = 0)
#'     
#' options(scirptgloss.testmode = FALSE) # reset to default behavior
#' }
#'
#' @importFrom shiny reactiveValuesToList
#'
append_declaration <- function(x, ..., after = length(x), dots = list()) {
  check_shiny()
  dots <- rev(c(dots, list(...)))
  
  for (d in names(dots)) {
    # handle desired shiny-specific variable types
    if ("reactivevalues" %in% class(dots[[d]]))
      dots[[d]] <- shiny::reactiveValuesToList(dots[[d]], all.names = TRUE)
    
    # reject additional shiny-specific variables
    if (any(class(dots[[d]]) %in% names(getNamespace("shiny")))) next
    
    # otherwise reconstruct code to initialize variable
    data_constructor <- getInitializationCode(dots[[d]])
    x <- append(x, bquote(.(as.name(d)) <- .(data_constructor)), after)
  }
  
  x
}



#' Add calls to output list functions
#'
#' @description add calls such as \code{output$plot()} to a code block. helpful
#'   for adding function call to a independent R script such that output gets
#'   drawn at end of script.
#'
#' @param x code block to which output calls will be appended
#' @param ... names of outputs to be called as character
#' @param dots optionally pass ellipses arguments as list
#' @param after position at which to create calls
#'
#' @return code block with calls to output functions appended
#'
#' @examples
#' code <- quote({
#'   a <- 1
#' })
#'
#' scriptgloss:::append_output_calls(code, 'plot', 'table', 'text')
#'
append_output_calls <- function(x, ..., dots = list(), after = length(x)) {
  dots <- c(list(...), as.list(dots))
  append(x,
    Map(function(i) call("$", as.name("output"), call(i)), dots),
    after = after)
}