Introducing spiderplot/swimlane/waterfall modules

DESCRIPTION

@@ -32,6 +32,7 @@ Depends:
 Imports:
     bslib (>= 0.8.0),
     checkmate (>= 2.1.0),
+    colorspace,
     colourpicker (>= 1.3.0),
     dplyr (>= 1.0.5),
     DT (>= 0.13),
@@ -42,13 +43,20 @@ Imports:
     ggpp (>= 0.5.8-1),
     ggrepel (>= 0.9.6),
     goftest (>= 1.2-3),
+    graphics,
+    grDevices,
     grid,
     gridExtra (>= 2.3),
+    htmltools,
     htmlwidgets (>= 1.6.4),
     jsonlite (>= 1.8.9),
     lattice (>= 0.18-4),
     lifecycle (>= 0.2.0),
     MASS (>= 7.3-60),
+    plotly,
+    reactable,
+    rlang (>= 1.0.0),
+    rmarkdown (>= 2.23),
     rtables (>= 0.6.11),
     scales (>= 1.3.0),
     shinyjs (>= 2.1.0),
@@ -73,8 +81,6 @@ Suggests:
     logger (>= 0.2.0),
     nestcolor (>= 0.1.0),
     pkgload,
-    rlang (>= 1.0.0),
-    rmarkdown (>= 2.23),
     roxy.shinylive,
     rvest,
     shinytest2,

NAMESPACE

@@ -10,6 +10,8 @@ S3method(create_sparklines,logical)
 S3method(create_sparklines,numeric)
 export(add_facet_labels)
 export(get_scatterplotmatrix_stats)
+export(spiderplotly)
+export(swimlanely)
 export(tm_a_pca)
 export(tm_a_regression)
 export(tm_data_table)
@@ -21,14 +23,21 @@ export(tm_g_distribution)
 export(tm_g_response)
 export(tm_g_scatterplot)
 export(tm_g_scatterplotmatrix)
+export(tm_g_spiderplot)
+export(tm_g_swimlane)
+export(tm_g_waterfall)
 export(tm_missing_data)
 export(tm_outliers)
+export(tm_rmarkdown)
 export(tm_t_crosstable)
+export(tm_t_reactables)
 export(tm_variable_browser)
+export(waterfally)
 import(ggmosaic)
 import(ggplot2)
 import(shiny)
 import(teal)
 import(teal.transform)
 importFrom(dplyr,"%>%")
 importFrom(lifecycle,deprecated)
+importFrom(rlang,":=")

R/module_colur_picker.R

