812 landing popup

NEWS.md

@@ -7,6 +7,8 @@
 * 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.
+* Modules created with `module()` function are divided into specific classes: `"teal_module"`, `"teal_module_reporter"` 
+and `"teal_module_landing"`. Modules of class `"teal_module_landing"` will not be wrapped into tabs in the `teal` apps.
 
 # teal 0.14.0
 

R/init.R

@@ -46,6 +46,9 @@
 #'   See the vignette for an example. However, [ui_teal_with_splash()]
 #'   is then preferred to this function.
 #'
+#' @note If you pass a module of class `"teal_module_landing"` in `modules` parameter, `teal` will not create a tab for
+#' this module.
+#'
 #' @return named list with `server` and `ui` function
 #'
 #' @export
@@ -136,6 +139,10 @@ init <- function(data,
     modules <- do.call(teal::modules, modules)
   }
 
+  landing <- extract_module(modules, "teal_module_landing")
+  if (length(landing) > 1L) stop("teal only supports apps with one module of `tm_landing_popup` class.")
+  modules <- drop_module(modules, "teal_module_landing")
+
   # 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) > 0L) {
+        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/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

@@ -75,7 +75,7 @@ modules <- function(..., label = "root") {
     )
   }
 
-  checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_modules"))
+  checkmate::assert_list(submodules, min.len = 1, any.missing = FALSE, types = c("teal_module", "teal_module_reporter", "teal_module_landing", "teal_modules"))
   # name them so we can more easily access the children
   # beware however that the label of the submodules should not be changed as it must be kept synced
   labels <- vapply(submodules, function(submodule) submodule$label, character(1))
@@ -103,6 +103,37 @@ append_module <- function(modules, module) {
   modules
 }
 
+#' Extract specific class from a list of `modules`
+#' @param modules `teal_modules`
+#' @keywords internal
+#' @return `teal_module_landing`
+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))
+  }
+}
+
+#' Remove a specific class from list of `modules`
+#' @param modules `teal_modules`
+#' @keywords internal
+#' @return `teal_modules`
+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_landing)), label = modules$label)
+    )
+  }
+}
+
 #' Does the object make use of the `arg`
 #'
 #' @param modules (`teal_module` or `teal_modules`) object
@@ -155,6 +186,9 @@ is_arg_used <- function(modules, arg) {
 #'   `server` function.
 #' @param ui_args (named `list`) with additional arguments passed on to the
 #'   `ui` function.
+#' @param type (`character(1)`) The type of the class assigned to the final module. One of `"teal_module"`,
+#' `"teal_module_reporter"` or `"teal_module_landing"`. Modules of class `"teal_module_landing"` will not be wrapped
+#' into tabs in the `teal` application.
 #'
 #' @return object of class `teal_module`.
 #' @export
@@ -194,13 +228,15 @@ module <- function(label = "module",
                    filters,
                    datanames = "all",
                    server_args = NULL,
-                   ui_args = NULL) {
+                   ui_args = NULL,
+                   type = c("teal_module", "teal_module_reporter", "teal_module_landing")) {
   checkmate::assert_string(label)
   checkmate::assert_function(server)
   checkmate::assert_function(ui)
   checkmate::assert_character(datanames, min.len = 1, null.ok = TRUE, any.missing = FALSE)
   checkmate::assert_list(server_args, null.ok = TRUE, names = "named")
   checkmate::assert_list(ui_args, null.ok = TRUE, names = "named")
+  type <- match.arg(type)
 
   if (!missing(filters)) {
     checkmate::assert_character(filters, min.len = 1, null.ok = TRUE, any.missing = FALSE)
@@ -284,7 +320,7 @@ module <- function(label = "module",
       server = server, ui = ui, datanames = datanames,
       server_args = server_args, ui_args = ui_args
     ),
-    class = "teal_module"
+    class = type
   )
 }