Refactor chunks to S4

[gogonzo]

Current chunks version generates multiple problems. The most important is that:

• Chunks is an R6 object which is not mutable. This means that changes in the chunks don't trigger shiny reactivity. To achieve this we need to clone or force some reactive events using reactive fields kept in chunks

• Partial consequence of above is that chunks having queue system which delays evaluation of the code. This causes the mismatch between code evaluation and reactivity and creates general confusion.

• Problem with chunks object in the session is a minor and can be solved in the easy yet time consuming way Deprecate init_chunks #22

Solution is to refactor chunks to S4 object which will be "reactive" by default - changing any slots in the S4 object changes the address of the S4 object.

class code

setClass(
  "Quosure",
  representation(expr = "expression", env = "environment"),
  prototype(expr = expression(), env = new.env(parent = parent.env(.GlobalEnv)))
)
setGeneric("push", function(object, expr, name = "code") {
  standardGeneric("push")
})
setGeneric("get_var", function(object, var) {
  standardGeneric("get_var")
})
setGeneric("get_code", function(object, deparse = FALSE) {
  standardGeneric("get_code")
})
setGeneric("join", function(object, object2) {
  standardGeneric("join")
})
setMethod("push", signature("Quosure"), function(object, expr, name) {
  # combine expressions
  nm <- make.unique(c(names(object@expr), name))
  object@expr <- setNames(c(object@expr, expr), nm)

  # need to copy the objects from old env to new env
  # to avoind "chunks" sharing the same environment
  env <- new.env()
  for (i in ls(object@env)) {
    env[[i]] <- object@env[[i]]
  }
  eval(expr, envir = env)
  object@env <- env
  object
})
setMethod("get_var", signature("Quosure", "character"), function(object, var) {
  get(var, envir = object@env)
})
setMethod("get_code", signature("Quosure"), function(object, deparse) {
  if (deparse) {
    deparse(object@expr)
  } else {
    object@expr
  }
})
setMethod("join", signature("Quosure", "Quosure"), function(object, object2) {
  # object2 can't have modified object of the same name! See chunks_push_chunks
  common_names <- intersect(ls(object@env), ls(object2@env))
  is_identical_obj <- vapply(common_names, function(x) {
    identical(get(x, object@env), get(x, object2@env))
  }, logical(1))
  if (any(isTRUE(is_identical_obj))) {
    stop(
      "join does not allow overwriting already calculated values.",
      " Following variables would have been overwritten:",
      paste("    -", names(is_identical_obj), collapse = "\n"),
      sep = "\n"
    )
  }

  # join expressions
  # > join should be an inteligent union
  unique_expr <- !(object2@expr %in% object@expr & names(object2@expr) %in% names(object2@expr))
    # duplicated expr will probably have the same name also
    # unique_expr should have TRUE only at the end of the vector.
  object@expr <- c(object@expr, object2@expr[unique_expr])

  # insert new objects to env
  new_names <- setdiff(ls(object2@env), ls(object@env))
  lapply(new_names, function(x) assign(x, get(x, object2@env), object@env))

  object
})

Above class works as expected:

• each push evaluates new code.
• on each push new environment is created.
• even if new environment is created, unchanged object are not deep copied.
• mutated object within one environment does not change "itself" in the other environments.

library(rlang)

Code <- new("Quosure")
Code1 <- push(Code, quote(a <- data.frame(a = 1)))
Code2 <- push(Code1, quote(ADSL <- data.frame(a = 1, b = 2)))
Code3 <- push(Code2, quote(ADSL$c <- 3))

lobstr::obj_addr(Code)
lobstr::obj_addr(Code2) # new address
lobstr::obj_addr(Code2) # new address
lobstr::obj_addr(Code3) # new address

lobstr::obj_addr(Code@env) # new environment
lobstr::obj_addr(Code1@env) # new environment
lobstr::obj_addr(Code2@env) # new environment
lobstr::obj_addr(Code3@env) # new environment

lobstr::obj_addr(Code1@env$a)
lobstr::obj_addr(Code3@env$a) # unchanged object in new env preserves the same pointer

lobstr::obj_addr(Code2@env$ADSL)
lobstr::obj_addr(Code3@env$ADSL) # mutated object changes it's reference


