Added update factors module

DESCRIPTION

@@ -47,6 +47,7 @@ Imports:
     writexl
 Suggests: 
     bslib,
+    ggplot2,
     jsonlite,
     knitr,
     MASS,

NAMESPACE

@@ -28,12 +28,15 @@ export(list_allowed_operations)
 export(list_pkg_data)
 export(modal_create_column)
 export(modal_cut_variable)
+export(modal_update_factor)
 export(sample_server)
 export(sample_ui)
 export(select_group_server)
 export(select_group_ui)
 export(set_i18n)
 export(show_data)
+export(update_factor_server)
+export(update_factor_ui)
 export(update_variables_server)
 export(update_variables_ui)
 export(validation_server)
@@ -142,6 +145,7 @@ importFrom(shiny,tabPanel)
 importFrom(shiny,tabPanelBody)
 importFrom(shiny,tableOutput)
 importFrom(shiny,tabsetPanel)
+importFrom(shiny,tagList)
 importFrom(shiny,tags)
 importFrom(shiny,textAreaInput)
 importFrom(shiny,textInput)
@@ -174,6 +178,7 @@ importFrom(shinybusy,notify_warning)
 importFrom(stats,setNames)
 importFrom(tibble,as_tibble)
 importFrom(toastui,datagrid)
+importFrom(toastui,datagridOutput)
 importFrom(toastui,datagridOutput2)
 importFrom(toastui,grid_colorbar)
 importFrom(toastui,grid_columns)
@@ -182,6 +187,7 @@ importFrom(toastui,grid_editor_opts)
 importFrom(toastui,grid_format)
 importFrom(toastui,grid_selection_row)
 importFrom(toastui,grid_style_column)
+importFrom(toastui,renderDatagrid)
 importFrom(toastui,renderDatagrid2)
 importFrom(tools,file_ext)
 importFrom(utils,data)

R/update-factor.R

@@ -0,0 +1,233 @@
+
+#' @title Module to Reorder the Levels of a Factor Variable
+#'
+#' @description
+#' This module contain an interface to reorder the levels of a factor variable.
+#'
+#'
+#' @param id Module ID.
+#'
+#' @return A [shiny::reactive()] function returning the data.
+#' @export
+#'
+#' @importFrom shiny NS fluidRow tagList column actionButton
+#' @importFrom shinyWidgets virtualSelectInput prettyCheckbox
+#' @importFrom toastui datagridOutput
+#' @importFrom htmltools tags
+#'
+#' @name update-factor
+#'
+#' @example examples/update_factor.R
+update_factor_ui <- function(id) {
+  ns <- NS(id)
+  tagList(
+    tags$style(
+      ".tui-grid-row-header-draggable span {width: 3px !important; height: 3px !important;}"
+    ),
+    fluidRow(
+      column(
+        width = 6,
+        virtualSelectInput(
+          inputId = ns("variable"),
+          label = "Factor variable to reorder:",
+          choices = NULL,
+          width = "100%",
+          zIndex = 50
+        )
+      ),
+      column(
+        width = 3,
+        class = "d-flex align-items-end",
+        actionButton(
+          inputId = ns("sort_levels"),
+          label = tagList(
+            ph("sort-ascending"),
+            "Sort levels"
+          ),
+          class = "btn-outline-primary mb-3",
+          width = "100%"
+        )
+      ),
+      column(
+        width = 3,
+        class = "d-flex align-items-end",
+        actionButton(
+          inputId = ns("sort_occurrences"),
+          label = tagList(
+            ph("sort-ascending"),
+            "Sort count"
+          ),
+          class = "btn-outline-primary mb-3",
+          width = "100%"
+        )
+      )
+    ),
+    datagridOutput(ns("grid")),
+    tags$div(
+      class = "float-end",
+      prettyCheckbox(
+        inputId = ns("new_var"),
+        label = i18n("Create a new variable"),
+        value = FALSE,
+        status = "primary",
+        outline = TRUE,
+        inline = TRUE
+      ),
+      actionButton(
+        inputId = ns("create"),
+        label = tagList(ph("arrow-clockwise"), "Update factor variable"),
+        class = "btn-outline-primary"
+      )
+    ),
+    tags$div(class = "clearfix")
+  )
+}
+
+
+#' @param data_r A [shiny::reactive()] function returning a `data.frame`.
+#'
+#' @export
+#'
+#' @importFrom shiny moduleServer observeEvent reactive reactiveValues req bindEvent isTruthy updateActionButton
+#' @importFrom shinyWidgets updateVirtualSelect
+#' @importFrom toastui renderDatagrid datagrid grid_columns grid_colorbar
+#'
+#' @rdname update-factor
+update_factor_server <- function(id, data_r = reactive(NULL)) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+
+      rv <- reactiveValues(data = NULL, data_grid = NULL)
+
+      bindEvent(observe({
+        data <- data_r()
+        rv$data <- data
+        vars_factor <- vapply(data, is.factor, logical(1))
+        vars_factor <- names(vars_factor)[vars_factor]
+        updateVirtualSelect(
+          inputId = "variable",
+          choices = vars_factor,
+          selected = if (isTruthy(input$variable)) input$variable else vars_factor[1]
+        )
+      }), data_r(), input$hidden)
+
+      observeEvent(input$variable, {
+        data <- req(data_r())
+        variable <- req(input$variable)
+        grid <- as.data.frame(table(data[[variable]]))
+        rv$data_grid <- grid
+      })
+
+      observeEvent(input$sort_levels, {
+        if (input$sort_levels %% 2 == 1) {
+          decreasing <- FALSE
+          label <- tagList(
+            ph("sort-descending"),
+            "Sort Levels"
+          )
+        } else {
+          decreasing <- TRUE
+          label <- tagList(
+            ph("sort-ascending"),
+            "Sort Levels"
+          )
+        }
+        updateActionButton(inputId = "sort_levels", label = as.character(label))
+        rv$data_grid <- rv$data_grid[order(rv$data_grid[[1]], decreasing = decreasing), ]
+      })
+
+      observeEvent(input$sort_occurrences, {
+        if (input$sort_occurrences %% 2 == 1) {
+          decreasing <- FALSE
+          label <- tagList(
+            ph("sort-descending"),
+            "Sort count"
+          )
+        } else {
+          decreasing <- TRUE
+          label <- tagList(
+            ph("sort-ascending"),
+            "Sort count"
+          )
+        }
+        updateActionButton(inputId = "sort_occurrences", label = as.character(label))
+        rv$data_grid <- rv$data_grid[order(rv$data_grid[[2]], decreasing = decreasing), ]
+      })
+
+
+      output$grid <- renderDatagrid({
+        req(rv$data_grid)
+        grid <- datagrid(
+          data = rv$data_grid,
+          draggable = TRUE,
+          sortable = FALSE,
+          data_as_input = TRUE
+        )
+        grid <- grid_columns(
+          grid,
+          columns = c("Var1", "Freq"),
+          header = c("Levels", "Count")
+        )
+        grid <- grid_colorbar(
+          grid,
+          column = "Freq",
+          label_outside = TRUE,
+          label_width = "30px",
+          background = "#D8DEE9",
+          from = c(0, max(rv$data_grid$Freq) + 1)
+        )
+        grid
+      })
+
+      data_updated_r <- reactive({
+        data <- req(data_r())
+        variable <- req(input$variable)
+        grid <- req(input$grid_data)
+        name_var <- if (isTRUE(input$new_var)) {
+          paste0(variable, "_updated")
+        } else {
+          variable
+        }
+        data[[name_var]] <- factor(
+          as.character(data[[variable]]),
+          levels = grid[["Var1"]]
+        )
+        data
+      })
+
+      data_returned_r <- observeEvent(input$create, {
+        rv$data <- data_updated_r()
+      })
+      return(reactive(rv$data))
+    }
+  )
+}
+
+
+
+#' @inheritParams shiny::modalDialog
+#' @export
+#'
+#' @importFrom shiny showModal modalDialog textInput
+#' @importFrom htmltools tagList
+#'
+#' @rdname update-factor
+modal_update_factor <- function(id,
+                                title = "Update levels of a factor",
+                                easyClose = TRUE,
+                                size = "l",
+                                footer = NULL) {
+  ns <- NS(id)
+  showModal(modalDialog(
+    title = tagList(title, button_close_modal()),
+    update_factor_ui(id),
+    tags$div(
+      style = "display: none;",
+      textInput(inputId = ns("hidden"), label = NULL, value = genId())
+    ),
+    easyClose = easyClose,
+    size = size,
+    footer = footer
+  ))
+}

