slightly updated visuals

NAMESPACE

@@ -18,6 +18,8 @@ export(clean_sep)
 export(columnSelectInput)
 export(contrast_text)
 export(create_baseline)
+export(create_column_server)
+export(create_column_ui)
 export(create_log_tics)
 export(create_overview_datagrid)
 export(create_plot)
@@ -45,6 +47,7 @@ export(format_writer)
 export(get_fun_options)
 export(get_label)
 export(get_plot_options)
+export(get_var_icon)
 export(getfun)
 export(gg_theme_export)
 export(gg_theme_shiny)
@@ -67,11 +70,13 @@ export(is_valid_token)
 export(launch_FreesearchR)
 export(limit_log)
 export(line_break)
+export(list_allowed_operations)
 export(m_redcap_readServer)
 export(m_redcap_readUI)
 export(merge_expression)
 export(merge_long)
 export(missing_fraction)
+export(modal_create_column)
 export(modal_cut_variable)
 export(modal_update_factor)
 export(modify_qmd)
@@ -102,6 +107,7 @@ export(repeated_instruments)
 export(sankey_ready)
 export(selectInputIcon)
 export(set_column_label)
+export(show_data)
 export(sort_by)
 export(specify_qmd_format)
 export(subset_types)
@@ -117,6 +123,7 @@ export(update_variables_ui)
 export(vectorSelectInput)
 export(vertical_stacked_bars)
 export(wide2long)
+export(winbox_create_column)
 export(winbox_update_factor)
 export(wrap_plot_list)
 export(write_quarto)
@@ -134,6 +141,7 @@ importFrom(htmltools,css)
 importFrom(htmltools,tagList)
 importFrom(htmltools,tags)
 importFrom(htmltools,validateCssUnit)
+importFrom(phosphoricons,ph)
 importFrom(rlang,"%||%")
 importFrom(rlang,call2)
 importFrom(rlang,expr)
@@ -152,20 +160,25 @@ importFrom(shiny,isTruthy)
 importFrom(shiny,modalDialog)
 importFrom(shiny,moduleServer)
 importFrom(shiny,numericInput)
+importFrom(shiny,observe)
 importFrom(shiny,observeEvent)
 importFrom(shiny,plotOutput)
 importFrom(shiny,reactive)
 importFrom(shiny,reactiveValues)
 importFrom(shiny,renderPlot)
+importFrom(shiny,renderUI)
 importFrom(shiny,req)
 importFrom(shiny,restoreInput)
 importFrom(shiny,selectizeInput)
 importFrom(shiny,showModal)
 importFrom(shiny,tagList)
+importFrom(shiny,textAreaInput)
 importFrom(shiny,textInput)
 importFrom(shiny,uiOutput)
 importFrom(shiny,updateActionButton)
+importFrom(shiny,updateTextAreaInput)
 importFrom(shinyWidgets,WinBox)
+importFrom(shinyWidgets,alert)
 importFrom(shinyWidgets,noUiSliderInput)
 importFrom(shinyWidgets,prettyCheckbox)
 importFrom(shinyWidgets,updateVirtualSelect)

NEWS.md

@@ -6,6 +6,8 @@
 
 - *IMPROVED*: docs are updated and much more comprehensive. They will be continuously updated.
 
