update to qenv (#462)

NEWS.md

@@ -2,7 +2,7 @@
 
 ### Breaking changes
 
-* Replaced `chunks` with simpler `Quosure` class.
+* Replaced `chunks` with simpler `qenv` class.
 * Replaced `datasets` argument containing `FilteredData` with the new arguments `data` (list of reactive datasets) and `filter_panel_api` (`FilterPanelAPI`).
 
 ### Enhancements

R/tm_a_pca.R

@@ -53,8 +53,8 @@
 #'     )
 #'   )
 #' )
-#' \dontrun{
-#' shinyApp(app$ui, app$server)
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
 #' }
 #'
 tm_a_pca <- function(label = "Principal Component Analysis",
@@ -250,6 +250,7 @@ ui_a_pca <- function(id, ...) {
 srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+  checkmate::assert_class(data, "tdata")
   moduleServer(id, function(input, output, session) {
     response <- dat
 
@@ -260,19 +261,19 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       response[[i]]$select$choices <- var_labels(data[[response[[i]]$dataname]]())
       response[[i]]$select$choices <- setdiff(
         response[[i]]$select$choices,
-        unlist(attr(data, "join_keys")$get(response[[i]]$dataname))
+        unlist(get_join_keys(data)$get(response[[i]]$dataname))
       )
     }
 
     anl_merged_input <- teal.transform::merge_expression_module(
       datasets = data,
-      join_keys = attr(data, "join_keys"),
+      join_keys = get_join_keys(data),
       data_extract = list(dat = dat, response = response)
     )
 
     anl_merged_q <- reactive({
       req(anl_merged_input())
-      teal.code::new_quosure(env = data) %>%
+      teal.code::new_qenv(tdata2env(data), code = get_code(data)) %>%
         teal.code::eval_code(as.expression(anl_merged_input()$expr))
     })
 
@@ -308,7 +309,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
         )
       ))
 
-      quosure <- teal.code::eval_code(
+      qenv <- teal.code::eval_code(
         merged$anl_q_r(),
         substitute(
           expr = keep_columns <- keep_cols,
@@ -317,8 +318,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
 
       if (na_action == "drop") {
-        quosure <- teal.code::eval_code(
-          quosure,
+        qenv <- teal.code::eval_code(
+          qenv,
           quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint
         )
       }
@@ -333,24 +334,24 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
         validate(need(all(not_single), msg))
       }
 
-      quosure <- teal.code::eval_code(
-        quosure,
+      qenv <- teal.code::eval_code(
+        qenv,
         substitute(
           expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),
           env = list(center = center, scale = scale)
         )
       )
 
-      quosure <- teal.code::eval_code(
-        quosure,
+      qenv <- teal.code::eval_code(
+        qenv,
         quote({
           tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")
           tbl_importance
         })
       )
 
       teal.code::eval_code(
-        quosure,
+        qenv,
         quote({
           tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")
           tbl_eigenvector
@@ -362,13 +363,13 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
     output$plot_settings <- renderUI({
       # reactivity triggers
       req(computation())
-      quosure <- computation()
+      qenv <- computation()
 
       ns <- session$ns
 
-      pca <- quosure[["pca"]]
+      pca <- qenv[["pca"]]
       chcs_pcs <- colnames(pca$rotation)
-      chcs_vars <- quosure[["keep_columns"]]
+      chcs_vars <- qenv[["keep_columns"]]
 
       tagList(
         conditionalPanel(
@@ -564,16 +565,16 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
       validate(need(isTRUE(input$x_axis != input$y_axis), "Please choose different X and Y axes."))
 
-      quosure <- base_q
+      qenv <- base_q
 
-      ANL <- quosure[["ANL"]] # nolint
+      ANL <- qenv[["ANL"]] # nolint
 
       resp_col <- as.character(merged$anl_input_r()$columns_source$response)
       dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)
       x_axis <- input$x_axis # nolint
       y_axis <- input$y_axis # nolint
       variables <- input$variables # nolint
-      pca <- quosure[["pca"]]
+      pca <- qenv[["pca"]]
 
       ggtheme <- input$ggtheme
       validate(need(ggtheme, "Please select a theme."))
@@ -583,8 +584,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       size <- input$size # nolint
       font_size <- input$font_size # nolint
 
-      quosure <- teal.code::eval_code(
-        quosure,
+      qenv <- teal.code::eval_code(
+        qenv,
         substitute(
           expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),
           env = list(x_axis = x_axis, y_axis = y_axis)
@@ -593,8 +594,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
 
       # rot_vars = data frame that displays arrows in the plot, need to be scaled to data
       if (!is.null(input$variables)) {
-        quosure <- teal.code::eval_code(
-          quosure,
+        qenv <- teal.code::eval_code(
+          qenv,
           substitute(
             expr = {
             r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off
@@ -663,8 +664,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
           env = list(x_axis = x_axis, y_axis = y_axis)
         )
 
-        quosure <- teal.code::eval_code(
-          quosure,
+        qenv <- teal.code::eval_code(
+          qenv,
           substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))
         )
 
@@ -673,14 +674,14 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
         scales_biplot <- if (is.character(response) ||
           is.factor(response) ||
           (is.numeric(response) && length(unique(response)) <= 6)) {
-          quosure <- teal.code::eval_code(
-            quosure,
+          qenv <- teal.code::eval_code(
+            qenv,
             quote(pca_rot$response <- as.factor(response))
           )
           quote(scale_color_brewer(palette = "Dark2"))
         } else if (inherits(response, "Date")) {
-          quosure <- teal.code::eval_code(
-            quosure,
+          qenv <- teal.code::eval_code(
+            qenv,
             quote(pca_rot$response <- numeric(response))
           )
 
@@ -692,8 +693,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
             )
           )
         } else {
-          quosure <- teal.code::eval_code(
-            quosure,
+          qenv <- teal.code::eval_code(
+            qenv,
             quote(pca_rot$response <- response)
           )
           quote(scale_color_gradient(
@@ -772,7 +773,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
       )
 
       teal.code::eval_code(
-        quosure,
+        qenv,
         substitute(
           expr = {
             g <- plot_call

R/tm_a_regression.R

@@ -71,8 +71,8 @@
 #'     )
 #'   )
 #' )
-#' \dontrun{
-#' shinyApp(app$ui, app$server)
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
 #' }
 tm_a_regression <- function(label = "Regression Analysis",
                             regressor,
@@ -236,10 +236,11 @@ srv_a_regression <- function(id,
                              default_outlier_label) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+  checkmate::assert_class(data, "tdata")
   moduleServer(id, function(input, output, session) {
     anl_merged_input <- teal.transform::merge_expression_module(
       datasets = data,
-      join_keys = attr(data, "join_keys"),
+      join_keys = get_join_keys(data),
       data_extract = list(response = response, regressor = regressor)
     )
 
@@ -260,7 +261,7 @@ srv_a_regression <- function(id,
 
     anl_merged_q <- reactive({
       req(anl_merged_input())
-      teal.code::new_quosure(env = data) %>%
+      teal.code::new_qenv(tdata2env(data), code = get_code(data)) %>%
         teal.code::eval_code(as.expression(anl_merged_input()$expr))
     })
 
@@ -811,7 +812,7 @@ srv_a_regression <- function(id,
         )
       }
 
-      quosure <- if (input_type == "Response vs Regressor") {
+      qenv <- if (input_type == "Response vs Regressor") {
         plot_type_0()
       } else {
         plot_base_q <- plot_base()
@@ -824,7 +825,7 @@ srv_a_regression <- function(id,
           "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()
         )
       }
-      quosure
+      qenv
     })
 
 

R/tm_data_table.R

@@ -40,8 +40,8 @@
 #'     )
 #'   )
 #' )
-#' \dontrun{
-#' shinyApp(app$ui, app$server)
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
 #' }
 tm_data_table <- function(label = "Data Table",
                           variables_selected = list(),
@@ -136,7 +136,7 @@ ui_page_data_table <- function(id,
               lapply(
                 datanames,
                 function(x) {
-                  dataset <- data[[x]]()
+                  dataset <- isolate(data[[x]]())
                   choices <- names(dataset)
                   labels <- vapply(
                     dataset,
@@ -187,6 +187,7 @@ srv_page_data_table <- function(id,
                                 dt_args,
                                 dt_options,
                                 server_rendering) {
+  checkmate::assert_class(data, "tdata")
   moduleServer(id, function(input, output, session) {
     if_filtered <- reactive(as.logical(input$if_filtered))
     if_distinct <- reactive(as.logical(input$if_distinct))
@@ -248,8 +249,11 @@ srv_data_table <- function(id,
                            dt_args,
                            dt_options,
                            server_rendering) {
+
   moduleServer(id, function(input, output, session) {
+
     output$data_table <- DT::renderDataTable(server = server_rendering, {
+
       variables <- input$variables
 
       validate(need(variables, "need valid variable names"))

R/tm_file_viewer.R

@@ -30,8 +30,8 @@
 #'     )
 #'   )
 #' )
-#' \dontrun{
-#' shinyApp(app$ui, app$server)
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
 #' }
 #'
 tm_file_viewer <- function(label = "File Viewer Module",

R/tm_front_page.R

@@ -52,8 +52,8 @@
 #'   header = tags$h1("Sample Application"),
 #'   footer = tags$p("Application footer"),
 #' )
-#' \dontrun{
-#' shinyApp(app$ui, app$server)
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
 #' }
 tm_front_page <- function(label = "Front page",
                           header_text = character(0),
@@ -77,7 +77,7 @@ tm_front_page <- function(label = "Front page",
     ui = ui_front_page,
     ui_args = args,
     server_args = list(tables = tables, show_metadata = show_metadata),
-    filters = NULL
+    filters = if (show_metadata) "all" else NULL
   )
 }
 
@@ -165,7 +165,8 @@ get_footer_tags <- function(footnotes) {
   }, bold_text = bold_texts, value = footnotes)
 }
 
-srv_front_page <- function(id, datasets, tables, show_metadata) {
+srv_front_page <- function(id, data, tables, show_metadata) {
+  checkmate::assert_class(data, "tdata")
   moduleServer(id, function(input, output, session) {
     ns <- session$ns
 
@@ -190,8 +191,10 @@ srv_front_page <- function(id, datasets, tables, show_metadata) {
       )
 
       metadata_data_frame <- reactive({
-        raw_metadata <- lapply(datasets$datanames(), datasets$get_metadata)
-        convert_metadata_to_dataframe(raw_metadata, datasets$datanames())
+        convert_metadata_to_dataframe(
+          lapply(names(data), function(dataname) get_metadata(data, dataname)),
+          names(data)
+        )
       })
 
       output$metadata_table <- renderDataTable({

R/tm_g_association.R

@@ -67,8 +67,8 @@
 #'     )
 #'   )
 #' )
-#' \dontrun{
-#' shinyApp(app$ui, app$server)
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
 #' }
 tm_g_association <- function(label = "Association",
                              ref,
@@ -217,6 +217,7 @@ srv_tm_g_association <- function(id,
                                  ggplot2_args) {
   with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
   with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+  checkmate::assert_class(data, "tdata")
   moduleServer(id, function(input, output, session) {
     selector_list <- teal.transform::data_extract_multiple_srv(
       data_extract = list(ref = ref, vars = vars),
@@ -226,12 +227,12 @@ srv_tm_g_association <- function(id,
     anl_merged_input <- teal.transform::merge_expression_srv(
       datasets = data,
       selector_list = selector_list,
-      join_keys = attr(data, "join_keys")
+      join_keys = get_join_keys(data)
     )
 
     anl_merged_q <- reactive({
       req(anl_merged_input())
-      teal.code::new_quosure(env = data) %>%
+      teal.code::new_qenv(tdata2env(data), code = get_code(data)) %>%
         teal.code::eval_code(as.expression(anl_merged_input()$expr))
     })