added update factor module + keep vars selected in aes input

DESCRIPTION

@@ -20,7 +20,7 @@ RoxygenNote: 7.3.1
 Roxygen: list(markdown = TRUE)
 Imports: 
     bslib,
-    datamods (>= 1.5.0),
+    datamods (>= 1.5.1),
     downlit,
     ggplot2 (>= 3.0.0),
     grDevices,

R/esquisse-server.R

@@ -120,6 +120,12 @@ esquisse_server <- function(id,
         data_chart$data <- cutted_var()
       })
 
+      # update factor modal
+      updated_fct <- update_fct_server("up_fct", reactive(data_chart$data))
+      observeEvent(updated_fct(), {
+        data_chart$data <- updated_fct()
+      })
+
 
 
       ### Geom & aesthetics selection

R/esquisse-ui.R

@@ -77,7 +77,8 @@ esquisse_ui <- function(id,
       header_btns$show_data(ns("show_data")),
       header_btns$update_variable(ns("update_variable")),
       header_btns$create_column(ns("create_col")),
-      header_btns$cut_variable(ns("cut_var"))
+      header_btns$cut_variable(ns("cut_var")),
+      header_btns$update_factor(ns("up_fct"))
     )
   )
 
@@ -236,7 +237,8 @@ esquisse_container <- function(width = "100%", height = "700px", fixed = FALSE)
 #' @param show_data Show button to display data.
 #' @param update_variable Show button to update selected variables and convert them.
 #' @param create_column Show button to create a new column based on an expression.
-#' @param cut_variable Show button to allow to convert a numeric variable into factors.
+#' @param cut_variable Show button to allow to convert a numeric variable into factor.
+#' @param update_factor Show button to open window to reorder factor levels and update them.
 #' @param settings Show button to open settings modal (to select aesthetics to use).
 #' @param close Show button to stop the app and close addin.
 #' @param .before,.after Custom content to put in the header, typically buttons.
@@ -250,6 +252,7 @@ esquisse_header <- function(import_data = TRUE,
                             update_variable = TRUE,
                             create_column = TRUE,
                             cut_variable = TRUE,
+                            update_factor = TRUE,
                             settings = TRUE,
                             close = TRUE,
                             .before = NULL,
@@ -260,6 +263,7 @@ esquisse_header <- function(import_data = TRUE,
     update_variable = isTRUE(update_variable),
     create_column = isTRUE(create_column),
     cut_variable = isTRUE(cut_variable),
+    update_factor = isTRUE(update_factor),
     settings = isTRUE(settings),
     close = isTRUE(close),
     .before = .before,
@@ -295,6 +299,11 @@ make_btn_header <- function(.list) {
     } else {
       function(id) NULL
     },
+    update_factor = if (isTRUE(.list$update_factor)) {
+      update_fct_ui
+    } else {
+      function(id) NULL
+    },
     settings = if (isTRUE(.list$settings)) {
       btn_header(i18n("Display settings"), "gear-fine")
     } else {

R/module-select-aes.R

@@ -106,15 +106,28 @@ select_aes_server <- function(id,
           )
         } else {
           var_choices <- get_col_names(data)
+          var_badges <- badgeType(
+            col_name = var_choices,
+            col_type = col_type(data[, var_choices, drop = TRUE])
+          )
+          selected <- dropNulls(isolate(input$dragvars$target))
+          var_selected <- unlist(selected, use.names = FALSE)
+          if (!all(var_selected %in% var_choices))
+            var_selected <- NULL
           updateDragulaInput(
             session = session,
             inputId = "dragvars",
             status = NULL,
             choiceValues = var_choices,
-            choiceNames = badgeType(
-              col_name = var_choices,
-              col_type = col_type(data[, var_choices, drop = TRUE])
+            choiceNames = var_badges,
+            # selected = shiny::isolate(input$dragvars$target),
+            selectedNames = if (length(var_selected) > 0) lapply(
+              X = selected,
+              function(x) {
+                var_badges[var_choices == x]
+              }
             ),
+            selectedValues = if (length(var_selected) > 0) selected,
             badge = FALSE
           )
         }

R/module-select-geom-aes.R

@@ -133,7 +133,7 @@ select_geom_aes_server <- function(id,
 
       }), rv$aes_1, input$geom_1)
 
-      observeEvent( rv$possible, {
+      observeEvent(rv$possible, {
         geoms <- geomIcons()$values
         geomposs <-  rv$possible
         updateDropInput(

R/module-utils.R

@@ -139,16 +139,16 @@ cut_var_ui <- function(id) {
   ns <- NS(id)
   icon <- tags$div(
     style = css(position = "relative", width = "35px"),
-    ph("list-numbers", height = "2em", title = i18n("Cut numeric variable into factors")),
+    ph("list-numbers", height = "2em", title = i18n("Cut numeric variable into factor")),
     ph(
       "scissors",
       style = css(position = "absolute", top = 0, right = 0, transform = "scale(-1, 1)"),
       height = "1.2em",
       weight = "bold",
-      title = i18n("Cut numeric variable into factors")
+      title = i18n("Cut numeric variable into factor")
     )
   )
-  btn_header(i18n("Cut numeric variable into factors"), class = " px-0", icon)(ns("btn"))
+  btn_header(i18n("Cut numeric variable into factor"), class = "px-0", icon)(ns("btn"))
 }
 
 #' @importFrom shiny moduleServer observeEvent modalDialog showModal reactive
@@ -168,3 +168,46 @@ cut_var_server <- function(id, data_r = reactive(NULL)) {
     }
   )
 }
+
+
+
+
+# Update factor -----------------------------------------------------------
+
+#' @importFrom shiny NS
+#' @importFrom htmltools tags css
+#' @importFrom phosphoricons ph
+update_fct_ui <- function(id) {
+  ns <- NS(id)
+  icon <- tags$div(
+    style = css(position = "relative", width = "35px"),
+    ph("list-dashes", height = "2em", title = i18n("Update factor")),
+    ph(
+      "arrows-down-up",
+      style = css(position = "absolute", top = 0, right = 0, transform = "scale(-1, 1)"),
+      height = "1.2em",
+      weight = "bold",
+      title = i18n("Update factor")
+    )
+  )
+  btn_header(i18n("Update factor"), class = "px-0", icon)(ns("btn"))
+}
+
+#' @importFrom shiny moduleServer observeEvent modalDialog showModal reactive
+#' @importFrom datamods cut_variable_ui cut_variable_server
+update_fct_server <- function(id, data_r = reactive(NULL)) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+      ns <- session$ns
+      observeEvent(input$btn, datamods::modal_update_factor(ns("mod")))
+      observeEvent(res(), shiny::removeModal())
+      res <- datamods::update_factor_server(
+        id = "mod",
+        data = data_r
+      )
+      return(res)
+    }
+  )
+}
+