812 landing popup

DESCRIPTION

@@ -76,6 +76,7 @@ Collate:
     'include_css_js.R'
     'modules.R'
     'init.R'
+    'landing_popup_module.R'
     'module_filter_manager.R'
     'module_nested_tabs.R'
     'module_snapshot_manager.R'

NAMESPACE

@@ -24,6 +24,7 @@ export(get_code_tdata)
 export(get_join_keys)
 export(get_metadata)
 export(init)
+export(landing_popup_module)
 export(module)
 export(modules)
 export(new_tdata)

NEWS.md

@@ -7,6 +7,7 @@
 * Added internal functions for storing and restoring of `teal_slices` objects.
 * Filter state snapshots can now be uploaded from file. See `?snapshot`.
 * Added argument to `teal_slices` and made modifications to `init` to enable tagging `teal_slices` with an app id to safely upload snapshots from disk.
+* `module` can now create modules of different classes that will be handled differently by `init`. The default class is still `"teal_module"` so no changes to existing templates are necessary. Currently handled classes are `"teal_module_landing"`, which will not be presented in tabs, and `"teal_module_reporter"`.
 
 # teal 0.14.0
 

R/init.R

@@ -136,6 +136,13 @@ init <- function(data,
     modules <- do.call(teal::modules, modules)
   }
 
+  landing <- extract_module(modules, "teal_module_landing")
+  if (length(landing) > 1L) stop("only one `landing_popup_module` can be used")
+  modules <- drop_module(modules, "teal_module_landing")
+  if (length(landing) == 1L && length(modules) == 0L) {
+    stop("app needs to have one more module besides `landing_popup_module`")
+  }
+
   # resolve modules datanames
   datanames <- teal.data::get_dataname(data)
   join_keys <- data$get_join_keys()
