812 landing popup (#934)

This resolves #812 

CC @lcd2yyz  

This is just a frontend proposition for the landing page functionality.
This could be used to present a welcome statement or a disclaimer that
requires a consent. Below is a code for the simple teal app that starts
with a landing page specification.

Currently this PR is build upon `shinyalert::shinyalert` function, but
once this is accepted I will take out just the ingredients out of this
functions and put in teal so that we don't need to include another
dependency in `teal` package.

A user is able to customize the landing page with `title` (1), `text`
(2) and `button` (3) parameters of `langing` list argument in
`teal::init`


![image](https://github.com/insightsengineering/teal/assets/133694481/6bb33779-0cca-4f3c-a32e-8f171c00430c)

<details><summary>R code</summary>
```r
new_iris <- transform(iris, id = seq_len(nrow(iris)))
new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))

app <- init(
  data = teal_data(
    dataset("new_iris", new_iris),
    dataset("new_mtcars", new_mtcars),
    code = "
      new_iris <- transform(iris, id = seq_len(nrow(iris)))
      new_mtcars <- transform(mtcars, id = seq_len(nrow(mtcars)))
    "
  ),
  modules = modules(
    module(
      label = "data source",
      server = function(input, output, session, data) {},
      ui = function(id, ...) div(p("information about data source")),
      datanames = "all"
    ),
    example_module(label = "example teal module"),
    module(
      "Iris Sepal.Length histogram",
      server = function(input, output, session, data) {
        output$hist <- renderPlot(
          hist(data[["new_iris"]]()$Sepal.Length)
        )
      },
      ui = function(id, ...) {
        ns <- NS(id)
        plotOutput(ns("hist"))
      },
      datanames = "new_iris"
    )
  ),
  title = "App title",
  filter = teal_slices(
    teal_slice(dataname = "new_iris", varname = "Species"),
    teal_slice(dataname = "new_iris", varname = "Sepal.Length"),
    teal_slice(dataname = "new_mtcars", varname = "cyl"),
    exclude_varnames = list(new_iris = c("Sepal.Width", "Petal.Width")),
    mapping = list(
      `example teal module` = "new_iris Species",
      `Iris Sepal.Length histogram` = "new_iris Species",
      global_filters = "new_mtcars cyl"
    )
  ),
  header = tags$h1("Sample App"),
  footer = tags$p("Copyright 2017 - 2023"),
  landing = list(
    title = 'Disclaimer',
    text = 'By agreeing to this statement you confirm you accept A, B and C.',
    button = 'Agree'
  )
)
if (interactive()) {
  shinyApp(app$ui, app$server)
}
```
</details>

---------

Signed-off-by: Marcin <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
Co-authored-by: Aleksander Chlebowski <[email protected]>
Co-authored-by: Pawel Rucki <[email protected]>
Co-authored-by: Dawid Kałędkowski <[email protected]>

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.
+* Added `landing_popup_module` function which creates a module that will display a popup when the app starts. The popup will block access to the app until it is dismissed.
 
 # teal 0.14.0
 

R/init.R

@@ -136,6 +136,10 @@ 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")
+
   # resolve modules datanames
   datanames <- teal.data::get_dataname(data)
   join_keys <- data$get_join_keys()
@@ -223,6 +227,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,88 @@
+#' Landing Popup Module
+#'
+#' @description Creates a landing welcome popup for `teal` applications.
+#'
+#' This module is used to display a popup dialog when the application starts.
+#' The dialog blocks the access to the application and must be closed with a button before the application is viewed.
+#'
+#' @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 list of `shiny.tag`s. 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")
+#'     ),
+#'     example_module()
+#'   )
+#' )
+#' 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("read", "Read more",
+#'           onclick = "window.open('http://google.com', '_blank')"
+#'         ),
+#'         actionButton("close", "Reject", onclick = "window.close()")
+#'       )
+#'     ),
+#'     example_module()
+#'   )
+#' )
+#'
+#' if (interactive()) {
+#'   shinyApp(app2$ui, app2$server)
+#' }
+#'
+#' @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
+#' Append a `teal_module` to `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,43 @@ 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`, the opposite, which is all `teal_modules` of  class other than `class`.
+#' @rdname module_management
+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 module_management
+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,18 +7,21 @@
 #'
 #' 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)
   checkmate::assert_list(server_args, names = "named")
   checkmate::assert_true(all(names(server_args) %in% names(formals(teal.reporter::reporter_previewer_srv))))
 
+  logger::log_info("Initializing reporter_previewer_module")
+
   srv <- function(id, reporter, ...) {
     teal.reporter::reporter_previewer_srv(id, reporter, ...)
   }
@@ -32,6 +35,8 @@ reporter_previewer_module <- function(label = "Report previewer", server_args =
     server = srv, ui = ui,
     server_args = server_args, ui_args = list(), datanames = NULL
   )
+  # Module is created with a placeholder label and the label is changed later.
+  # This is to prevent another module being labeled "Report previewer".
   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