Merge pull request #82 from dreamRs/dev-2

edit data: pass reactable option + selection
dreamRs · Nov 14, 2023 · 570fc8a · 570fc8a
2 parents 50eb6e5 + 13ed191
commit 570fc8a
Show file tree

Hide file tree

Showing 5 changed files with 137 additions and 26 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -37,6 +37,7 @@ importFrom(data.table,.SD)
 importFrom(data.table,as.data.table)
 importFrom(data.table,copy)
 importFrom(data.table,fread)
+importFrom(data.table,setattr)
 importFrom(data.table,setnames)
 importFrom(data.table,uniqueN)
 importFrom(htmltools,HTML)

diff --git a/R/edit-data-utils.R b/R/edit-data-utils.R
@@ -157,6 +157,15 @@ edit_input_form <- function(default = list(),
             inline = TRUE,
             width = "100%"
           )
+        } else if (isTRUE((inherits(variable, c("POSIXct", "POSIXt"))))) {
+          airDatepickerInput(
+            inputId = ns(variable_id),
+            label = label,
+            value = default[[variable_id]] %||% Sys.time(),
+            inline = TRUE,
+            timepicker = TRUE,
+            width = "100%"
+          )
         } else {
           return(NULL)
         }
@@ -172,36 +181,52 @@ edit_input_form <- function(default = list(),
 #'
 #' @param data `data.frame` to use
 #' @param colnames `data.frame` column names
+#' @param reactable_options `list` allowing you to add reactable options
 #'
 #' @return the `data.frame` in reactable format
 #' @noRd
 #'
 #' @importFrom reactable reactable colDef
-#'
-table_display <- function(data, colnames = NULL) {
-  cols <- list()
-  for (i in seq_along(data)) {
-    cols[[names(data)[i]]] <- colDef(name = colnames[i])
+#' @importFrom data.table copy setnames
+table_display <- function(data, colnames = NULL, reactable_options = NULL) {
+
+  data <- copy(data)
+  if (!is.null(colnames)) {
+    setnames(data, old = seq_along(colnames), new = colnames)
   }
+
+  cols <- reactable_options$columns %||% list()
   if (all(is.na(data$.datamods_edit_update))) {
-    cols$.datamods_edit_update = colDef(show = FALSE)
+    cols$.datamods_edit_update <- colDef(show = FALSE)
   } else {
-    cols$.datamods_edit_update = col_def_update()
+    cols$.datamods_edit_update <- col_def_update()
   }
 
   if (all(is.na(data$.datamods_edit_delete))) {
-    cols$.datamods_edit_delete = colDef(show = FALSE)
+    cols$.datamods_edit_delete <- colDef(show = FALSE)
   } else {
-    cols$.datamods_edit_delete = col_def_delete()
+    cols$.datamods_edit_delete <- col_def_delete()
   }
 
   cols$.datamods_id <- colDef(show = FALSE)
-  reactable(
-    data = data,
-    columns = cols
-  )
+
+  if (is.null(reactable_options))
+    reactable_options <- list()
+  reactable_options <- reactable_options
+  reactable_options$data <- data
+  reactable_options$columns <- cols
+
+  rlang::exec(reactable::reactable, !!!reactable_options)
 }
 
+#' @importFrom reactable updateReactable getReactableState
+#' @importFrom data.table copy setnames
+update_table <- function(data, colnames) {
+  data <- copy(data)
+  setnames(data, old = seq_along(colnames), new = colnames)
+  page <- getReactableState(outputId = "table", name = "page")
+  updateReactable("table", data = data, page = page)
+}
 
 #' @title The update column definition
 #'
@@ -385,3 +410,4 @@ notification_info <- function(title, text) {
     clickToClose = TRUE
   )
 }
+
diff --git a/R/edit-data.R b/R/edit-data.R
@@ -55,14 +55,15 @@ edit_data_ui <- function(id) {
 #' @param var_edit vector of `character` which allows to choose the names of the editable columns
 #' @param var_mandatory vector of `character` which allows to choose obligatory fields to fill
 #' @param return_class Class of returned data: `data.frame`, `data.table`, `tbl_df` (tibble) or `raw`.
+#' @param reactable_options Options passed to [reactable::reactable()].
 #'
 #' @return the edited `data.frame` in reactable format with the user modifications
 #'
 #' @name edit-data
 #'
 #' @importFrom shiny moduleServer eventReactive reactiveValues is.reactive reactive renderUI actionButton observeEvent isTruthy showModal removeModal downloadButton downloadHandler
-#' @importFrom data.table copy as.data.table := copy setnames as.data.table
-#' @importFrom reactable renderReactable reactableOutput getReactableState updateReactable
+#' @importFrom data.table copy as.data.table := copy setnames as.data.table setattr
+#' @importFrom reactable renderReactable reactableOutput getReactableState
 #' @importFrom phosphoricons ph
 #' @importFrom writexl write_xlsx
 #' @importFrom utils write.csv
@@ -80,7 +81,8 @@ edit_data_server <- function(id,
                              file_name_export = "data",
                              var_edit = NULL,
                              var_mandatory = NULL,
-                             return_class = c("data.frame", "data.table", "tbl_df", "raw")) {
+                             return_class = c("data.frame", "data.table", "tbl_df", "raw"),
+                             reactable_options = NULL) {
   return_class <- match.arg(return_class)
   moduleServer(
     id,
@@ -146,10 +148,16 @@ edit_data_server <- function(id,
         data <- req(data_init_r())
         table_display(
           data = data,
-          colnames = data_rv$colnames
+          colnames = data_rv$colnames,
+          reactable_options = reactable_options
         )
       })
 
+      # Retrieve selected row(s)
+      selected_r <- reactive({
+        getReactableState("table", "selected")
+      })
+
 
       # Add a row ---
       output$add_button <- renderUI({
@@ -209,8 +217,7 @@ edit_data_server <- function(id,
 # browser()
           data <- rbind(data, new, fill = TRUE)
           data_rv$data <- data
-          page <- getReactableState(outputId = "table", name = "page")
-          updateReactable("table", data = data, page = page)
+          update_table(data, data_rv$colnames)
         })
         if (inherits(results_add, "try-error")) {
           notification_failure(
@@ -266,8 +273,7 @@ edit_data_server <- function(id,
           })]
           data <- data[order(.datamods_id)]
           data_rv$data <- copy(data)
-          page <- getReactableState(outputId = "table", name = "page")
-          updateReactable("table", data = data, page = page)
+          update_table(data, data_rv$colnames)
         })
         if (inherits(results_update, "try-error")) {
           notification_failure(
@@ -305,8 +311,7 @@ edit_data_server <- function(id,
           data <- data[.datamods_id != input$delete]
           data <- data[order(.datamods_id)]
           data_rv$data <- data
-          page <- getReactableState(outputId = "table", name = "page")
-          updateReactable("table", data = data, page = page)
+          update_table(data, data_rv$colnames)
         })
         if (inherits(results_delete, "try-error")) {
           notification_failure(
@@ -393,13 +398,15 @@ edit_data_server <- function(id,
         }
       )
 
+
       return(
         reactive({
           req(data_rv$data)
           data <- data_rv$data
           data <- as.data.table(data)
           data <- data[,-c(".datamods_id", ".datamods_edit_update", ".datamods_edit_delete")]
           setnames(data, data_rv$colnames)
+          setattr(data, "selected", selected_r())
           as_out(data, return_class)
         })
       )

diff --git a/examples/edit_data.R b/examples/edit_data.R
@@ -1,6 +1,7 @@
 library(shiny)
 library(datamods)
 library(bslib)
+library(reactable)
 
 ui <- fluidPage(
   theme = bs_theme(
@@ -24,7 +25,43 @@ server <- function(input, output, session) {
     download_excel = TRUE,
     file_name_export = "datas",
     # var_edit = c("name", "job", "credit_card_provider", "credit_card_security_code"),
-    var_mandatory = c("name", "job")
+    var_mandatory = c("name", "job"),
+    reactable_options = list(
+      defaultColDef = colDef(filterable = TRUE),
+      selection = "single",
+      columns = list(
+        name = colDef(name = "Name", style = list(fontWeight = "bold")),
+        credit_card_security_code = colDef(name = "Credit card security code"),
+        date_obtained = colDef(name = "Date obtained", format = colFormat(date = TRUE)),
+        contactless_card = colDef(
+          name = "Contactless Card",
+          cell = function(value) {
+            # Render as an X mark or check mark
+            if (value == FALSE) "\u274c No" else "\u2714\ufe0f Yes"
+        }),
+        credit_card_provider = colDef(
+          name = "Credit card provider",
+          style = function(value) {
+            if (value == "Mastercard") {
+              color <- "#e06631"
+            } else if (value == "VISA 16 digit") {
+              color <- "#0c13cf"
+            } else if (value == "American Express") {
+              color <- "#4d8be8"
+            } else if (value == "JCB 16 digit") {
+              color <- "#23c45e"
+            } else {
+              color <- "#777"
+            }
+            list(color = color, fontWeight = "bold")
+          }
+        )
+      ),
+      bordered = TRUE,
+      compact = TRUE,
+      searchable = TRUE,
+      highlight = TRUE
+    )
   )
 
   output$result <- renderPrint({

diff --git a/man/edit-data.Rd b/man/edit-data.Rd