feat: more details in the "New factor" modal

R/cut-variable-ext.R

@@ -21,13 +21,13 @@ cut_variable_ui <- function(id) {
     shiny::fluidRow(
       column(
         width = 3,
-        # shiny::uiOutput(outputId = ns("variable"))
+        shiny::uiOutput(outputId = ns("variable"))
-        shinyWidgets::virtualSelectInput(
+        # shinyWidgets::virtualSelectInput(
-          inputId = ns("variable"),
+        #   inputId = ns("variable"),
-          label = i18n$t("Variable to cut:"),
+        #   label = i18n$t("Variable to cut:"),
-          choices = NULL,
+        #   choices = NULL,
-          width = "100%"
+        #   width = "100%"
-        )
+        # )
       ),
       column(
         width = 3,
@@ -46,6 +46,9 @@ cut_variable_ui <- function(id) {
       ),
       column(
         width = 3,
+        shiny::conditionalPanel(
+          condition = "input.method != 'top' && input.method != 'bottom'",
+          ns = ns,
           checkboxInput(
             inputId = ns("right"),
             label = i18n$t("Close intervals on the right"),
@@ -57,6 +60,7 @@ cut_variable_ui <- function(id) {
             value = TRUE
           )
         )
+      )
     ),
     conditionalPanel(
       condition = "input.method == 'fixed'",
@@ -91,6 +95,8 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
     function(input, output, session) {
       rv <- reactiveValues(data = NULL, new_var_name = NULL)
 
+      ns <- session$ns
+
       bindEvent(observe({
         data <- data_r()
         rv$data <- data
@@ -99,21 +105,22 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
         }, logical(1))
         vars_num <- names(vars_num)[vars_num]
 
-        # shiny::renderUI(
+        output$variable <- shiny::renderUI(
-        # columnSelectInput(
+          columnSelectInput(
-        #   inputId = "variable",
+            inputId = ns("variable"),
-        #   data = data,
+            data = data,
-        #   label = i18n$t("Variable to cut:"),
+            label = i18n$t("Variable to cut:"),
-        #   width = "100%",
+            width = "100%",
-        #   choices = vars_num,
+            col_subset = vars_num,
-        #   selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
-        # ))
-
-        shinyWidgets::updateVirtualSelect(
-          inputId = "variable",
-          choices = vars_num,
             selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
           )
+        )
+
+        # shinyWidgets::updateVirtualSelect(
+        #   inputId = "variable",
+        #   choices = vars_num,
+        #   selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
+        # )
       }), data_r(), input$hidden)
 
       output$slider_fixed <- renderUI({
@@ -183,8 +190,8 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
         } else if ("factor" %in% class(data[[variable]])) {
           choices <- c(
             choices,
-            "top" # ,
+            "top",
-            # "bottom",
+            "bottom"
           )
         } else {
           choices <- c(
@@ -207,13 +214,28 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
 
         choices <- unique(choices)
 
-        shinyWidgets::virtualSelectInput(
+        ## Implement labeled vector selection of cut methods to include descriptions
-          inputId = session$ns("method"),
+        ##
+        ## cut_methods()
+        ##
+
+
+
+        vectorSelectInput(
+          inputId = ns("method"),
           label = i18n$t("Method:"),
-          choices = choices,
+          choices = names2val(get_list_elements(choices, "descr", dict = cut_methods())),
           selected = NULL,
           width = "100%"
         )
+
+        # shinyWidgets::virtualSelectInput(
+        #   inputId = session$ns("method"),
+        #   label = i18n$t("Method:"),
+        #   choices = choices,
+        #   selected = NULL,
+        #   width = "100%"
+        # )
       })
 
 
@@ -326,7 +348,13 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
         )
 
         if ("type" %in% names(breaks_r())) {
-          parameters <- modifyList(parameters, list(type = breaks_r()$type))
+          parameters <- modifyList(
+            parameters,
+            list(
+              type = breaks_r()$type,
+              other = i18n$t("Other")
+            )
+          )
         }
 
         new_variable <- tryCatch(
@@ -446,3 +474,105 @@ plot_histogram <- function(data, column = NULL, bins = 30, breaks = NULL, color
   abline(v = breaks, col = "#FFFFFF", lty = 1, lwd = 1.5)
   abline(v = breaks, col = "#2E2E2E", lty = 2, lwd = 1.5)
 }
+
+
+#### Helpers
+####
+####
+
+#' Library of cut methods with descriptions
+#'
+#' @returns vector
+#' @export
+#'
+cut_methods <- function() {
+  list(
+    "hour" = list(
+      descr = i18n$t("Hour of the day"),
+      # class = c("hms", "POSIXct"), # Not implemented yet, but will during rewrite at some point...
+      breaks = i18n$t("Breaks")
+    ),
+    "day" = list(
+      descr = i18n$t("By day of the week"),
+      breaks = i18n$t("Breaks")
+    ),
+    "weekday" = list(
+      descr = i18n$t("By weekday"),
+      breaks = i18n$t("Breaks")
+    ),
+    "week" = list(
+      descr = i18n$t("By week number and year"),
+      breaks = i18n$t("Breaks")
+    ),
+    "week_only" = list(
+      descr = i18n$t("By week number"),
+      breaks = i18n$t("Breaks")
+    ),
+    "month" = list(
+      descr = i18n$t("By month and year"),
+      breaks = i18n$t("Breaks")
+    ),
+    "month_only" = list(
+      descr = i18n$t("By month only"),
+      breaks = i18n$t("Breaks")
+    ),
+    "quarter" = list(
+      descr = i18n$t("By quarter of the year"),
+      breaks = i18n$t("Breaks")
+    ),
+    "year" = list(
+      descr = i18n$t("By year"),
+      breaks = i18n$t("Breaks")
+    ),
+    "top" = list(
+      descr = i18n$t("Keep only most common"),
+      breaks = i18n$t("Number")
+    ),
+    "bottom" = list(
+      descr = i18n$t("Combine below percentage"),
+      breaks = i18n$t("Percentage")
+    ),
+    "fixed" = list(
+      descr = i18n$t("By specified numbers"),
+      breaks = i18n$t("Breaks")
+    ),
+    "quantile" = list(
+      descr = i18n$t("By quantiles (groups of equal size)"),
+      breaks = i18n$t("Breaks")
+    )
+  )
+}
+
+#' Subset elements from list of lists
+#'
+#' @description
+#' General function to sub-setting details stored in list dictionaries.
+#'
+#'
+#' @param name list name to lookup
+#' @param element element to get
+#' @param dict dictionary to use
+#'
+#' @returns named vector
+#' @export
+#'
+#' @examples
+#' get_list_elements(c("top", "bottom"), "descr")
+get_list_elements <- function(name, element, dict = cut_methods()) {
+  sapply(dict[name], \(.x){
+    .x[[element]]
+  })
+}
+
+#' Set values as names and names as values
+#'
+#' @param data data
+#'
+#' @returns named vector
+#' @export
+#'
+#' @examples
+#' names2val(c("Cylinders" = "cyl", "Transmission" = "am", "Gears" = "gear"))
+names2val <- function(data) {
+  setNames(names(data), data)
+}

R/cut_var.R

@@ -167,6 +167,11 @@ cut_var.Date <- function(x, breaks = NULL, start.on.monday = TRUE, ...) {
 #'   as.factor() |>
 #'   cut_var(2) |>
 #'   table()
+#'
+#' mtcars$carb |>
+#'   as.factor() |>
+#'   cut_var(20, "bottom") |>
+#'   table()
 cut_var.factor <- function(x, breaks = NULL, type = c("top", "bottom"), other = "Other", ...) {
   args <- list(...)
 
@@ -176,10 +181,12 @@ cut_var.factor <- function(x, breaks = NULL, type = c("top", "bottom"), other =
 
   type <- match.arg(type)
 
+  tbl <- sort(table(x), decreasing = TRUE)
+
   if (type == "top") {
-    lvls <- names(sort(table(x), decreasing = TRUE)[seq_len(breaks)])
+    lvls <- names(tbl[seq_len(breaks)])
   } else if (type == "bottom") {
-    lvls <- names(sort(table(x), decreasing = FALSE)[seq_len(breaks)])
+    lvls <- names(tbl)[!tbl / NROW(x) * 100 < breaks]
   }
 
   if (other %in% lvls) {