+Polishing and moved hosted app to new address to fully reflect name change: [https://agdamsbo.shinyapps.io/FreesearchR/](https://agdamsbo.shinyapps.io/FreesearchR/)
+
 # FreesearchR 25.4.2
 
 Polished and simplified data import module including a much improved REDCap import module.

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'v25.4.3.250423'
+app_version <- function()'v25.4.3.250424'

R/create-column-mod.R

@@ -0,0 +1,443 @@
+#' @title Create new column
+#'
+#' @description
+#' This module allow to enter an expression to create a new column in a `data.frame`.
+#'
+#'
+#' @param id Module's ID.
+#'
+#' @return A [shiny::reactive()] function returning the data.
+#'
+#' @note User can only use a subset of function: `r paste(list_allowed_operations(), collapse=", ")`.
+#'  You can add more operations using the `allowed_operations` argument, for  example if you want to allow to use package lubridate, you can do:
+#'  ```r
+#'  c(list_allowed_operations(), getNamespaceExports("lubridate"))
+#'  ```
+#'
+#' @export
+#'
+#' @importFrom htmltools tagList tags css
+#' @importFrom shiny NS textInput textAreaInput uiOutput actionButton
+#' @importFrom phosphoricons ph
+#' @importFrom shinyWidgets virtualSelectInput
+#'
+#' @name create-column
+#'
+#' @example example/create_column_module_demo.R
+create_column_ui <- function(id) {
+  ns <- NS(id)
+  tagList(
+    # datamods:::html_dependency_datamods(),
+    # html_dependency_FreesearchR(),
+   tags$head(
+    tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
+  ),
+    # tags$head(
+    #   # Note the wrapping of the string in HTML()
+    #   tags$style(HTML("
+    #   /* modified from esquisse for data types */
+    #   .btn-column-categorical {
+    #     background-color: #EF562D;
+    #     color: #FFFFFF;
+    #   }
+    #   .btn-column-continuous {
+    #     background-color: #0C4C8A;
+    #     color: #FFFFFF;
+    #   }
+    #   .btn-column-dichotomous {
+    #     background-color: #97D5E0;
+    #     color: #FFFFFF;
+    #   }
+    #   .btn-column-datetime {
+    #     background-color: #97D5E0;
+    #     color: #FFFFFF;
+    #   }
+    #   .btn-column-id {
+    #     background-color: #848484;
+    #     color: #FFFFFF;
+    #   }
+    #   .btn-column-text {
+    #     background-color: #2E2E2E;
+    #     color: #FFFFFF;
+    #   }"))
+    # ),
+    fluidRow(
+      column(
+        width = 6,
+        textInput(
+          inputId = ns("new_column"),
+          label = i18n("New column name:"),
+          value = "new_column1",
+          width = "100%"
+        )
+      ),
+      column(
+        width = 6,
+        shinyWidgets::virtualSelectInput(
+          inputId = ns("group_by"),
+          label = i18n("Group calculation by:"),
+          choices = NULL,
+          multiple = TRUE,
+          disableSelectAll = TRUE,
+          hasOptionDescription = TRUE,
+          width = "100%"
+        )
+      )
+    ),
+    textAreaInput(
+      inputId = ns("expression"),
+      label = i18n("Enter an expression to define new column:"),
+      value = "",
+      width = "100%",
+      rows = 6
+    ),
+    tags$i(
+      class = "d-block",
+      phosphoricons::ph("info"),
+      datamods::i18n("Click on a column name to add it to the expression:")
+    ),
+    uiOutput(outputId = ns("columns")),
+    uiOutput(outputId = ns("feedback")),
+    tags$div(
+      style = css(
+        display = "grid",
+        gridTemplateColumns = "3fr 1fr",
+        columnGap = "10px",
+        margin = "10px 0"
+      ),
+      actionButton(
+        inputId = ns("compute"),
+        label = tagList(
+          phosphoricons::ph("gear"), i18n("Create column")
+        ),
+        class = "btn-outline-primary",
+        width = "100%"
+      ),
+      actionButton(
+        inputId = ns("remove"),
+        label = tagList(
+          phosphoricons::ph("trash")
+        ),
+        class = "btn-outline-danger",
+        width = "100%"
+      )
+    )
+  )
+}
+
+#' @param data_r A [shiny::reactive()] function returning a `data.frame`.
+#' @param allowed_operations A `list` of allowed operations, see below for details.
+#'
+#' @export
+#'
+#' @rdname create-column
+#'
+#' @importFrom shiny moduleServer reactiveValues observeEvent renderUI req
+#'  updateTextAreaInput reactive bindEvent observe
+#' @importFrom shinyWidgets alert updateVirtualSelect
+create_column_server <- function(id,
+                                 data_r = reactive(NULL),
+                                 allowed_operations = list_allowed_operations()) {
+  moduleServer(
+    id,
+    function(input, output, session) {
+      ns <- session$ns
+
+      info_alert <- shinyWidgets::alert(
+        status = "info",
+        phosphoricons::ph("question"),
+        datamods::i18n("Choose a name for the column to be created or modified,"),
+        datamods::i18n("then enter an expression before clicking on the button above to validate or on "),
+        phosphoricons::ph("trash"), datamods::i18n("to delete it.")
+      )
+
+      rv <- reactiveValues(
+        data = NULL,
+        feedback = info_alert
+      )
+
+      observeEvent(input$hidden, rv$feedback <- info_alert)
+
+      bindEvent(observe({
+        data <- data_r()
+        shinyWidgets::updateVirtualSelect(
+          inputId = "group_by",
+          choices = make_choices_with_infos(data)
+        )
+      }), data_r(), input$hidden)
+
+      observeEvent(data_r(), rv$data <- data_r())
+
+      output$feedback <- renderUI(rv$feedback)
+
+      output$columns <- renderUI({
+        data <- req(rv$data)
+        mapply(
+          label = names(data),
+          data = data,
+          FUN = btn_column,
+          MoreArgs = list(inputId = ns("add_column")),
+          SIMPLIFY = FALSE
+        )
+      })
+
+      observeEvent(input$add_column, {
+        updateTextAreaInput(
+          session = session,
+          inputId = "expression",
+          value = paste0(input$expression, input$add_column)
+        )
+      })
+
+      observeEvent(input$new_column, {
+        if (input$new_column == "") {
+          rv$feedback <- shinyWidgets::alert(
+            status = "warning",
+            ph("warning"), datamods::i18n("New column name cannot be empty")
+          )
+        }
+      })
+
+      observeEvent(input$remove, {
+        rv$data[[input$new_column]] <- NULL
+      })
+      observeEvent(input$compute, {
+        rv$feedback <- try_compute_column(
+          expression = input$expression,
+          name = input$new_column,
+          rv = rv,
+          allowed_operations = allowed_operations,
+          by = input$group_by
+        )
+      })
+
+      return(reactive(rv$data))
+    }
+  )
+}
+
+#' @export
+#'
+#' @rdname create-column
+# @importFrom methods getGroupMembers
+list_allowed_operations <- function() {
+  c(
+    "(", "c",
+    # getGroupMembers("Arith"),
+    c("+", "-", "*", "^", "%%", "%/%", "/"),
+    # getGroupMembers("Compare"),
+    c("==", ">", "<", "!=", "<=", ">="),
+    # getGroupMembers("Logic"),
+    c("&", "|"),
+    # getGroupMembers("Math"),
+    c(
+      "abs", "sign", "sqrt", "ceiling", "floor", "trunc", "cummax",
+      "cummin", "cumprod", "cumsum", "exp", "expm1", "log", "log10",
+      "log2", "log1p", "cos", "cosh", "sin", "sinh", "tan", "tanh",
+      "acos", "acosh", "asin", "asinh", "atan", "atanh", "cospi", "sinpi",
+      "tanpi", "gamma", "lgamma", "digamma", "trigamma"
+    ),
+    # getGroupMembers("Math2"),
+    c("round", "signif"),
+    # getGroupMembers("Summary"),
+    c("max", "min", "range", "prod", "sum", "any", "all"),
+    "pmin", "pmax", "mean",
+    "paste", "paste0", "substr", "nchar", "trimws",
+    "gsub", "sub", "grepl", "ifelse", "length",
+    "as.numeric", "as.character", "as.integer", "as.Date", "as.POSIXct",
+    "as.factor", "factor"
+  )
+}
+
+
+#' @inheritParams shiny::modalDialog
+#' @export
+#'
+#' @importFrom shiny showModal modalDialog textInput
+#' @importFrom htmltools tagList
+#'
+#' @rdname create-column
+modal_create_column <- function(id,
+                                title = i18n("Create a new column"),
+                                easyClose = TRUE,
+                                size = "l",
+                                footer = NULL) {
+  ns <- NS(id)
+  showModal(modalDialog(
+    title = tagList(title, datamods:::button_close_modal()),
+    create_column_ui(id),
+    tags$div(
+      style = "display: none;",
+      textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
+    ),
+    easyClose = easyClose,
+    size = size,
+    footer = footer
+  ))
+}
+
+#' @inheritParams shinyWidgets::WinBox
+#' @export
+#'
+#' @importFrom shinyWidgets WinBox wbOptions wbControls
+#' @importFrom htmltools tagList
+#' @rdname create-column
+winbox_create_column <- function(id,
+                                 title = i18n("Create a new column"),
+                                 options = shinyWidgets::wbOptions(),
+                                 controls = shinyWidgets::wbControls()) {
+  ns <- NS(id)
+  WinBox(
+    title = title,
+    ui = tagList(
+      create_column_ui(id),
+      tags$div(
+        style = "display: none;",
+        textInput(inputId = ns("hidden"), label = NULL, value = datamods:::genId())
+      )
+    ),
+    options = modifyList(
+      shinyWidgets::wbOptions(height = "550px", modal = TRUE),
+      options
+    ),
+    controls = controls,
+    auto_height = FALSE
+  )
+}
+
+
+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(datamods:::alert_error(attr(parsed, "condition")$message))
+  }
+  funs <- unlist(c(extract_calls(parsed), lapply(parsed, extract_calls)), recursive = TRUE)
+  if (!are_allowed_operations(funs, allowed_operations)) {
+    return(datamods:::alert_error(datamods::i18n("Some operations are not allowed")))
+  }
+  if (!isTruthy(by)) {
+    result <- try(
+      rlang::eval_tidy(rlang::parse_expr(expression), data = rv$data),
+      silent = TRUE
+    )
+  } else {
+    result <- try(
+      {
+        dt <- as.data.table(rv$data)
+        new_col <- NULL
+        dt[, new_col := rlang::eval_tidy(rlang::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))
+  }
+  code <- if (!isTruthy(by)) {
+    rlang::call2("mutate", !!!rlang::set_names(list(rlang::parse_expr(expression)), name))
+  } else {
+    rlang::call2(
+      "mutate",
+      !!!rlang::set_names(list(rlang::parse_expr(expression)), name),
+      !!!list(.by = rlang::expr(c(!!!rlang::syms(by))))
+    )
+  }
+  attr(rv$data, "code") <- Reduce(
+    f = function(x, y) rlang::expr(!!x %>% !!y),
+    x = c(attr(rv$data, "code"), code)
+  )
+  shinyWidgets::alert(
+    status = "success",
+    ph("check"), datamods::i18n("Column added!")
+  )
+}
+
+are_allowed_operations <- function(x, allowed_operations) {
+  all(
+    x %in% allowed_operations
+  )
+}
+
+
+extract_calls <- function(exp) {
+  if (is.call(exp)) {
+    return(list(
+      as.character(exp[[1L]]),
+      lapply(exp[-1L], extract_calls)
+    ))
+  }
+}
+
+alert_error <- function(text) {
+  alert(
+    status = "danger",
+    ph("bug"), text
+  )
+}
+
+
+btn_column <- function(label, data, inputId) {
+  icon <- get_var_icon(data, "class")
+  type <- data_type(data)
+  tags$button(
+    type = "button",
+    class = paste0("btn btn-column-", type),
+    style = css(
+      "--bs-btn-padding-y" = ".25rem",
+      "--bs-btn-padding-x" = ".5rem",
+      "--bs-btn-font-size" = ".75rem",
+      "margin-bottom" = "5px"
+    ),
+    if (!is.null(icon)) icon,
+    label,
+    onclick = sprintf(
+      "Shiny.setInputValue('%s', '%s', {priority: 'event'})",
+      inputId, label
+    )
+  )
+}
+
+make_choices_with_infos <- function(data) {
+  lapply(
+    X = seq_along(data),
+    FUN = function(i) {
+      nm <- names(data)[i]
+      values <- data[[nm]]
+      icon <- get_var_icon(values, "class")
+      # icon <- if (inherits(values, "character")) {
+      #   phosphoricons::ph("text-aa")
+      # } else if (inherits(values, "factor")) {
+      #   phosphoricons::ph("list-bullets")
+      # } else if (inherits(values, c("numeric", "integer"))) {
+      #   phosphoricons::ph("hash")
+      # } else if (inherits(values, c("Date"))) {
+      #   phosphoricons::ph("calendar")
+      # } else if (inherits(values, c("POSIXt"))) {
+      #   phosphoricons::ph("clock")
+      # } else {
+      #   NULL
+      # }
+      description <- if (is.atomic(values)) {
+        paste(i18n("Unique values:"), data.table::uniqueN(values))
+      } else {
+        ""
+      }
+      list(
+        label = htmltools::doRenderTags(tagList(
+          icon, nm
+        )),
+        value = nm,
+        description = description
+      )
+    }
+  )
+}

R/cut-variable-dates.R

@@ -56,6 +56,7 @@ cut_var.hms <- function(x, breaks, ...) {
 #' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
 #' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "month_only")
 #' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "%A-%H")
+#' readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "%W")
 cut_var.POSIXt <- function(x, breaks, right = FALSE, include.lowest = TRUE, start.on.monday = TRUE, ...) {
   breaks_o <- breaks
   args <- list(...)
@@ -126,7 +127,10 @@ cut_var.POSIXct <- cut_var.POSIXt
 #' @examples
 #' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
 #' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
-cut_var.Date <- function(x, breaks, start.on.monday = TRUE, ...) {
+#' as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(format = "%W")
+cut_var.Date <- function(x, breaks=NULL, start.on.monday = TRUE, ...) {
+  args <- list(...)
+
   if ("format" %in% names(args)){
     assertthat::assert_that(is.character(args$format))
     out <- forcats::as_factor(format(x,format=args$format))
@@ -337,10 +341,11 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
         variable <- req(input$variable)
 
         choices <- c(
+          # "fixed",
           # "quantile"
         )
 
-        if ("hms" %in% class(data[[variable]])) {
+        if (any(c("hms","POSIXct") %in% class(data[[variable]]))) {
           choices <- c(choices, "hour")
         } else if (any(c("POSIXt", "Date") %in% class(data[[variable]]))) {
           choices <- c(
@@ -348,6 +353,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
             "day",
             "weekday",
             "week",
+            # "week_only",
             "month",
             "month_only",
             "quarter",
@@ -372,6 +378,8 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
           )
         }
 
+        choices <- unique(choices)
+
         shinyWidgets::virtualSelectInput(
           inputId = session$ns("method"),
           label = i18n("Method:"),
@@ -389,7 +397,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
         req(input$n_breaks, input$method)
         if (input$method == "fixed") {
           req(input$fixed_brks)
-          if (any(c("hms", "POSIXt") %in% class(data[[variable]]))) {
+          if (any(c("hms", "POSIXct") %in% class(data[[variable]]))) {
             # cut.POSIXct <- cut.POSIXt
             f <- cut_var(data[[variable]], breaks = input$fixed_brks)
             list(var = f, brks = levels(f))
@@ -432,6 +440,11 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
           # cut.POSIXct <- cut.POSIXt
           f <- cut_var(data[[variable]], breaks = "hour")
           list(var = f, brks = levels(f))
+        # } else if (input$method %in% c("week_only")) {
+        #   # As a proof of concept a single option to use "format" parameter
+        #   # https://www.stat.berkeley.edu/~s133/dates.html
+        #   f <- cut_var(data[[variable]], format = "%W")
+        #   list(var = f, brks = levels(f))
         } else {
           classInt::classIntervals(
             var = as.numeric(data[[variable]]),
@@ -445,6 +458,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
         data <- req(data_r())
         variable <- req(input$variable)
         plot_histogram(data, variable, breaks = breaks_r()$brks, color = datamods:::get_primary_color())
+        # plot_histogram(data = breaks_r()$var, breaks = breaks_r()$brks, color = datamods:::get_primary_color())
       })
 
 
@@ -582,8 +596,13 @@ modal_cut_variable <- function(id,
 
 
 #' @importFrom graphics abline axis hist par plot.new plot.window
-plot_histogram <- function(data, column, bins = 30, breaks = NULL, color = "#112466") {
+plot_histogram <- function(data, column=NULL, bins = 30, breaks = NULL, color = "#112466") {
+  if (is.vector(data)){
+    x <- data
+  } else {
   x <- data[[column]]
+
+  }
   x <- as.numeric(x)
   op <- par(mar = rep(1.5, 4))
   on.exit(par(op))

R/data-summary.R

@@ -318,9 +318,9 @@ class_icons <- function(x) {
     shiny::icon("arrow-down-a-z")
   } else if (identical(x, "logical")) {
     shiny::icon("toggle-off")
-  } else if (any(c("Date", "POSIXct", "POSIXt") %in% x)) {
+  } else if (any(c("Date", "POSIXt") %in% x)) {
     shiny::icon("calendar-days")
-  } else if ("hms" %in% x) {
+  } else if (any("POSIXct", "hms") %in% x) {
     shiny::icon("clock")
   } else {
     shiny::icon("table")
@@ -360,3 +360,33 @@ type_icons <- function(x) {
     }
     }
 }
+
+#' Easily get variable icon based on data type or class
+#'
+#' @param data variable or data frame
+#' @param class.type "type" or "class". Default is "class"
+#'
+#' @returns svg icon
+#' @export
+#'
+#' @examples
+#' mtcars[1] |> get_var_icon("class")
+#' default_parsing(mtcars) |> get_var_icon()
+get_var_icon <- function(data,class.type=c("class","type")){
+  if (is.data.frame(data)){
+    lapply(data,get_var_icon)
+  } else {
+
+  class.type <- match.arg(class.type)
+
+  switch(class.type,
+         type = {
+           type_icons(data_type(data))
+         },
+         class = {
+           class(data)[1] |> class_icons()
+         }
+  )
+}
+
+}

R/datagrid-infos-mod.R

@@ -0,0 +1,348 @@
+
+#' Display a table in a window
+#'
+#' @param data a data object (either a `matrix` or a `data.frame`).
+#' @param title Title to be displayed in window.
+#' @param show_classes Show variables classes under variables names in table header.
+#' @param type Display table in a pop-up with [shinyWidgets::show_alert()],
+#'  in modal window with [shiny::showModal()] or in a WinBox window with [shinyWidgets::WinBox()].
+#' @param options Arguments passed to [toastui::datagrid()].
+#' @param width Width of the window, only used if `type = "popup"` or `type = "winbox"`.
+#' @param ... Additional options, such as `wbOptions = wbOptions()` or `wbControls = wbControls()`.
+#'
+#' @note
+#' If you use `type = "winbox"`, you'll need to use `shinyWidgets::html_dependency_winbox()` somewhere in your UI.
+#'
+#' @return No value.
+#' @export
+#'
+#' @importFrom htmltools tags tagList css
+#' @importFrom shiny showModal modalDialog
+#' @importFrom utils modifyList packageVersion
+#'
+#' @example examples/show_data.R
+show_data <- function(data,
+                      title = NULL,
+                      options = NULL,
+                      show_classes = TRUE,
+                      type = c("popup", "modal", "winbox"),
+                      width = "65%",
+                      ...) { # nocov start
+  type <- match.arg(type)
+  data <- as.data.frame(data)
+  args <- list(...)
+  gridTheme <- getOption("datagrid.theme")
+  if (length(gridTheme) < 1) {
+    datamods:::apply_grid_theme()
+  }
+  on.exit(toastui::reset_grid_theme())
+
+  if (is.null(options))
+    options <- list()
+
+  options$height <- 550
+  options$minBodyHeight <- 400
+  options$data <- data
+  options$theme <- "default"
+  options$colwidths <- "guess"
+  options$guess_colwidths_opts <- list(min_width = 90, max_width = 400, mul = 1, add = 10)
+  if (isTRUE(show_classes))
+    options$summary <- construct_col_summary(data)
+  datatable <- rlang::exec(toastui::datagrid, !!!options)
+  datatable <- toastui::grid_columns(datatable, className = "font-monospace")
+  if (identical(type, "winbox")) {
+    stopifnot(
+      "You need shinyWidgets >= 0.8.4" = packageVersion("shinyWidgets") >= "0.8.4"
+    )
+    wb_options <- if (is.null(args$wbOptions)) {
+      shinyWidgets::wbOptions(
+        height = "600px",
+        width = width,
+        modal = TRUE
+      )
+    } else {
+      modifyList(
+        shinyWidgets::wbOptions(
+          height = "600px",
+          width = width,
+          modal = TRUE
+        ),
+        args$wbOptions
+      )
+    }
+    wb_controls <- if (is.null(args$wbControls)) {
+      shinyWidgets::wbControls()
+    } else {
+      args$wbControls
+    }
+    shinyWidgets::WinBox(
+      title = title,
+      ui = datatable,
+      options = wb_options,
+      controls = wb_controls,
+      padding = "0 5px"
+    )
+  } else if (identical(type, "popup")) {
+    shinyWidgets::show_alert(
+      title = NULL,
+      text = tags$div(
+        if (!is.null(title)) {
+          tagList(
+            tags$h3(title),
+            tags$hr()
+          )
+        },
+        style = "color: #000 !important;",
+        datatable
+      ),
+      closeOnClickOutside = TRUE,
+      showCloseButton = TRUE,
+      btn_labels = NA,
+      html = TRUE,
+      width = width
+    )
+  } else {
+    showModal(modalDialog(
+      title = tagList(
+        datamods:::button_close_modal(),
+        title
+      ),
+      tags$div(
+        style = css(minHeight = validateCssUnit(options$height)),
+        toastui::renderDatagrid2(datatable)
+      ),
+      size = "xl",
+      footer = NULL,
+      easyClose = TRUE
+    ))
+  }
+} # nocov end
+
+
+
+#' @importFrom htmltools tagList tags css
+describe_col_char <- function(x, with_summary = TRUE) {
+  tags$div(
+    style = css(padding = "3px 0", fontSize = "x-small"),
+    tags$div(
+      style = css(fontStyle = "italic"),
+      get_var_icon(x),
+      # phosphoricons::ph("text-aa"),
+      "character"
+    ),
+    if (with_summary) {
+      tagList(
+        tags$hr(style = css(margin = "3px 0")),
+        tags$div(
+          i18n("Unique:"), length(unique(x))
+        ),
+        tags$div(
+          i18n("Missing:"), sum(is.na(x))
+        ),
+        tags$div(
+          style = css(whiteSpace = "normal", wordBreak = "break-all"),
+          i18n("Most Common:"), gsub(
+            pattern = "'",
+            replacement = "\u07F4",
+            x = names(sort(table(x), decreasing = TRUE))[1]
+          )
+        ),
+        tags$div(
+          "\u00A0"
+        )
+      )
+    }
+  )
+}
+
+fmt_p <- function(val, tot) {
+  paste0(round(val / tot * 100, 1), "%")
+}
+
+describe_col_factor <- function(x, with_summary = TRUE) {
+  count <- sort(table(x, useNA = "always"), decreasing = TRUE)
+  total <- sum(count)
+  one <- count[!is.na(names(count))][1]
+  two <- count[!is.na(names(count))][2]
+  missing <- count[is.na(names(count))]
+  tags$div(
+    style = css(padding = "3px 0", fontSize = "x-small"),
+    tags$div(
+      style = css(fontStyle = "italic"),
+      get_var_icon(x),
+      # phosphoricons::ph("list-bullets"),
+      "factor"
+    ),
+    if (with_summary) {
+      tagList(
+        tags$hr(style = css(margin = "3px 0")),
+        tags$div(
+          names(one), ":", fmt_p(one, total)
+        ),
+        tags$div(
+          names(two), ":", fmt_p(two, total)
+        ),
+        tags$div(
+          "Missing", ":", fmt_p(missing, total)
+        ),
+        tags$div(
+          "\u00A0"
+        )
+      )
+    }
+  )
+}
+
+describe_col_num <- function(x, with_summary = TRUE) {
+  tags$div(
+    style = css(padding = "3px 0", fontSize = "x-small"),
+    tags$div(
+      style = css(fontStyle = "italic"),
+      get_var_icon(x),
+      # phosphoricons::ph("hash"),
+      "numeric"
+    ),
+    if (with_summary) {
+      tagList(
+        tags$hr(style = css(margin = "3px 0")),
+        tags$div(
+          i18n("Min:"), round(min(x, na.rm = TRUE), 2)
+        ),
+        tags$div(
+          i18n("Mean:"), round(mean(x, na.rm = TRUE), 2)
+        ),
+        tags$div(
+          i18n("Max:"), round(max(x, na.rm = TRUE), 2)
+        ),
+        tags$div(
+          i18n("Missing:"), sum(is.na(x))
+        )
+      )
+    }
+  )
+}
+
+
+describe_col_date <- function(x, with_summary = TRUE) {
+  tags$div(
+    style = css(padding = "3px 0", fontSize = "x-small"),
+    tags$div(
+      style = css(fontStyle = "italic"),
+      get_var_icon(x),
+      # phosphoricons::ph("calendar"),
+      "date"
+    ),
+    if (with_summary) {
+      tagList(
+        tags$hr(style = css(margin = "3px 0")),
+        tags$div(
+          i18n("Min:"), min(x, na.rm = TRUE)
+        ),
+        tags$div(
+          i18n("Max:"), max(x, na.rm = TRUE)
+        ),
+        tags$div(
+          i18n("Missing:"), sum(is.na(x))
+        ),
+        tags$div(
+          "\u00A0"
+        )
+      )
+    }
+  )
+}
+
+describe_col_datetime <- function(x, with_summary = TRUE) {
+  tags$div(
+    style = css(padding = "3px 0", fontSize = "x-small"),
+    tags$div(
+      style = css(fontStyle = "italic"),
+      get_var_icon(x),
+      # phosphoricons::ph("clock"),
+      "datetime"
+    ),
+    if (with_summary) {
+      tagList(
+        tags$hr(style = css(margin = "3px 0")),
+        tags$div(
+          i18n("Min:"), min(x, na.rm = TRUE)
+        ),
+        tags$div(
+          i18n("Max:"), max(x, na.rm = TRUE)
+        ),
+        tags$div(
+          i18n("Missing:"), sum(is.na(x))
+        ),
+        tags$div(
+          "\u00A0"
+        )
+      )
+    }
+  )
+}
+
+
+describe_col_other <- function(x, with_summary = TRUE) {
+  tags$div(
+    style = css(padding = "3px 0", fontSize = "x-small"),
+    tags$div(
+      style = css(fontStyle = "italic"),
+      get_var_icon(x),
+      # phosphoricons::ph("clock"),
+      paste(class(x), collapse = ", ")
+    ),
+    if (with_summary) {
+      tagList(
+        tags$hr(style = css(margin = "3px 0")),
+        tags$div(
+          i18n("Unique:"), length(unique(x))
+        ),
+        tags$div(
+          i18n("Missing:"), sum(is.na(x))
+        ),
+        tags$div(
+          "\u00A0"
+        ),
+        tags$div(
+          "\u00A0"
+        )
+      )
+    }
+  )
+}
+
+construct_col_summary <- function(data) {
+  list(
+    position = "top",
+    height = 90,
+    columnContent = lapply(
+      X = setNames(names(data), names(data)),
+      FUN = function(col) {
+        values <- data[[col]]
+        content <- if (inherits(values, "character")) {
+          describe_col_char(values)
+        } else if (inherits(values, "factor")) {
+          describe_col_factor(values)
+        } else if (inherits(values, c("numeric", "integer"))) {
+          describe_col_num(values)
+        } else if (inherits(values, c("Date"))) {
+          describe_col_date(values)
+        } else if (inherits(values, c("POSIXt"))) {
+          describe_col_datetime(values)
+        } else {
+          describe_col_other(values)
+        }
+        list(
+          template = toastui::JS(
+            "function(value) {",
+            sprintf(
+              "return '%s';",
+              gsub(replacement = "", pattern = "\n", x = htmltools::doRenderTags(content))
+            ),
+            "}"
+          )
+        )
+      }
+    )
+  )
+}

R/html_dependency_freesearchr.R

@@ -0,0 +1,9 @@
+html_dependency_FreesearchR <- function() {
+  htmltools::htmlDependency(
+    name = "FreesearchR",
+    version = packageVersion("FreesearchR"),
+    src = list(href = "FreesearchR", file = "assets"),
+    package = "FreesearchR",
+    stylesheet = "css/FreesearchR.css"
+  )
+}

R/theme.R

@@ -6,23 +6,23 @@
 #' @export
 custom_theme <- function(...,
                          version = 5,
-                         primary = "#1E4A8F",
+                         primary = FreesearchR_colors("primary"),
-                         secondary = "#FF6F61",
+                         secondary = FreesearchR_colors("secondary"),
                          bootswatch = "united",
                          base_font = bslib::font_google("Montserrat"),
-                         heading_font = bslib::font_google("Public Sans",wght = "700"),
+                         heading_font = bslib::font_google("Public Sans", wght = "700"),
-                         code_font = bslib::font_google("Open Sans")
+                         code_font = bslib::font_google("Open Sans"),
-                         # success = "#1E4A8F",
+                         success = FreesearchR_colors("success"),
-                         # info = ,
+                         info = FreesearchR_colors("info"),
-                         # warning = ,
+                         warning = FreesearchR_colors("warning"),
-                         # danger = ,
+                         danger = FreesearchR_colors("danger")
                          # fg = "#000",
                          # bg="#fff",
                          # base_font = bslib::font_google("Alice"),
                          # heading_font = bslib::font_google("Jost", wght = "800"),
                          # heading_font = bslib::font_google("Noto Serif"),
                          # heading_font = bslib::font_google("Alice"),
-                         ){
+) {
   bslib::bs_theme(
     ...,
     "navbar-bg" = primary,
@@ -32,10 +32,37 @@ custom_theme <- function(...,
     bootswatch = bootswatch,
     base_font = base_font,
     heading_font = heading_font,
-    code_font = code_font
+    code_font = code_font,
+    success=success,
+    info=info,
+    warning=warning,
+    danger=danger
   )
 }
 
+FreesearchR_colors <- function(choose = NULL) {
+  out <- c(
+    primary = "#1E4A8F",
+    secondary = "#FF6F61",
+    success = "#00C896",
+    warning = "#FFB100",
+    danger = "#FF3A2F",
+    extra = "#8A4FFF",
+    info = "#11A0EC",
+    bg = "#FFFFFF",
+    dark = "#2D2D42",
+    fg = "#000000"
+  )
+  if (!is.null(choose)) {
+    out[choose]
+  } else {
+    out
+  }
+}
+
+
+
+
 
 #' GGplot default theme for plotting in Shiny
 #'
@@ -44,7 +71,7 @@ custom_theme <- function(...,
 #' @returns ggplot object
 #' @export
 #'
-gg_theme_shiny <- function(){
+gg_theme_shiny <- function() {
   ggplot2::theme(
     axis.title = ggplot2::element_text(size = 18),
     axis.text = ggplot2::element_text(size = 14),
@@ -64,7 +91,7 @@ gg_theme_shiny <- function(){
 #' @returns ggplot object
 #' @export
 #'
-gg_theme_export <- function(){
+gg_theme_export <- function() {
   ggplot2::theme(
     axis.title = ggplot2::element_text(size = 18),
     axis.text.x = ggplot2::element_text(size = 14),

README.md

@@ -4,12 +4,12 @@
 [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental)
 [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.14527429.svg)](https://doi.org/10.5281/zenodo.14527429) 
 [![rhub](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml/badge.svg)](https://github.com/agdamsbo/FreesearchR/actions/workflows/rhub.yaml)
-[![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/freesearcheR/)
+[![FreesearchR](https://img.shields.io/badge/Shiny-shinyapps.io-blue?style=flat&labelColor=white&logo=RStudio&logoColor=blue)](https://agdamsbo.shinyapps.io/FreesearchR/)
 <!-- badges: end -->
 
 This package is the backbone of the ***FreesearchR***, a free and open-source browser based data exploration and analysis tool intended to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results.
 
-The ***FreesearchR***-tool is online and accessible here: [link to the app freely hosted on shinyapps.io](https://agdamsbo.shinyapps.io/FreesearcheR/). All feedback is welcome and can be shared as a GitHub issue. Any suggestions on collaboration is much welcomed. Please reach out!
+The ***FreesearchR***-tool is online and accessible here: [link to the app freely hosted on shinyapps.io](https://agdamsbo.shinyapps.io/FreesearchR/). All feedback is welcome and can be shared as a GitHub issue. Any suggestions on collaboration is much welcomed. Please reach out!
 
 ## Motivation
 

SESSION.md

@@ -11,11 +11,11 @@
 |collate     |en_US.UTF-8                                |
 |ctype       |en_US.UTF-8                                |
 |tz          |Europe/Copenhagen                          |
-|date        |2025-04-23                                 |
+|date        |2025-04-24                                 |
 |rstudio     |2024.12.1+563 Kousa Dogwood (desktop)      |
 |pandoc      |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
 |quarto      |1.6.40 @ /usr/local/bin/quarto             |
-|FreesearchR |25.4.3.250423                              |
+|FreesearchR |25.4.3.250424                              |
                                                                                 
                                                                                 
 --------------------------------------------------------------------------------
@@ -39,8 +39,7 @@
 |cellranger    |1.1.0         |2016-07-27 |CRAN (R 4.4.0) |
 |class         |7.3-23        |2025-01-01 |CRAN (R 4.4.1) |
 |classInt      |0.4-11        |2025-01-08 |CRAN (R 4.4.1) |
-|cli           |3.6.4         |2025-02-13 |CRAN (R 4.4.1) |
+|cli           |3.6.5         |2025-04-23 |CRAN (R 4.4.1) |
-|clipr         |0.8.0         |2022-02-22 |CRAN (R 4.4.1) |
 |colorspace    |2.1-1         |2024-07-26 |CRAN (R 4.4.1) |
 |commonmark    |1.9.5         |2025-03-17 |CRAN (R 4.4.1) |
 |correlation   |0.8.7         |2025-03-03 |CRAN (R 4.4.1) |
@@ -60,7 +59,6 @@
 |easystats     |0.7.4         |2025-02-06 |CRAN (R 4.4.1) |
 |effectsize    |1.0.0         |2024-12-10 |CRAN (R 4.4.1) |
 |ellipsis      |0.3.2         |2021-04-29 |CRAN (R 4.4.1) |
-|esquisse      |2.1.0         |2025-02-21 |CRAN (R 4.4.1) |
 |evaluate      |1.0.3         |2025-01-10 |CRAN (R 4.4.1) |
 |farver        |2.1.2         |2024-05-13 |CRAN (R 4.4.1) |
 |fastmap       |1.2.0         |2024-05-15 |CRAN (R 4.4.1) |
@@ -90,7 +88,6 @@
 |lattice       |0.22-7        |2025-04-02 |CRAN (R 4.4.1) |
 |lifecycle     |1.0.4         |2023-11-07 |CRAN (R 4.4.1) |
 |lme4          |1.1-37        |2025-03-26 |CRAN (R 4.4.1) |
-|magick        |2.8.6         |NA         |NA             |
 |magrittr      |2.0.3         |2022-03-30 |CRAN (R 4.4.1) |
 |MASS          |7.3-65        |2025-02-28 |CRAN (R 4.4.1) |
 |Matrix        |1.7-3         |2025-03-11 |CRAN (R 4.4.1) |
@@ -104,7 +101,6 @@
 |nloptr        |2.2.1         |2025-03-17 |CRAN (R 4.4.1) |
 |openssl       |2.3.2         |2025-02-03 |CRAN (R 4.4.1) |
 |openxlsx2     |1.14          |2025-03-20 |CRAN (R 4.4.1) |
-|pak           |0.8.0.2       |2025-04-08 |CRAN (R 4.4.1) |
 |parameters    |0.24.2        |2025-03-04 |CRAN (R 4.4.1) |
 |patchwork     |1.3.0         |2024-09-16 |CRAN (R 4.4.1) |
 |performance   |0.13.0        |2025-01-15 |CRAN (R 4.4.1) |
@@ -112,7 +108,6 @@
 |pillar        |1.10.2        |2025-04-05 |CRAN (R 4.4.1) |
 |pkgbuild      |1.4.7         |2025-03-24 |CRAN (R 4.4.1) |
 |pkgconfig     |2.0.3         |2019-09-22 |CRAN (R 4.4.1) |
-|pkgdown       |2.1.1         |2024-09-17 |CRAN (R 4.4.1) |
 |pkgload       |1.4.0         |2024-06-28 |CRAN (R 4.4.0) |
 |processx      |3.8.6         |2025-02-21 |CRAN (R 4.4.1) |
 |profvis       |0.4.0         |2024-09-20 |CRAN (R 4.4.1) |
@@ -121,6 +116,10 @@
 |ps            |1.9.1         |2025-04-12 |CRAN (R 4.4.1) |
 |purrr         |1.0.4         |2025-02-05 |CRAN (R 4.4.1) |
 |quarto        |1.4.4         |2024-07-20 |CRAN (R 4.4.0) |
+|R.cache       |0.16.0        |2022-07-21 |CRAN (R 4.4.0) |
+|R.methodsS3   |1.8.2         |2022-06-13 |CRAN (R 4.4.1) |
+|R.oo          |1.27.0        |2024-11-01 |CRAN (R 4.4.1) |
+|R.utils       |2.13.0        |2025-02-24 |CRAN (R 4.4.1) |
 |R6            |2.6.1         |2025-02-15 |CRAN (R 4.4.1) |
 |rbibutils     |2.3           |2024-10-04 |CRAN (R 4.4.1) |
 |RColorBrewer  |1.1-3         |2022-04-03 |CRAN (R 4.4.1) |
@@ -130,6 +129,8 @@
 |readODS       |2.3.2         |2025-01-13 |CRAN (R 4.4.1) |
 |readr         |2.1.5         |2024-01-10 |CRAN (R 4.4.0) |
 |readxl        |1.4.5         |2025-03-07 |CRAN (R 4.4.1) |
+|REDCapCAST    |25.3.2        |2025-03-10 |CRAN (R 4.4.1) |
+|REDCapR       |1.4.0         |2025-01-11 |CRAN (R 4.4.1) |
 |reformulas    |0.4.0         |2024-11-03 |CRAN (R 4.4.1) |
 |remotes       |2.5.0         |2024-03-17 |CRAN (R 4.4.1) |
 |renv          |1.1.4         |2025-03-20 |CRAN (R 4.4.1) |
@@ -149,6 +150,7 @@
 |shinyTime     |1.0.3         |2022-08-19 |CRAN (R 4.4.0) |
 |shinyWidgets  |0.9.0         |2025-02-21 |CRAN (R 4.4.1) |
 |stringi       |1.8.7         |2025-03-27 |CRAN (R 4.4.1) |
+|styler        |1.10.3        |2024-04-07 |CRAN (R 4.4.0) |
 |tibble        |3.2.1         |2023-03-20 |CRAN (R 4.4.0) |
 |tidyr         |1.3.1         |2024-01-24 |CRAN (R 4.4.1) |
 |tidyselect    |1.2.1         |2024-03-11 |CRAN (R 4.4.0) |

examples/create_column_module_demo.R

@@ -0,0 +1,69 @@
+
+library(shiny)
+library(reactable)
+
+ui <- fluidPage(
+  theme = bslib::bs_theme(version = 5L, preset = "bootstrap"),
+  shinyWidgets::html_dependency_winbox(),
+  tags$h2("Create new column"),
+  fluidRow(
+    column(
+      width = 4,
+      create_column_ui("inline"),
+      actionButton("modal", "Or click here to open a modal to create a column"),
+      tags$br(), tags$br(),
+      actionButton("winbox", "Or click here to open a WinBox to create a column")
+    ),
+    column(
+      width = 8,
+      reactableOutput(outputId = "table"),
+      verbatimTextOutput("code")
+    )
+  )
+)
+
+server <- function(input, output, session) {
+
+  rv <- reactiveValues(data = MASS::Cars93[, c(1, 3, 4, 5, 6, 10)])
+
+  # inline mode
+  data_inline_r <- create_column_server(
+    id = "inline",
+    data_r = reactive(rv$data)
+  )
+  observeEvent(data_inline_r(), rv$data <- data_inline_r())
+
+  # modal window mode
+  observeEvent(input$modal, modal_create_column("modal"))
+  data_modal_r <- create_column_server(
+    id = "modal",
+    data_r = reactive(rv$data)
+  )
+  observeEvent(data_modal_r(), rv$data <- data_modal_r())
+
+  # WinBox window mode
+  observeEvent(input$winbox, winbox_create_column("winbox"))
+  data_winbox_r <- create_column_server(
+    id = "winbox",
+    data_r = reactive(rv$data)
+  )
+  observeEvent(data_winbox_r(), rv$data <- data_winbox_r())
+
+  # Show result
+  output$table <- renderReactable({
+    data <- req(rv$data)
+    reactable(
+      data = data,
+      bordered = TRUE,
+      compact = TRUE,
+      striped = TRUE
+    )
+  })
+
+  output$code <- renderPrint({
+    attr(rv$data, "code")
+  })
+}
+
+if (interactive())
+  shinyApp(ui, server)

inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/FreesearchR.dcf

@@ -0,0 +1,10 @@
+name: FreesearchR
+title:
+username: agdamsbo
+account: agdamsbo
+server: shinyapps.io
+hostUrl: https://api.shinyapps.io/v1
+appId: 14600805
+bundleId: 10170173
+url: https://agdamsbo.shinyapps.io/FreesearchR/
+version: 1

inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf

@@ -5,6 +5,6 @@ account: agdamsbo
 server: shinyapps.io
 hostUrl: https://api.shinyapps.io/v1
 appId: 13611288
-bundleId: 10164419
+bundleId: 10164589
 url: https://agdamsbo.shinyapps.io/freesearcheR/
 version: 1

inst/apps/FreesearchR/server.R

@@ -2,7 +2,7 @@ library(readr)
 library(MASS)
 library(stats)
 library(gt)
-library(openxlsx2)
+# library(openxlsx2)
 library(haven)
 library(readODS)
 require(shiny)
@@ -15,16 +15,16 @@ library(broom)
 library(broom.helpers)
 # library(REDCapCAST)
 library(easystats)
-library(esquisse)
+# library(esquisse)
 library(patchwork)
 library(DHARMa)
 library(apexcharter)
 library(toastui)
 library(datamods)
-library(data.table)
 library(IDEAFilter)
 library(shinyWidgets)
 library(DT)
+library(data.table)
 library(gtsummary)
 # library(FreesearchR)
 
@@ -32,7 +32,8 @@ library(gtsummary)
 
 data(starwars)
 data(mtcars)
-mtcars <- mtcars |> append_column(as.Date(sample(1:365, nrow(mtcars))), "rand_dates")
+mtcars_date <- mtcars |> append_column(as.Date(sample(1:365, nrow(mtcars))), "rand_dates")
+mtcars_date$date <- as.Date(sample(seq_len(365),nrow(mtcars)))
 data(trial)
 
 
@@ -189,8 +190,11 @@ server <- function(input, output, session) {
       rv$data_original <- temp_data |>
         default_parsing()
 
-      rv$code$import_print <- list(
+      rv$code$import <- rv$code$import |>
-        rv$code$import,
+        expression_string(assign.str = "df <-")
+
+      rv$code$format <- list(
+        "df",
         rlang::expr(dplyr::select(dplyr::all_of(!!input$import_var))),
         rlang::call2(.fn = "default_parsing", .ns = "FreesearchR")
       ) |>
@@ -315,13 +319,13 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     input$modal_column,
-    datamods::modal_create_column(
+    modal_create_column(
       id = "modal_column",
-      footer = "This window is aimed at advanced users and require some R-experience!",
+      footer = shiny::markdown("This window is aimed at advanced users and require some *R*-experience!"),
       title = "Create new variables"
     )
   )
-  data_modal_r <- datamods::create_column_server(
+  data_modal_r <- create_column_server(
     id = "modal_column",
     data_r = reactive(rv$data)
   )
@@ -444,7 +448,7 @@ server <- function(input, output, session) {
   )
 
   observeEvent(input$modal_browse, {
-    datamods::show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal")
+    show_data(REDCapCAST::fct_drop(rv$data_filtered), title = "Uploaded data overview", type = "modal")
   })
 
   output$original_str <- renderPrint({
@@ -475,7 +479,11 @@ server <- function(input, output, session) {
   # })
 
   output$code_import <- shiny::renderUI({
-    prismCodeBlock(paste0("#Data import\n", rv$code$import_print))
+    prismCodeBlock(paste0("#Data import\n", rv$code$import))
+  })
+
+  output$code_import <- shiny::renderUI({
+    prismCodeBlock(paste0("#Data import formatting\n", rv$code$format))
   })
 
   output$code_data <- shiny::renderUI({

inst/apps/FreesearchR/ui.R

@@ -197,7 +197,8 @@ ui_elements <- list(
           update_variables_ui("modal_variables"),
           shiny::tags$br(),
           shiny::tags$br(),
-          tags$h4("Advanced data manipulation"),
+          shiny::tags$h4("Advanced data manipulation"),
+          shiny::tags$p("Below options allow more advanced varaible manipulations."),
           shiny::tags$br(),
           shiny::tags$br(),
           shiny::fluidRow(
@@ -210,6 +211,7 @@ ui_elements <- list(
               ),
               shiny::tags$br(),
               shiny::helpText("Reorder the levels of factor/categorical variables."),
+              shiny::tags$br(),
               shiny::tags$br()
             ),
             shiny::column(
@@ -221,6 +223,7 @@ ui_elements <- list(
               ),
               shiny::tags$br(),
               shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time)."),
+              shiny::tags$br(),
               shiny::tags$br()
             ),
             shiny::column(
@@ -232,10 +235,10 @@ ui_elements <- list(
               ),
               shiny::tags$br(),
               shiny::helpText(shiny::markdown("Create a new variable/column based on an *R*-expression.")),
+              shiny::tags$br(),
               shiny::tags$br()
             )
           ),
-          shiny::tags$br(),
           tags$h4("Compare modified data to original"),
           shiny::tags$br(),
           shiny::tags$p(
@@ -462,7 +465,7 @@ ui_elements <- list(
           shiny::tagList(
             lapply(
               paste0("code_", c(
-                "import", "data", "variables", "filter", "table1", "univariable", "multivariable"
+                "import", "format", "data", "variables", "filter", "table1", "univariable", "multivariable"
               )),
               \(.x)shiny::htmlOutput(outputId = .x)
             )
@@ -507,15 +510,9 @@ dark <- custom_theme(
 ui <- bslib::page_fixed(
   prismDependencies,
   prismRDependency,
-  shiny::tags$head(includeHTML(("www/umami-app.html"))),
+  shiny::tags$head(
-  shiny::tags$style(
+    includeHTML(("www/umami-app.html")),
-    type = "text/css",
+    tags$link(rel = "stylesheet", type = "text/css", href = "style.css")),
-    # add the name of the tab you want to use as title in data-value
-    shiny::HTML(
-      ".container-fluid > .nav > li >
-                        a[data-value='FreesearchR'] {font-size: 28px}"
-    )
-  ),
   title = "FreesearchR",
   theme = light,
   shiny::useBusyIndicators(),

inst/apps/FreesearchR/www/references.bib

@@ -1,24 +1,11 @@
 
 @book{andreasgammelgaarddamsbo2025,
-	title = {agdamsbo/freesearcheR: freesearcheR 25.3.1},
+	title = {agdamsbo/FreesearchR: FreesearchR 25.4.3},
-	author = {Andreas Gammelgaard Damsbo, },
+	author = {Damsbo, Andreas Gammelgaard},
 	year = {2025},
-	month = {03},
+	month = {04},
-	date = {2025-03-06},
+	date = {2025-04-24},
 	publisher = {Zenodo},
 	doi = {10.5281/ZENODO.14527429},
 	url = {https://zenodo.org/doi/10.5281/zenodo.14527429}
 }
-
-@article{Aam2020,
-	title = {Post-stroke Cognitive Impairment{\textemdash}Impact of Follow-Up Time and Stroke Subtype on Severity and Cognitive Profile: The Nor-COAST Study},
-	author = {Aam, Stina and Einstad, Marte Stine and Munthe-Kaas, Ragnhild and Lydersen, Stian and Ihle-Hansen, Hege and Knapskog, Anne Brita and {Ellekjær}, Hanne and Seljeseth, Yngve and Saltvedt, Ingvild},
-	year = {2020},
-	date = {2020},
-	journal = {Frontiers in Neurology},
-	pages = {1--10},
-	volume = {11},
-	number = {July},
-	doi = {10.3389/fneur.2020.00699},
-	note = {Citation Key: Aam2020}
-}

inst/apps/FreesearchR/www/style.css

@@ -0,0 +1,124 @@
+
+/*!
+ * Copyright (c) 2025 FreesearchR
+ *
+ * FreesearchR, CSS styles
+ * https://github.com/agdamsbo/FreesearchR
+ *
+ * @version 0.0.1
+ */
+
+.container-fluid > .nav > li >
+                        a[data-value='FreesearchR'] {font-size: 28px}
+
+/* from datamods */
+.show-block {
+  display: block !important;
+}
+.show-inline {
+  display: inline !important;
+}
+.hidden {
+  display: none !important;
+}
+.invisible {
+  visibility: hidden;
+}
+
+.container-rule {
+  position: relative;
+  text-align: center;
+  height: 25px;
+  margin-bottom: 5px;
+}
+
+.horizontal-rule {
+  position: absolute;
+  top: 11px;
+  right: 0;
+  left: 0;
+  background-color: #d0cfcf;
+  height: 1px;
+  z-index: 100;
+  margin: 0;
+  border: none;
+}
+
+.label-rule {
+  background: #FFF;
+  opacity: 1;
+  z-index: 101;
+  background-color: #FFF;
+  position: relative;
+  padding: 0 10px 0 10px;
+}
+
+.datamods-table-container {
+  overflow: auto;
+  word-break: keep-all;
+  white-space: nowrap;
+}
+
+.datamods-table-container > .table {
+  margin-bottom: 0 !important;
+}
+
+.datamods-file-import {
+  display: grid;
+  grid-template-columns: auto 50px;
+  grid-column-gap: 10px;
+}
+
+.datamods-dt-nowrap {
+  word-break: keep-all;
+  white-space: nowrap;
+}
+
+
+
+/* validation */
+.datamods-validation-results {
+  display: grid;
+  grid-template-columns: repeat(3, 1fr);
+  grid-template-rows: 1fr;
+  height: 50px;
+  line-height: 50px;
+  font-size: large;
+}
+
+.datamods-validation-summary {
+  font-weight: bold;
+  text-align: center;
+}
+
+.datamods-validation-item {
+  font-size: larger;
+}
+
+
+
+/* modified from esquisse for data types */
+.btn-column-categorical {
+  background-color: #00C896;
+  color: #FFFFFF;
+}
+.btn-column-continuous {
+  background-color: #FFB100;
+  color: #FFFFFF;
+}
+.btn-column-dichotomous {
+  background-color: #8A4FFF;
+  color: #FFFFFF;
+}
+.btn-column-datetime {
+  background-color: #11A0EC;
+  color: #FFFFFF;
+}
+.btn-column-id {
+  background-color: #848484;
+  color: #FFFFFF;
+}
+.btn-column-text {
+  background-color: #2E2E2E;
+  color: #FFFFFF;
+}

inst/assets/css/FreesearchR.css

@@ -0,0 +1,124 @@
+
+/*!
+ * Copyright (c) 2025 FreesearchR
+ *
+ * FreesearchR, CSS styles
+ * https://github.com/agdamsbo/FreesearchR
+ *
+ * @version 0.0.1
+ */
+
+.container-fluid > .nav > li >
+                        a[data-value='FreesearchR'] {font-size: 28px}
+
+/* from datamods */
+.show-block {
+  display: block !important;
+}
+.show-inline {
+  display: inline !important;
+}
+.hidden {
+  display: none !important;
+}
+.invisible {
+  visibility: hidden;
+}
+
+.container-rule {
+  position: relative;
+  text-align: center;
+  height: 25px;
+  margin-bottom: 5px;
+}
+
+.horizontal-rule {
+  position: absolute;
+  top: 11px;
+  right: 0;
+  left: 0;
+  background-color: #d0cfcf;
+  height: 1px;
+  z-index: 100;
+  margin: 0;
+  border: none;
+}
+
+.label-rule {
+  background: #FFF;
+  opacity: 1;
+  z-index: 101;
+  background-color: #FFF;
+  position: relative;
+  padding: 0 10px 0 10px;
+}
+
+.datamods-table-container {
+  overflow: auto;
+  word-break: keep-all;
+  white-space: nowrap;
+}
+
+.datamods-table-container > .table {
+  margin-bottom: 0 !important;
+}
+
+.datamods-file-import {
+  display: grid;
+  grid-template-columns: auto 50px;
+  grid-column-gap: 10px;
+}
+
+.datamods-dt-nowrap {
+  word-break: keep-all;
+  white-space: nowrap;
+}
+
+
+
+/* validation */
+.datamods-validation-results {
+  display: grid;
+  grid-template-columns: repeat(3, 1fr);
+  grid-template-rows: 1fr;
+  height: 50px;
+  line-height: 50px;
+  font-size: large;
+}
+
+.datamods-validation-summary {
+  font-weight: bold;
+  text-align: center;
+}
+
+.datamods-validation-item {
+  font-size: larger;
+}
+
+
+
+/* modified from esquisse for data types */
+.btn-column-categorical {
+  background-color: #00C896;
+  color: #FFFFFF;
+}
+.btn-column-continuous {
+  background-color: #FFB100;
+  color: #FFFFFF;
+}
+.btn-column-dichotomous {
+  background-color: #8A4FFF;
+  color: #FFFFFF;
+}
+.btn-column-datetime {
+  background-color: #11A0EC;
+  color: #FFFFFF;
+}
+.btn-column-id {
+  background-color: #848484;
+  color: #FFFFFF;
+}
+.btn-column-text {
+  background-color: #2E2E2E;
+  color: #FFFFFF;
+}

man/create-column.Rd

@@ -0,0 +1,76 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/create-column-mod.R
+\name{create-column}
+\alias{create-column}
+\alias{create_column_ui}
+\alias{create_column_server}
+\alias{list_allowed_operations}
+\alias{modal_create_column}
+\alias{winbox_create_column}
+\title{Create new column}
+\usage{
+create_column_ui(id)
+
+create_column_server(
+  id,
+  data_r = reactive(NULL),
+  allowed_operations = list_allowed_operations()
+)
+
+list_allowed_operations()
+
+modal_create_column(
+  id,
+  title = i18n("Create a new column"),
+  easyClose = TRUE,
+  size = "l",
+  footer = NULL
+)
+
+winbox_create_column(
+  id,
+  title = i18n("Create a new column"),
+  options = shinyWidgets::wbOptions(),
+  controls = shinyWidgets::wbControls()
+)
+}
+\arguments{
+\item{id}{Module's ID.}
+
+\item{data_r}{A \code{\link[shiny:reactive]{shiny::reactive()}} function returning a \code{data.frame}.}
+
+\item{allowed_operations}{A \code{list} of allowed operations, see below for details.}
+
+\item{title}{An optional title for the dialog.}
+
+\item{easyClose}{If \code{TRUE}, the modal dialog can be dismissed by
+clicking outside the dialog box, or be pressing the Escape key. If
+\code{FALSE} (the default), the modal dialog can't be dismissed in those
+ways; instead it must be dismissed by clicking on a \code{modalButton()}, or
+from a call to \code{\link[shiny:removeModal]{removeModal()}} on the server.}
+
+\item{size}{One of \code{"s"} for small, \code{"m"} (the default) for medium,
+\code{"l"} for large, or \code{"xl"} for extra large. Note that \code{"xl"} only
+works with Bootstrap 4 and above (to opt-in to Bootstrap 4+,
+pass \code{\link[bslib:bs_theme]{bslib::bs_theme()}} to the \code{theme} argument of a page container
+like \code{\link[shiny:fluidPage]{fluidPage()}}).}
+
+\item{footer}{UI for footer. Use \code{NULL} for no footer.}
+
+\item{options}{List of options, see \code{\link[shinyWidgets:wbOptions]{wbOptions()}}.}
+
+\item{controls}{List of controls, see \code{\link[shinyWidgets:wbControls]{wbControls()}}.}
+}
+\value{
+A \code{\link[shiny:reactive]{shiny::reactive()}} function returning the data.
+}
+\description{
+This module allow to enter an expression to create a new column in a \code{data.frame}.
+}
+\note{
+User can only use a subset of function: (, c, +, -, *, ^, \%\%, \%/\%, /, ==, >, <, !=, <=, >=, &, |, abs, sign, sqrt, ceiling, floor, trunc, cummax, cummin, cumprod, cumsum, exp, expm1, log, log10, log2, log1p, cos, cosh, sin, sinh, tan, tanh, acos, acosh, asin, asinh, atan, atanh, cospi, sinpi, tanpi, gamma, lgamma, digamma, trigamma, round, signif, max, min, range, prod, sum, any, all, pmin, pmax, mean, paste, paste0, substr, nchar, trimws, gsub, sub, grepl, ifelse, length, as.numeric, as.character, as.integer, as.Date, as.POSIXct, as.factor, factor.
+You can add more operations using the \code{allowed_operations} argument, for  example if you want to allow to use package lubridate, you can do:
+
+\if{html}{\out{<div class="sourceCode r">}}\preformatted{c(list_allowed_operations(), getNamespaceExports("lubridate"))
+}\if{html}{\out{</div>}}
+}

man/cut_var.Rd

@@ -33,7 +33,7 @@ cut_var(x, ...)
   ...
 )
 
-\method{cut_var}{Date}(x, breaks, start.on.monday = TRUE, ...)
+\method{cut_var}{Date}(x, breaks = NULL, start.on.monday = TRUE, ...)
 }
 \arguments{
 \item{x}{an object inheriting from class "POSIXct"}
@@ -58,6 +58,8 @@ readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-0
 readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
 readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "month_only")
 readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "\%A-\%H")
+readr::parse_datetime(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks=NULL,format = "\%W")
 as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(2)
 as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(breaks = "weekday")
+as.Date(c("1992-02-01 01:00:20", "1992-02-06 03:00:20", "1992-05-01 01:20:20", "1992-09-01 08:20:20", "1999-02-01 21:20:20", "1992-12-01 03:02:20")) |> cut_var(format = "\%W")
 }

man/get_var_icon.Rd

@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/data-summary.R
+\name{get_var_icon}
+\alias{get_var_icon}
+\title{Easily get variable icon based on data type or class}
+\usage{
+get_var_icon(data, class.type = c("class", "type"))
+}
+\arguments{
+\item{data}{variable or data frame}
+
+\item{class.type}{"type" or "class". Default is "class"}
+}
+\value{
+svg icon
+}
+\description{
+Easily get variable icon based on data type or class
+}
+\examples{
+mtcars[1] |> get_var_icon("class")
+default_parsing(mtcars) |> get_var_icon()
+}

man/show_data.Rd

@@ -0,0 +1,41 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datagrid-infos-mod.R
+\name{show_data}
+\alias{show_data}
+\title{Display a table in a window}
+\usage{
+show_data(
+  data,
+  title = NULL,
+  options = NULL,
+  show_classes = TRUE,
+  type = c("popup", "modal", "winbox"),
+  width = "65\%",
+  ...
+)
+}
+\arguments{
+\item{data}{a data object (either a \code{matrix} or a \code{data.frame}).}
+
+\item{title}{Title to be displayed in window.}
+
+\item{options}{Arguments passed to \code{\link[toastui:datagrid]{toastui::datagrid()}}.}
+
+\item{show_classes}{Show variables classes under variables names in table header.}
+
+\item{type}{Display table in a pop-up with \code{\link[shinyWidgets:sweetalert]{shinyWidgets::show_alert()}},
+in modal window with \code{\link[shiny:showModal]{shiny::showModal()}} or in a WinBox window with \code{\link[shinyWidgets:WinBox]{shinyWidgets::WinBox()}}.}
+
+\item{width}{Width of the window, only used if \code{type = "popup"} or \code{type = "winbox"}.}
+
+\item{...}{Additional options, such as \code{wbOptions = wbOptions()} or \code{wbControls = wbControls()}.}
+}
+\value{
+No value.
+}
+\description{
+Display a table in a window
+}
+\note{
+If you use \code{type = "winbox"}, you'll need to use \code{shinyWidgets::html_dependency_winbox()} somewhere in your UI.
+}

renv.lock

@@ -1792,7 +1792,7 @@
     },
     "cli": {
       "Package": "cli",
-      "Version": "3.6.4",
+      "Version": "3.6.5",
       "Source": "Repository",
       "Title": "Helpers for Developing Command Line Interfaces",
       "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"gabor@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Kirill\", \"Müller\", role = \"ctb\"), person(\"Salim\", \"Brüggemann\", , \"salim-b@pm.me\", role = \"ctb\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )",

umami-page.html

@@ -1 +1 @@
-<script defer src="https://analytics.gdamsbo.dk/script.js" data-website-id="1f3baf18-29aa-4612-931b-58ea35922ae4"></script>
+<script defer src="https://analytics.gdamsbo.dk/script.js" data-website-id="e7d4e13a-5824-4778-bbc0-8f92fb08303a"></script>