@@ -0,0 +1,129 @@
+# todo: to teal widgets?
+
+colour_picker_ui <- function(id) {
+  ns <- NS(id)
+  bslib::accordion(
+    uiOutput(ns("module"), title = "Event colors:", container = bslib::accordion_panel),
+    open = FALSE
+  )
+}
+
+colour_picker_srv <- function(id, x, default_colors) {
+  moduleServer(id, function(input, output, session) {
+    default_colors_adjusted <- reactive({
+      req(x())
+      .color_palette_discrete(
+        levels = unique(x()),
+        color = default_colors
+      )
+    })
+
+    color_values <- reactiveVal()
+    observeEvent(default_colors_adjusted(), {
+      if (!identical(default_colors_adjusted(), color_values())) {
+        color_values(default_colors_adjusted())
+      }
+    })
+
+    output$module <- renderUI({
+      tagList(
+        lapply(
+          names(color_values()),
+          function(level) {
+            div(
+              colourpicker::colourInput(
+                inputId = session$ns(.name_to_id(level)),
+                label = level,
+                value = color_values()[level]
+              )
+            )
+          }
+        )
+      )
+    })
+
+    color_input_values <- reactiveVal()
+    observe({
+      req(color_values())
+      new_input_values <- sapply(names(color_values()), function(level) {
+        c(input[[.name_to_id(level)]], color_values()[[level]])[1]
+      })
+      if (!identical(new_input_values, isolate(color_input_values()))) {
+        isolate(color_input_values(new_input_values))
+      }
+    })
+
+    color_input_values
+  })
+}
+
+
+
+#' Color palette discrete
+#'
+#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by
+#' levels of variable used for coloring. This function allows to specify only some or none of the colors/levels
+#' as the rest will be filled automatically.
+#' @param levels (`character`) values of possible variable levels
+#' @param color (`named character`) valid color names (see [colors()]) or hex-colors named by `levels`.
+#' @return `character` with hex colors named by `levels`.
+.color_palette_discrete <- function(levels, color) {
+  p <- color[names(color) %in% levels]
+
+  if (length(p) > 0) {
+    p_rgb_num <- grDevices::col2rgb(p)
+    p_hex <- grDevices::rgb(p_rgb_num[1, ] / 255, p_rgb_num[2, ] / 255, p_rgb_num[3, ] / 255)
+    p <- stats::setNames(p_hex, names(p))
+  }
+
+  missing_levels <- setdiff(levels, names(p))
+  N <- length(levels)
+  n <- length(p)
+  m <- N - n
+
+  if (m > 0 && n > 0) {
+    all_colors <- colorspace::qualitative_hcl(N)
+
+    if (n == 1) {
+      current_color_hsv <- grDevices::rgb2hsv(grDevices::col2rgb(p))
+      all_colors_hsv <- grDevices::rgb2hsv(grDevices::col2rgb(all_colors))
+
+      distances <- numeric(length(all_colors))
+      for (i in seq_along(all_colors)) {
+        h_diff <- min(
+          abs(current_color_hsv[1] - all_colors_hsv[1, i]),
+          1 - abs(current_color_hsv[1] - all_colors_hsv[1, i])
+        )
+        s_diff <- abs(current_color_hsv[2] - all_colors_hsv[2, i])
+        v_diff <- abs(current_color_hsv[3] - all_colors_hsv[3, i])
+        distances[i] <- sqrt(h_diff^2 + s_diff^2 + v_diff^2)
+      }
+
+      idx <- order(distances, decreasing = TRUE)[seq_len(m)]
+      missing_colors <- all_colors[idx]
+    } else {
+      remaining_colors <- all_colors[seq_len(m)]
+      missing_colors <- remaining_colors
+    }
+
+    p <- c(p, stats::setNames(missing_colors, missing_levels))
+  } else if (m > 0) {
+    missing_colors <- colorspace::qualitative_hcl(m)
+    p <- stats::setNames(missing_colors, missing_levels)
+  }
+
+  result <- p[match(levels, names(p))]
+  stats::setNames(result, levels)
+}
+
+
+.shape_palette_discrete <- function(levels, symbol) {
+  if (length(symbol) == 0) {
+    s <- rep("circle-open", length(levels))
+    s <- stats::setNames(s, levels)
+  } else {
+    s <- stats::setNames(symbol[levels], levels)
+    s[is.na(s)] <- "circle-open"
+  }
+  s
+}

R/plotly_with_settings.R

@@ -0,0 +1,10 @@
+plotly_with_settings_ui <- function(id, height) {
+  ns <- NS(id)
+  plotly::plotlyOutput(ns("plot"), height = height)
+}
+
+plotly_with_settings_srv <- function(id, plot) {
+  moduleServer(id, function(input, output, session) {
+    output$plot <- plotly::renderPlotly(plot())
+  })
+}

R/roxygen2_templates.R

@@ -14,3 +14,55 @@ roxygen_ggplot2_args_param <- function(...) {
 }
 
 # nocov end
+
+#' Shared parameters documentation
+#'
+#' Defines common arguments shared across multiple functions in the package
+#' to avoid repetition by using `inheritParams`.
+#'
+#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
+#' `value`, `min`, and `max` intended for use with a slider UI element.
+#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
+#' `value`, `min`, and `max` for a slider encoding the plot width.
+#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
+#' rotate by default (`FALSE`).
+#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
+#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
+#' with settings for the module plot.
+#' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
+#'
+#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
+#' with settings for the module table.
+#' The argument is merged with options variable `teal.basic_table_args` and default module setup.
+#'
+#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
+#' providing context or a title.
+#'  with text placed before the output to put the output into context. For example a title.
+#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
+#' adding context or further instructions. Elements like `shiny::helpText()` are useful.
+#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
+#' - When the length of `alpha` is one: the plot points will have a fixed opacity.
+#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
+#' vector of `value`, `min`, and `max`.
+#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
+#' - When the length of `size` is one: the plot point sizes will have a fixed size.
+#' - When the length of `size` is three: the plot points size are dynamically adjusted based on
+#' vector of `value`, `min`, and `max`.
+#' @param decorators `r lifecycle::badge("experimental")`
+#' (named `list` of lists of `teal_transform_module`) optional,
+#' decorator for tables or plots included in the module output reported.
+#' The decorators are applied to the respective output objects.
+#'
+#' @param table_datanames (`character`) names of the datasets which should be listed below the plot
+#'  when some data points are selected. Objects named after `table_datanames` will be pulled from
+#'  `data` so it is important that data actually contains these datasets. Please be aware that
+#'  table datasets must be linked with `plot_dataname` by the relevant [join_keys()].
+#' See section "Decorating Module" below for more details.
+#'
+#' @return Object of class `teal_module` to be used in `teal` applications.
+#'
+#' @name shared_params
+#' @keywords internal
+NULL