[WIP] tm_a_kmeans module

NAMESPACE

@@ -10,6 +10,7 @@ S3method(create_sparklines,logical)
 S3method(create_sparklines,numeric)
 export(add_facet_labels)
 export(get_scatterplotmatrix_stats)
+export(tm_a_kmeans)
 export(tm_a_pca)
 export(tm_a_regression)
 export(tm_data_table)

R/tm_a_kmeans.R

@@ -0,0 +1,275 @@
+#' `teal` module: Scatterplot and k-means clustering
+#'
+#' Module for visualizing k-means clustering, including scatterplots and
+#' some clustering diagnostics plots. It allows users to identify clusters of similar observations
+#' in data, based on continuous variables. Module also displays summary statistics of the goodness
+#' of final clustering (within-cluster sum of squares).
+#'
+#' @note For more examples, please see the vignette "Using k-means clustering" via
+#' `vignette("using-kmeans-clustering", package = "teal.modules.general")`.
+#'
+#' @inheritParams teal::module
+#' @inheritParams shared_params
+#' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+#' Variables used for the creation of clusters with filtering and selecting.
+#' @param clusters (`integer(1)`) number of clusters.
+#' @param algorithm (`character(1)`) name of the clustering algorithm to be used. See more `stats::kmeans`.
+#' @param iter.max (`integer(1)`) maximum number of iterations allowed.
+#'
+#' @templateVar ggnames `r regression_names`
+#' @template ggplot2_args_multi
+#'
+#' @inherit shared_params return
+#'
+#' @examples
+#' # general data example
+#' library(teal.widgets)
+#'
+#' data <- teal_data()
+#' data <- within(data, {
+#'   iris <- iris
+#' })
+#' datanames(data) <- c("iris")
+#'
+#' app <- init(
+#'   data = data,
+#'   modules = modules(
+#'     tm_a_kmeans(
+#'       label = "k-means Clustering",
+#'       dat = data_extract_spec(
+#'         dataname = "iris",
+#'         select = select_spec(
+#'           label = "Select variables:",
+#'           choices = variable_choices(
+#'             data[["iris"]],
+#'             c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")
+#'           ),
+#'           selected = c("Sepal.Length", "Sepal.Width"),
+#'           multiple = TRUE,
+#'           fixed = FALSE
+#'         )
+#'       ),
+#'       ggplot2_args = ggplot2_args(
+#'         labs = list(subtitle = "Plot generated by k-means Module")
+#'       )
+#'     )
+#'   )
+#' )
+#' if (interactive()) {
+#'   shinyApp(app$ui, app$server)
+#' }
+#'
+#' @export
+#'
+tm_a_kmeans <- function(label = "k-means Clustering",
+                        dat,
+                        clusters = 3,
+                        algorithm = c("Hartigan-Wong", "Lloyd", "Forgy", "MacQueen"),
+                        iter.max = 10,
+                        plot_height = c(600, 200, 2000),
+                        plot_width = NULL,
+                        alpha = c(1, 0, 1),
+                        size = c(2, 1, 8),
+                        ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+                        ggplot2_args = teal.widgets::ggplot2_args(),
+                        pre_output = NULL,
+                        post_output = NULL) {
+  message("Initializing tm_a_kmeans")
+
+  # Normalize the parameters
+  if (inherits(dat, "data_extract_spec")) dat <- list(dat)
+  if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
+
+  # Start of assertions
+  checkmate::assert_string(label)
+  checkmate::assert_list(dat, types = "data_extract_spec")
+  checkmate::assert_numeric(clusters, lower = 1)
+
+  algorithm <- match.arg(algorithm)
+
+  checkmate::assert_numeric(iter.max, lower = 1)
+
+  checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+  checkmate::assert_numeric(plot_height[1],
+    lower = plot_height[2],
+    upper = plot_height[3],
+    .var.name = "plot_height"
+  )
+
+  checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+  checkmate::assert_numeric(plot_width[1],
+    lower = plot_width[2],
+    upper = plot_width[3],
+    null.ok = TRUE,
+    .var.name = "plot_width"
+  )
+
+  if (length(alpha) == 1) {
+    checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
+  } else {
+    checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
+    checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
+  }
+
+  if (length(size) == 1) {
+    checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
+  } else {
+    checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
+    checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
+  }
+
+  ggtheme <- match.arg(ggtheme)
+
+  checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
+  checkmate::assert_subset(names(ggplot2_args), c("default"))
+
+  checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+  checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+  # End of assertions
+
+  # Make UI args
+  args <- as.list(environment())
+
+  data_extract_list <- list(dat = dat)
+
+  ans <- module(
+    label = label,
+    server = srv_a_kmeans,
+    ui = ui_a_kmeans,
+    ui_args = args,
+    server_args = c(
+      data_extract_list,
+      list(
+        plot_height = plot_height,
+        plot_width = plot_width,
+        ggplot2_args = ggplot2_args
+      )
+    ),
+    datanames = teal.transform::get_extract_datanames(data_extract_list)
+  )
+  attr(ans, "teal_bookmarkable") <- FALSE
+  ans
+}
+
+# UI function for the k-means module
+ui_a_kmeans <- function(id, ...) {
+  ns <- NS(id)
+  args <- list(...)
+  is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)
+
+  tagList(
+    include_css_files("custom"),
+    teal.widgets::standard_layout(
+      output = teal.widgets::white_small_well(
+        uiOutput(ns("all_plots"))
+      ),
+      encoding = tags$div(
+        ### Reporter
+        teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+        ###
+        tags$label("Encodings", class = "text-primary"),
+        teal.transform::datanames_input(args["dat"]),
+        teal.transform::data_extract_ui(
+          id = ns("dat"),
+          label = "Data selection",
+          data_extract_spec = args$dat,
+          is_single_dataset = is_single_dataset_value
+        ),
+        teal.widgets::panel_group(
+          teal.widgets::panel_item(
+            title = "Display",
+            collapsed = FALSE,
+            checkboxGroupInput(
+              ns("tables_display"),
+              "Tables display",
+              choices = c("Cluster centers" = "centers", "Within cluster SS" = "withinss"),
+              selected = c("centers", "withinss")
+            )
+          ),
+          teal.widgets::panel_item(
+            title = "Setup",
+            numericInput(
+              ns("clusters"), "Clusters", value = args$clusters, min = 1, max = 20, step = 1
+            ),
+            selectInput(
+              ns("algorithm"), "Algorithm",
+              choices = c("Hartigan-Wong", "Lloyd", "Forgy", "MacQueen"),
+              selected = "Hartigan-Wong",
+              multiple = FALSE
+            ),
+            numericInput(
+              ns("iter.max"), "Max Iterations", value = args$iter.max, min = 1, max = 100, step = 1
+            ),
+          ),
+          teal.widgets::panel_item(
+            title = "Plot settings",
+            collapsed = TRUE,
+            teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+            teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+            selectInput(
+              inputId = ns("ggtheme"),
+              label = "Theme (by ggplot):",
+              choices = ggplot_themes,
+              selected = args$ggtheme,
+              multiple = FALSE
+            )
+          )
+        )
+      ),
+      forms = tagList(
+        teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+        teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+      ),
+      pre_output = args$pre_output,
+      post_output = args$post_output
+    )
+  )
+}
+
+# Server function for the k-means module
+srv_a_kmeans <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+  with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+  with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+  checkmate::assert_class(data, "reactive")
+  checkmate::assert_class(isolate(data()), "teal_data")
+  moduleServer(id, function(input, output, session) {
+
+    output_q <- reactive({
+      qenv <- teal.code::qenv()
+    })
+
+    teal.widgets::verbatim_popup_srv(
+      id = "warning",
+      verbatim_content = reactive(teal.code::get_warnings(output_q())),
+      title = "Warning",
+      disabled = reactive(is.null(teal.code::get_warnings(output_q())))
+    )
+
+    teal.widgets::verbatim_popup_srv(
+      id = "rcode",
+      verbatim_content = reactive(teal.code::get_code(output_q())),
+      title = "R Code for k-means"
+    )
+
+    ### REPORTER
+    if (with_reporter) {
+      card_fun <- function(comment, label) {
+        card <- teal::report_card_template(
+          title = "K-means Clustering",
+          label = label,
+          with_filter = with_filter,
+          filter_panel_api = filter_panel_api
+        )
+
+        if (!comment == "") {
+          card$append_text("Comment", "header3")
+          card$append_text(comment)
+        }
+        card$append_src(teal.code::get_code(output_q()))
+        card
+      }
+      teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+    }
+    ###
+  })
+}