get_var(Code2, "ADSL")
get_var(Code3, "ADSL")

POC for a shiny app:

Diagram of simple app representing different use cases:

App code

library(shiny)
library(teal.code)
library(dplyr)
library(rlang)

q <- new("Quosure")

q <- push(
  q,
  quote(
    adsl <- data.frame(
      SUBJID = 1:100,
      STUDYID = c(rep(1, 20), rep(2, 50), rep(3, 30)),
      AGE = sample(20:88, 100, replace = T) %>% as.numeric(),
      SEX = sample(c("M", "F", "U"), 100, replace = T) %>% as.factor()
    )
  )
)

# Days where Overall Survival (OS), Event free survival (EFS) and Progression Free Survival (PFS) happened
q <- push(
  q,
  expr(
    events <- data.frame(
      SUBJID = rep(1:100, 3),
      STUDYID = rep(c(rep(1, 20), rep(2, 50), rep(3, 30)), 3),
      PARAMCD = c(rep("OS", 100), rep("EFS", 100), rep("PFS", 100)),
      AVAL = c(rexp(100, 1 / 100), rexp(100, 1 / 80), rexp(100, 1 / 60)) %>% as.numeric(),
      AVALU = rep("DAYS", 300) %>% as.factor()
    )
  )
)

ui <- ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      # Input of Response can be chosen from Event Table
      selectInput(
        inputId = "filter_paramcd",
        label = "Filter Paramcd",
        choices = c("OS", "EFS", "PFS"),
        selected = "OS",
        multiple = TRUE
      ),
      selectInput(
        inputId = "filter_sex",
        label = "Filter sex",
        choices = c("F", "M", "U"),
        selected = c("F", "M", "U"),
        multiple = TRUE
      ),
      selectInput(
        inputId = "anl_columns",
        label = "ANL columns",
        choices = NULL,
        multiple = TRUE
      )
    ),
    mainPanel(
      verbatimTextOutput("code"),
      DT::DTOutput("anl_table"),
      plotOutput("plot")
    )
  )
)

server <- function(input, output, session) {
  # Create the dataset by merging the two tables per patient
  adsl_filtered_reactive <- reactive({
    push(q, expr(adsl_filtered <- adsl %>% dplyr::filter(SEX %in% !!input$filter_sex)))
  })

  # reactives name must differ from the objects which we want to reuse later
  events_filtered_reactive <- reactive({
    push(
      q,
      expr(events_filtered <- events %>% dplyr::filter(PARAMCD %in% !!input$filter_paramcd))
    )
    })

  merge_data <- reactive({
    q_common <- join(adsl_filtered_reactive(), events_filtered_reactive())
    push(
      q_common,
      expr(anl <- left_join(adsl_filtered, events_filtered, by = c("STUDYID", "SUBJID")))
    )
  })

  observeEvent(merge_data(), {
    anl <- get_var(merge_data(), "anl")
    updateSelectInput(
      session,
      "anl_columns",
      choices = colnames(anl),
      selected = colnames(anl)
    )
  })

  subset_anl <- reactive({
    req(input$anl_columns)
    qq <- push(
      merge_data(),
      rlang::expr(anl_subset <- anl[c(!!input$anl_columns)])
    )
  })

  table_call <- reactive({
    qq <- new("Quosure", env = subset_anl()@env)
    push(
      qq,
      rlang::expr({
        table <- DT::datatable(anl_subset)
        table
      })
    )
  })

  plot_call <- reactive({
    qq <- new("Quosure", env = subset_anl()@env)

    push(
      qq,
      rlang::expr({
        plot <- plot(anl_subset$AGE, anl_subset$AVAL)
        plot
      })
    )
  })

  outputs_call <- reactive({
    qq <- join(subset_anl(), table_call())
    join(qq, plot_call())
  })

  output$anl_table <- DT::renderDT(get_var(table_call(), "table"))
  output$plot <- renderPlot(get_var(plot_call(), "plot"))

  output$code <- renderText({
    paste(
      get_code(outputs_call()),
      collapse = "\n"
    )
  })
}
shinyApp(ui, server)