@@ -223,6 +230,10 @@ init <- function(data,
   res <- list(
     ui = ui_teal_with_splash(id = id, data = data, title = title, header = header, footer = footer),
     server = function(input, output, session) {
+      if (length(landing) == 1L) {
+        landing_module <- landing[[1L]]
+        do.call(landing_module$server, c(list(id = "landing_module_shiny_id"), landing_module$server_args))
+      }
       # copy object so that load won't be shared between the session
       data <- data$copy(deep = TRUE)
       filter <- deep_copy_filter(filter)

R/landing_popup_module.R

@@ -0,0 +1,118 @@
+#' Landing Popup Module
+#'
+#' @description This module creates a landing welcome popup for `teal` applications.
+#'
+#' @details If you use this module in `teal::init(modules = )`, it will not be wrapped in a tab in `teal` application.
+#'
+#' @param label `character(1)` the label of the module.
+#' @param title `character(1)` the text to be displayed as a title of the popup.
+#' @param content The content of the popup. Passed to `...` of `shiny::modalDialog`. Can be a `character`
+#' or a text input control (like `textInput`) or a list of `shiny` tags. See examples.
+#' @param buttons `shiny.tag` or a list of tags (`tagList`). Typically a `modalButton` or `actionButton`. See examples.
+#'
+#' @return A `teal_module` (extended with `teal_landing_module` class) to be used in `teal` applications.
+#'
+#' @examples
+#' app1 <- teal::init(
+#'   data = teal.data::dataset("iris", iris),
+#'   modules = teal::modules(
+#'     teal::landing_popup_module(
+#'       content = "A place for the welcome message or a disclaimer statement.",
+#'       buttons = modalButton("Proceed")
+#'     ),
+#'     module(
+#'       label = "example module",
+#'       server = function(input, output, session, data) {},
+#'       ui = function(id, ...) div(p("Example text"))
+#'     )
+#'   )
+#' )
+#' if (interactive()) {
+#'   shinyApp(app1$ui, app1$server)
+#' }
+#'
+#' app2 <- teal::init(
+#'   data = teal.data::dataset("iris", iris),
+#'   modules = teal::modules(
+#'     teal::landing_popup_module(
+#'       title = "Welcome",
+#'       content = tags$b(
+#'         "A place for the welcome message or a disclaimer statement.",
+#'         style = "color: red;"
+#'       ),
+#'       buttons = tagList(
+#'         modalButton("Proceed"),
+#'         actionButton("close", "Read more",
+#'           onclick = "window.open('http://google.com', '_blank')"
+#'         )
+#'       )
+#'     ),
+#'     module(
+#'       label = "example module",
+#'       server = function(input, output, session, data) {},
+#'       ui = function(id, ...) div(p("Example text"))
+#'     )
+#'   )
+#' )
+#'
+#' if (interactive()) {
+#'   shinyApp(app2$ui, app2$server)
+#' }
+#'
+#' app3 <- teal::init(
+#'   data = teal.data::dataset("iris", iris),
+#'   modules = teal::modules(
+#'     teal::landing_popup_module(
+#'       title = "Welcome",
+#'       content = "App will close, once you click the rejection button!",
+#'       buttons = tagList(
+#'         modalButton("Proceed"),
+#'         actionButton("close", "Reject", onclick = "window.close()")
+#'       )
+#'     ),
+#'     module(
+#'       label = "example module",
+#'       server = function(input, output, session, data) {},
+#'       ui = function(id, ...) div(p("Example text"))
+#'     )
+#'   )
+#' )
+#'
+#' if (interactive()) {
+#'   shinyApp(app3$ui, app3$server, options = list(launch.browser = TRUE))
+#' }
+#'
+#' @export
+landing_popup_module <-
+  function(label = "Landing Popup",
+           title = NULL,
+           content = NULL,
+           buttons = modalButton("Accept")) {
+    checkmate::assert_string(label)
+    checkmate::assert_string(title, null.ok = TRUE)
+    checkmate::assert_multi_class(
+      content,
+      classes = c("character", "shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE
+    )
+    checkmate::assert_multi_class(buttons, classes = c("shiny.tag", "shiny.tag.list"))
+
+    logger::log_info("Initializing landing_popup_module")
+
+    module <- module(
+      label = label,
+      server = function(id) {
+        moduleServer(id, function(input, output, session) {
+          showModal(
+            modalDialog(
+              id = "landingpopup",
+              title = title,
+              content,
+              footer = buttons
+            )
+          )
+        })
+      }
+    )
+    class(module) <- c("teal_module_landing", class(module))
+    module
+  }

R/module_teal.R

@@ -226,16 +226,7 @@ srv_teal <- function(id, modules, raw_data, filter = teal_slices()) {
     })
 
     reporter <- teal.reporter::Reporter$new()
-    is_any_previewer <- function(modules) {
-      if (inherits(modules, "teal_modules")) {
-        any(unlist(lapply(modules$children, is_any_previewer), use.names = FALSE))
-      } else if (inherits(modules, "teal_module_previewer")) {
-        TRUE
-      } else {
-        FALSE
-      }
-    }
-    if (is_arg_used(modules, "reporter") && !is_any_previewer(modules)) {
+    if (is_arg_used(modules, "reporter") && length(extract_module(modules, "teal_module_previewer")) == 0) {
       modules <- append_module(modules, reporter_previewer_module())
     }
 

R/modules.R

@@ -89,7 +89,7 @@ modules <- function(..., label = "root") {
   )
 }
 
-#' Function which appends a teal_module onto the children of a teal_modules object
+#' Function which appends a `teal_module` onto the children of a `teal_modules` object
 #' @keywords internal
 #' @param modules `teal_modules`
 #' @param module `teal_module` object to be appended onto the children of `modules`
@@ -103,6 +103,42 @@ append_module <- function(modules, module) {
   modules
 }
 
+#' Extract/Remove module(s) of specific class
+#'
+#' Given a `teal_module` or a `teal_modules`, return the elements of the structure according to `class`.
+#'
+#' @param modules `teal_modules`
+#' @param class The class name of `teal_module` to be extracted or dropped.
+#' @keywords internal
+#' @return For `extract_module`, a `teal_module` of class `class` or `teal_modules` containing modules of class `class`.
+#' For `drop_module`, an opposite, which is all `teal_modules` besides the ones with `class` class.
+#' @rdname extract_module
+extract_module <- function(modules, class) {
+  if (inherits(modules, class)) {
+    modules
+  } else if (inherits(modules, "teal_module")) {
+    NULL
+  } else if (inherits(modules, "teal_modules")) {
+    Filter(function(x) length(x) > 0L, lapply(modules$children, extract_module, class))
+  }
+}
+
+#' @keywords internal
+#' @return `teal_modules`
+#' @rdname extract_module
+drop_module <- function(modules, class) {
+  if (inherits(modules, class)) {
+    NULL
+  } else if (inherits(modules, "teal_module")) {
+    modules
+  } else if (inherits(modules, "teal_modules")) {
+    do.call(
+      "modules",
+      c(Filter(function(x) length(x) > 0L, lapply(modules$children, drop_module, class)), label = modules$label)
+    )
+  }
+}
+
 #' Does the object make use of the `arg`
 #'
 #' @param modules (`teal_module` or `teal_modules`) object

R/reporter_previewer_module.R

@@ -7,12 +7,13 @@
 #'
 #' If you are creating a `teal` application using [teal::init()] then this
 #' module will be added to your application automatically if any of your `teal modules`
-#' support report generation
+#' support report generation.
 #'
 #' @inheritParams module
 #' @param server_args (`named list`)\cr
 #'  Arguments passed to [teal.reporter::reporter_previewer_srv()].
-#' @return `teal_module` containing the `teal.reporter` previewer functionality
+#' @return `teal_module` (extended with `teal_module_previewer` class) containing the `teal.reporter` previewer
+#' functionality.
 #' @export
 reporter_previewer_module <- function(label = "Report previewer", server_args = list()) {
   checkmate::assert_string(label)
@@ -32,6 +33,7 @@ reporter_previewer_module <- function(label = "Report previewer", server_args =
     server = srv, ui = ui,
     server_args = server_args, ui_args = list(), datanames = NULL
   )
+  # Label 'Report previewer' is reserved in teal.
   class(module) <- c("teal_module_previewer", class(module))
   module$label <- label
   module

_pkgdown.yml

@@ -107,6 +107,9 @@ reference:
       - reporter_previewer_module
       - TealReportCard
       - report_card_template
+  - title: Landing Popup
+    contents:
+      - landing_popup_module
   - title: Functions for Module Developers
     contents:
       - tdata