create_column: allow group by

dreamRs · Apr 3, 2024 · 0e81a4f · 0e81a4f
1 parent 0f03187
commit 0e81a4f
Show file tree

Hide file tree

Showing 6 changed files with 82 additions and 33 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -94,6 +94,7 @@ importFrom(rlang,is_vector)
 importFrom(rlang,parse_expr)
 importFrom(rlang,set_names)
 importFrom(rlang,sym)
+importFrom(rlang,syms)
 importFrom(shiny,NS)
 importFrom(shiny,actionButton)
 importFrom(shiny,actionLink)

diff --git a/R/create-column.R b/R/create-column.R
@@ -20,18 +20,35 @@
 #' @importFrom htmltools tagList tags css
 #' @importFrom shiny NS textInput textAreaInput uiOutput actionButton
 #' @importFrom phosphoricons ph
+#' @importFrom shinyWidgets virtualSelectInput
 #'
 #' @name create-column
 #'
 #' @example examples/create_column.R
 create_column_ui <- function(id) {
   ns <- NS(id)
   tagList(
-    textInput(
-      inputId = ns("new_column"),
-      label = "New column name:",
-      value = "new_column1",
-      width = "100%"
+    fluidRow(
+      column(
+        width = 6,
+        textInput(
+          inputId = ns("new_column"),
+          label = "New column name:",
+          value = "new_column1",
+          width = "100%"
+        )
+      ),
+      column(
+        width = 6,
+        virtualSelectInput(
+          inputId = ns("group_by"),
+          label = "Group calculation by:",
+          choices = NULL,
+          multiple = TRUE,
+          disableSelectAll = TRUE,
+          width = "100%"
+        )
+      )
     ),
     textAreaInput(
       inputId = ns("expression"),
@@ -83,7 +100,7 @@ create_column_ui <- function(id) {
 #'
 #' @importFrom shiny moduleServer reactiveValues observeEvent renderUI req
 #'  updateTextAreaInput reactive
-#' @importFrom shinyWidgets alert
+#' @importFrom shinyWidgets alert updateVirtualSelect
 create_column_server <- function(id,
                                  data_r = reactive(NULL),
                                  allowed_operations = list_allowed_operations()) {
@@ -95,6 +112,14 @@ create_column_server <- function(id,
 
       rv <- reactiveValues(data = NULL, feedback = NULL)
 
+      observeEvent(data_r(), {
+        data <- data_r()
+        updateVirtualSelect(
+          inputId = "group_by",
+          choices = names(data)
+        )
+      })
+
       observeEvent(data_r(), rv$data <- data_r())
 
       output$feedback <- renderUI(rv$feedback)
@@ -129,7 +154,8 @@ create_column_server <- function(id,
           expression = input$expression,
           name = input$new_column,
           rv = rv,
-          allowed_operations = allowed_operations
+          allowed_operations = allowed_operations,
+          by = input$group_by
         )
       })
 
@@ -144,7 +170,7 @@ create_column_server <- function(id,
 # @importFrom methods getGroupMembers
 list_allowed_operations <- function() {
   c(
-    "(",
+    "(", "c",
     # getGroupMembers("Arith"),
     c("+", "-", "*", "^", "%%", "%/%", "/"),
     # getGroupMembers("Compare"),
@@ -190,8 +216,13 @@ modal_create_column <- function(id,
 }
 
 
-#' @importFrom rlang parse_expr eval_tidy call2 set_names
-try_compute_column <- function(expression, name, rv, allowed_operations) {
+#' @importFrom rlang parse_expr eval_tidy call2 set_names syms
+#' @importFrom data.table as.data.table :=
+try_compute_column <- function(expression,
+                               name,
+                               rv,
+                               allowed_operations,
+                               by = NULL) {
   parsed <- try(parse(text = expression, keep.source = FALSE), silent = TRUE)
   if (inherits(parsed, "try-error")) {
     return(alert_error(attr(parsed, "condition")$message))
@@ -200,21 +231,38 @@ try_compute_column <- function(expression, name, rv, allowed_operations) {
   if (!are_allowed_operations(funs, allowed_operations)) {
     return(alert_error("Some operations are not allowed"))
   }
-  result <- try(
-    eval_tidy(parse_expr(expression), data = rv$data),
-    silent = TRUE
-  )
+  if (!isTruthy(by)) {
+    result <- try(
+      eval_tidy(parse_expr(expression), data = rv$data),
+      silent = TRUE
+    )
+  } else {
+    result <- try(
+      {
+        dt <- as.data.table(rv$data)
+        new_col <- NULL
+        dt[, new_col := eval_tidy(parse_expr(expression), data = .SD), by = by]
+        dt$new_col
+      },
+      silent = TRUE
+    )
+  }
   if (inherits(result, "try-error")) {
     return(alert_error(attr(result, "condition")$message))
   }
   adding_col <- try(rv$data[[name]] <- result, silent = TRUE)
   if (inherits(adding_col, "try-error")) {
     return(alert_error(attr(adding_col, "condition")$message))
   }
-  attr(rv$data, "code") <- c(
-    attr(rv$data, "code"),
+  code <- if (!isTruthy(by)) {
     call2("mutate", !!!set_names(list(parse_expr(expression)), name))
-  )
+  } else {
+    expr(
+      !!expr(group_by(!!!syms(by))) %>%
+        !!call2("mutate", !!!set_names(list(parse_expr(expression)), name))
+    )
+  }
+  attr(rv$data, "code") <- c(attr(rv$data, "code"),  code)
   alert(
     status = "success",
     ph("check"), "Column added!"

diff --git a/R/datagrid-infos.R b/R/datagrid-infos.R
@@ -2,15 +2,15 @@
 #' @importFrom htmltools tagList tags css
 describe_col_char <- function(x, with_summary = TRUE) {
   tags$div(
-    style = css(padding = "5px 0", fontSize = "x-small"),
+    style = css(padding = "3px 0", fontSize = "x-small"),
     tags$div(
       style = css(fontStyle = "italic"),
       phosphoricons::ph("text-aa"),
       "character"
     ),
     if (with_summary) {
       tagList(
-        tags$hr(style = css(margin = "5px 0")),
+        tags$hr(style = css(margin = "3px 0")),
         tags$div(
           "Unique:", length(unique(x))
         ),
@@ -44,15 +44,15 @@ describe_col_factor <- function(x, with_summary = TRUE) {
   two <- count[!is.na(names(count))][2]
   missing <- count[is.na(names(count))]
   tags$div(
-    style = css(padding = "5px 0", fontSize = "x-small"),
+    style = css(padding = "3px 0", fontSize = "x-small"),
     tags$div(
       style = css(fontStyle = "italic"),
       phosphoricons::ph("list-bullets"),
       "factor"
     ),
     if (with_summary) {
       tagList(
-        tags$hr(style = css(margin = "5px 0")),
+        tags$hr(style = css(margin = "3px 0")),
         tags$div(
           names(one), ":", fmt_p(one, total)
         ),
@@ -72,15 +72,15 @@ describe_col_factor <- function(x, with_summary = TRUE) {
 
 describe_col_num <- function(x, with_summary = TRUE) {
   tags$div(
-    style = css(padding = "5px 0", fontSize = "x-small"),
+    style = css(padding = "3px 0", fontSize = "x-small"),
     tags$div(
       style = css(fontStyle = "italic"),
       phosphoricons::ph("hash"),
       "numeric"
     ),
     if (with_summary) {
       tagList(
-        tags$hr(style = css(margin = "5px 0")),
+        tags$hr(style = css(margin = "3px 0")),
         tags$div(
           "Min:", round(min(x, na.rm = TRUE), 2)
         ),
@@ -101,15 +101,15 @@ describe_col_num <- function(x, with_summary = TRUE) {
 
 describe_col_date <- function(x, with_summary = TRUE) {
   tags$div(
-    style = css(padding = "5px 0", fontSize = "x-small"),
+    style = css(padding = "3px 0", fontSize = "x-small"),
     tags$div(
       style = css(fontStyle = "italic"),
       phosphoricons::ph("calendar"),
       "date"
     ),
     if (with_summary) {
       tagList(
-        tags$hr(style = css(margin = "5px 0")),
+        tags$hr(style = css(margin = "3px 0")),
         tags$div(
           "Min:", min(x, na.rm = TRUE)
         ),
@@ -129,15 +129,15 @@ describe_col_date <- function(x, with_summary = TRUE) {
 
 describe_col_datetime <- function(x, with_summary = TRUE) {
   tags$div(
-    style = css(padding = "5px 0", fontSize = "x-small"),
+    style = css(padding = "3px 0", fontSize = "x-small"),
     tags$div(
       style = css(fontStyle = "italic"),
       phosphoricons::ph("clock"),
       "datetime"
     ),
     if (with_summary) {
       tagList(
-        tags$hr(style = css(margin = "5px 0")),
+        tags$hr(style = css(margin = "3px 0")),
         tags$div(
           "Min:", min(x, na.rm = TRUE)
         ),
@@ -158,15 +158,15 @@ describe_col_datetime <- function(x, with_summary = TRUE) {
 
 describe_col_other <- function(x, with_summary = TRUE) {
   tags$div(
-    style = css(padding = "5px 0", fontSize = "x-small"),
+    style = css(padding = "3px 0", fontSize = "x-small"),
     tags$div(
       style = css(fontStyle = "italic"),
       # phosphoricons::ph("clock"),
       paste(class(x), collapse = ", ")
     ),
     if (with_summary) {
       tagList(
-        tags$hr(style = css(margin = "5px 0")),
+        tags$hr(style = css(margin = "3px 0")),
         tags$div(
           "Unique:", length(unique(x))
         ),
@@ -188,7 +188,7 @@ describe_col_other <- function(x, with_summary = TRUE) {
 construct_col_summary <- function(data) {
   list(
     position = "top",
-    height = 40,
+    height = 90,
     columnContent = lapply(
       X = setNames(names(data), names(data)),
       FUN = function(col) {

diff --git a/R/show_data.R b/R/show_data.R
@@ -35,7 +35,7 @@ show_data <- function(data,
   if (is.null(options))
     options <- list()
 
-  options$height <- 500
+  options$height <- 550
   options$minBodyHeight <- 400
   options$data <- data
   options$theme <- "default"

diff --git a/R/zzz.R b/R/zzz.R
@@ -1,6 +1,6 @@
 
 utils::globalVariables(c(
-  "%>%", "filter", "label", "translation",
+  "%>%", "filter", "group_by", "label", "translation",
   ".datamods_edit_update", ".datamods_edit_delete", ".datamods_id",
   "..var_edit", "..vars_datamods_edit",
   "select", "any_of", "rename",

diff --git a/man/create-column.Rd b/man/create-column.Rd