examples/update_factor.R

@@ -0,0 +1,68 @@
+
+library(shiny)
+library(datamods)
+library(ggplot2)
+
+ui <- fluidPage(
+  theme = bslib::bs_theme(version = 5L, preset = "bootstrap"),
+  tags$h2("Reorder the Levels of a Factor"),
+  fluidRow(
+    column(
+      width = 6,
+      update_factor_ui("id"),
+      actionButton("modal", "Or click here to open a modal to update factor's level")
+    ),
+    column(
+      width = 6,
+      selectInput(
+        "var",
+        label = "Variable to plot:",
+        choices = NULL
+      ),
+      plotOutput("plot"),
+      verbatimTextOutput("res")
+    )
+  )
+)
+
+server <- function(input, output, session) {
+
+  rv <- reactiveValues(data = MASS::Cars93[c(1, 2, 3, 9, 10, 11, 16, 26, 27)])
+  observe(
+    updateSelectInput(inputId = "var", choices = names(rv$data))
+  )
+
+  # Inline mode
+  data_inline_r <- update_factor_server(
+    id = "id",
+    data_r = reactive(rv$data)
+  )
+  observeEvent(data_inline_r(), rv$data <- data_inline_r())
+
+  # modal window mode
+  observeEvent(input$modal, modal_update_factor("modal"))
+  data_modal_r <- update_factor_server(
+    id = "modal",
+    data_r = reactive(rv$data)
+  )
+  observeEvent(data_modal_r(), {
+    shiny::removeModal()
+    rv$data <- data_modal_r()
+  })
+
+  # Plot results
+  output$plot <- renderPlot({
+    req(input$var, rv$data)
+    ggplot(rv$data) +
+      aes(x = !!sym(input$var)) +
+      geom_bar()
+  })
+  # Show results
+  output$res <- renderPrint({
+    data <- req(rv$data)
+    str(data)
+  })
+}
+
+if (interactive())
+  shinyApp(ui, server)