new missings module and function for plotting

R/missings-module.R

@@ -9,8 +9,7 @@ data_missings_ui <- function(id) {
   ns <- shiny::NS(id)
 
   shiny::tagList(
-    gt::gt_output(outputId = ns("missings_table")),
-    shiny::plotOutput(outputId = ns("missings_plot"))
+    gt::gt_output(outputId = ns("missings_table"))
   )
 }
 
@@ -24,20 +23,56 @@ data_missings_ui <- function(id) {
 #' @export
 data_missings_server <- function(id,
                                  data,
+                                 variable,
                                  ...) {
   shiny::moduleServer(
     id = id,
     module = function(input, output, session) {
       # ns <- session$ns
 
+      datar <- if (is.reactive(data)) data else reactive(data)
+      variabler <- if (is.reactive(variable)) variable else reactive(variable)
+
       rv <- shiny::reactiveValues(
         data = NULL
       )
 
-      rv$data <- if (is.reactive(data)) data else reactive(data)
+      rv$data <- shiny::reactive({
+        df_tbl <- datar()
+        by_var <- variabler()
 
-      output$missings_plot <- shiny::renderPlot({
-        visdat::vis_dat(rv$data(),palette = "cb_safe")
+        tryCatch(
+          {
+            if (!is.null(by_var) && by_var != "" && by_var %in% names(df_tbl)) {
+              df_tbl[[by_var]] <- ifelse(is.na(df_tbl[[by_var]]), "Missing", "Non-missing")
+
+              out <- gtsummary::tbl_summary(df_tbl, by = by_var) |>
+                gtsummary::add_p()
+            } else {
+              out <- gtsummary::tbl_summary(df_tbl)
+            }
+          },
+          error = function(err) {
+            showNotification(paste0("Error: ", err), type = "err")
+          }
+        )
+
+        out
+      })
+
+      output$missings_table <- gt::render_gt({
+        shiny::req(datar)
+        shiny::req(variabler)
+
+        if (is.null(variabler()) || variabler() == "" || !variabler() %in% names(datar())) {
+          title <- "No missing observations"
+        } else {
+          title <- paste("Missing vs non-missing observations in", variabler())
+        }
+
+        rv$data() |>
+          gtsummary::as_gt() |>
+          gt::tab_header(title = gt::md(title))
       })
     }
   )
@@ -51,17 +86,24 @@ missing_demo_app <- function() {
       label = "Browse data",
       width = "100%",
       disabled = FALSE
-    )#,
-    # data_missings_ui("data")
+    ),
+    shiny::selectInput(
+      inputId = "missings_var",
+      label = "Select variable to stratify analysis", choices = c("cyl", "vs")
+    ),
+    data_missings_ui("data")
   )
   server <- function(input, output, session) {
     data_demo <- mtcars
-    data_demo[2:4, "cyl"] <- NA
+    data_demo[sample(1:32, 10), "cyl"] <- NA
+    data_demo[sample(1:32, 8), "vs"] <- NA
+
+    data_missings_server(id = "data", data = data_demo, variable = shiny::reactive(input$missings_var))
 
     observeEvent(input$modal_missings, {
       tryCatch(
         {
-          modal_data_missings(data = data_demo, id = "modal_missings")
+          modal_visual_missings(data = data_demo, id = "modal_missings")
         },
         error = function(err) {
           showNotification(paste0("We encountered the following error browsing your data: ", err), type = "err")
@@ -75,20 +117,22 @@ missing_demo_app <- function() {
 missing_demo_app()
 
 
-modal_data_missings <- function(data,
-                                title = "Show missing pattern",
+modal_visual_missings <- function(data,
+                                  title = "Visual overview of data classes and missing observations",
                                   easyClose = TRUE,
                                   size = "xl",
                                   footer = NULL,
                                   ...) {
-
   datar <- if (is.reactive(data)) data else reactive(data)
 
   showModal(modalDialog(
     title = tagList(title, datamods:::button_close_modal()),
     tags$div(
+      # apexcharter::renderApexchart({
+      #   missings_apex_plot(datar(), ...)
+      # })
       shiny::renderPlot({
-        visdat::vis_dat(datar())+
+        visdat::vis_dat(datar(),sort_type = FALSE) +
           ggplot2::guides(fill = ggplot2::guide_legend(title = "Data class")) +
           # ggplot2::theme_void() +
           ggplot2::theme(
@@ -97,7 +141,7 @@ modal_data_missings <- function(data,
             panel.grid.minor = ggplot2::element_blank(),
             # axis.text.y = element_blank(),
             # axis.title.y = element_blank(),
-            text = ggplot2::element_text(size = 15),
+            text = ggplot2::element_text(size = 18),
             # axis.text = ggplot2::element_blank(),
             # panel.background = ggplot2::element_rect(fill = "white"),
             # plot.background = ggplot2::element_rect(fill = "white"),
@@ -111,3 +155,99 @@ modal_data_missings <- function(data,
     footer = footer
   ))
 }
+
+
+## Slow with many observations...
+
+#' Plot missings and class with apexcharter
+#'
+#' @param data data frame
+#'
+#' @returns An [apexchart()] `htmlwidget` object.
+#' @export
+#'
+#' @examples
+#' data_demo <- mtcars
+#' data_demo[2:4, "cyl"] <- NA
+#' rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot()
+#' data_demo |> missings_apex_plot()
+#' mtcars |> missings_apex_plot(animation = TRUE)
+#' # dplyr::storms |> missings_apex_plot()
+#' visdat::vis_dat(dplyr::storms)
+missings_apex_plot <- function(data, animation = FALSE, ...) {
+  browser()
+
+  df_plot <- purrr::map_df(data, \(x){
+    ifelse(is.na(x),
+      yes = NA,
+      no = glue::glue_collapse(class(x),
+        sep = "\n"
+      )
+    )
+  }) %>%
+    dplyr::mutate(rows = dplyr::row_number()) %>%
+    tidyr::pivot_longer(
+      cols = -rows,
+      names_to = "variable", values_to = "valueType", values_transform = list(valueType = as.character)
+    ) %>%
+    dplyr::arrange(rows, variable, valueType)
+
+
+  df_plot$valueType_num <- df_plot$valueType |>
+    forcats::as_factor() |>
+    as.numeric()
+
+
+  df_plot$valueType[is.na(df_plot$valueType)] <- "NA"
+  df_plot$valueType_num[is.na(df_plot$valueType_num)] <- max(df_plot$valueType_num, na.rm = TRUE) + 1
+
+  labels <- setNames(unique(df_plot$valueType_num), unique(df_plot$valueType))
+
+  if (any(df_plot$valueType == "NA")) {
+    colors <- setNames(c(viridisLite::viridis(n = length(labels) - 1), "#999999"), names(labels))
+  } else {
+    colors <- setNames(viridisLite::viridis(n = length(labels)), names(labels))
+  }
+
+
+  label_list <- labels |>
+    purrr::imap(\(.x, .i){
+      list(
+        from = .x,
+        to = .x,
+        color = colors[[.i]],
+        name = .i
+      )
+    }) |>
+    setNames(NULL)
+
+  out <- apexcharter::apex(
+    data = df_plot,
+    type = "heatmap",
+    mapping = apexcharter::aes(x = variable, y = rows, fill = valueType_num),
+    ...
+  ) %>%
+    apexcharter::ax_stroke(width = NULL) |>
+    apexcharter::ax_plotOptions(
+      heatmap = apexcharter::heatmap_opts(
+        radius = 0,
+        enableShades = FALSE,
+        colorScale = list(
+          ranges = label_list
+        ),
+        useFillColorAsStroke = TRUE
+      )
+    ) %>%
+    apexcharter::ax_dataLabels(enabled = FALSE) |>
+    apexcharter::ax_tooltip(
+      enabled = FALSE,
+      intersect = FALSE
+    )
+
+  if (!isTRUE(animation)) {
+    out <- out |>
+      apexcharter::ax_chart(animations = list(enabled = FALSE))
+  }
+
+  out
+}

man/data-missings.Rd

@@ -8,7 +8,7 @@
 \usage{
 data_missings_ui(id)
 
-data_missings_server(id, data, ...)
+data_missings_server(id, data, variable, ...)
 }
 \arguments{
 \item{id}{Module id}

man/missings_apex_plot.Rd

@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/missings-module.R
+\name{missings_apex_plot}
+\alias{missings_apex_plot}
+\title{Plot missings and class with apexcharter}
+\usage{
+missings_apex_plot(data, animation = FALSE, ...)
+}
+\arguments{
+\item{data}{data frame}
+}
+\value{
+An \code{\link[=apexchart]{apexchart()}} \code{htmlwidget} object.
+}
+\description{
+Plot missings and class with apexcharter
+}
+\examples{
+data_demo <- mtcars
+data_demo[2:4, "cyl"] <- NA
+rbind(data_demo, data_demo, data_demo, data_demo) |> missings_apex_plot()
+data_demo |> missings_apex_plot()
+mtcars |> missings_apex_plot(animation = TRUE)
+# dplyr::storms |> missings_apex_plot()
+visdat::vis_dat(dplyr::storms)
+}