diff --git a/NAMESPACE b/NAMESPACE index f644c440..186ab21a 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index af77b755..3dd549ca 100644 --- a/NEWS.md +++ b/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. diff --git a/R/app_version.R b/R/app_version.R index 1fbe1ecb..c99b8062 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'v25.4.3.250423' +app_version <- function()'v25.4.3.250424' diff --git a/R/create-column-mod.R b/R/create-column-mod.R new file mode 100644 index 00000000..f25dbdd8 --- /dev/null +++ b/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 + ) + } + ) +} diff --git a/R/cut-variable-dates.R b/R/cut-variable-dates.R index e18f6150..d3f95eb5 100644 --- a/R/cut-variable-dates.R +++ b/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)) diff --git a/R/data-summary.R b/R/data-summary.R index f0e6be3f..ccb749bc 100644 --- a/R/data-summary.R +++ b/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() + } + ) +} + +} diff --git a/R/datagrid-infos-mod.R b/R/datagrid-infos-mod.R new file mode 100644 index 00000000..6958e6be --- /dev/null +++ b/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)) + ), + "}" + ) + ) + } + ) + ) +} diff --git a/R/html_dependency_freesearchr.R b/R/html_dependency_freesearchr.R new file mode 100644 index 00000000..bf46e471 --- /dev/null +++ b/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" + ) +} diff --git a/R/sysdata.rda b/R/sysdata.rda index b9989b2e..51dd6d09 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/theme.R b/R/theme.R index 15fc5f4b..d0852ada 100644 --- a/R/theme.R +++ b/R/theme.R @@ -6,23 +6,23 @@ #' @export custom_theme <- function(..., version = 5, - primary = "#1E4A8F", - secondary = "#FF6F61", + primary = FreesearchR_colors("primary"), + secondary = FreesearchR_colors("secondary"), bootswatch = "united", base_font = bslib::font_google("Montserrat"), - heading_font = bslib::font_google("Public Sans",wght = "700"), - code_font = bslib::font_google("Open Sans") - # success = "#1E4A8F", - # info = , - # warning = , - # danger = , + heading_font = bslib::font_google("Public Sans", wght = "700"), + code_font = bslib::font_google("Open Sans"), + success = FreesearchR_colors("success"), + info = FreesearchR_colors("info"), + warning = FreesearchR_colors("warning"), + 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,16 +71,16 @@ custom_theme <- function(..., #' @returns ggplot object #' @export #' -gg_theme_shiny <- function(){ - ggplot2::theme( - axis.title = ggplot2::element_text(size = 18), - axis.text = ggplot2::element_text(size = 14), - strip.text = ggplot2::element_text(size = 14), - legend.title = ggplot2::element_text(size = 18), - legend.text = ggplot2::element_text(size = 14), - plot.title = ggplot2::element_text(size = 24), - plot.subtitle = ggplot2::element_text(size = 18) - ) +gg_theme_shiny <- function() { + ggplot2::theme( + axis.title = ggplot2::element_text(size = 18), + axis.text = ggplot2::element_text(size = 14), + strip.text = ggplot2::element_text(size = 14), + legend.title = ggplot2::element_text(size = 18), + legend.text = ggplot2::element_text(size = 14), + plot.title = ggplot2::element_text(size = 24), + plot.subtitle = ggplot2::element_text(size = 18) + ) } @@ -64,12 +91,12 @@ gg_theme_shiny <- function(){ #' @returns ggplot object #' @export #' -gg_theme_export <- function(){ - ggplot2::theme( - axis.title = ggplot2::element_text(size = 18), - axis.text.x = ggplot2::element_text(size = 14), - legend.title = ggplot2::element_text(size = 18), - legend.text = ggplot2::element_text(size = 14), - plot.title = ggplot2::element_text(size = 24) - ) +gg_theme_export <- function() { + ggplot2::theme( + axis.title = ggplot2::element_text(size = 18), + axis.text.x = ggplot2::element_text(size = 14), + legend.title = ggplot2::element_text(size = 18), + legend.text = ggplot2::element_text(size = 14), + plot.title = ggplot2::element_text(size = 24) + ) } diff --git a/README.md b/README.md index 87eb19c6..989d2ed4 100644 --- a/README.md +++ b/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/) 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 diff --git a/SESSION.md b/SESSION.md index 674d463a..8620ab6f 100644 --- a/SESSION.md +++ b/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) | -|clipr |0.8.0 |2022-02-22 |CRAN (R 4.4.1) | +|cli |3.6.5 |2025-04-23 |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) | diff --git a/examples/create_column_module_demo.R b/examples/create_column_module_demo.R new file mode 100644 index 00000000..6c96ec48 --- /dev/null +++ b/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) diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index b3606e63..b041778d 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: /Users/au301842/FreesearchR/R//app_version.R ######## -app_version <- function()'v25.4.3.250423' +app_version <- function()'v25.4.3.250424' ######## @@ -300,6 +300,455 @@ sentence_paste <- function(data, and.str = "and") { +######## +#### Current file: /Users/au301842/FreesearchR/R//create-column-mod.R +######## + +#' @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 + ) + } + ) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//custom_SelectInput.R ######## @@ -556,6 +1005,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(...) @@ -626,7 +1076,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)) @@ -837,10 +1290,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( @@ -848,6 +1302,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { "day", "weekday", "week", + # "week_only", "month", "month_only", "quarter", @@ -872,6 +1327,8 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) { ) } + choices <- unique(choices) + shinyWidgets::virtualSelectInput( inputId = session$ns("method"), label = i18n("Method:"), @@ -889,7 +1346,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)) @@ -932,6 +1389,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]]), @@ -945,6 +1407,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()) }) @@ -1082,8 +1545,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)) @@ -2360,9 +2828,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") @@ -2403,6 +2871,390 @@ 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() + } + ) +} + +} + + +######## +#### Current file: /Users/au301842/FreesearchR/R//datagrid-infos-mod.R +######## + + +#' 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)) + ), + "}" + ) + ) + } + ) + ) +} + ######## #### Current file: /Users/au301842/FreesearchR/R//helpers.R @@ -3064,6 +3916,21 @@ is_identical_to_previous <- function(data, no.name = TRUE) { } +######## +#### Current file: /Users/au301842/FreesearchR/R//html_dependency_freesearchr.R +######## + +html_dependency_FreesearchR <- function() { + htmltools::htmlDependency( + name = "FreesearchR", + version = packageVersion("FreesearchR"), + src = list(href = "FreesearchR", file = "assets"), + package = "FreesearchR", + stylesheet = "css/FreesearchR.css" + ) +} + + ######## #### Current file: /Users/au301842/FreesearchR/R//import-file-ext.R ######## @@ -6930,23 +7797,23 @@ html_code_wrap <- function(string,lang="r"){ #' @export custom_theme <- function(..., version = 5, - primary = "#1E4A8F", - secondary = "#FF6F61", + primary = FreesearchR_colors("primary"), + secondary = FreesearchR_colors("secondary"), bootswatch = "united", base_font = bslib::font_google("Montserrat"), - heading_font = bslib::font_google("Public Sans",wght = "700"), - code_font = bslib::font_google("Open Sans") - # success = "#1E4A8F", - # info = , - # warning = , - # danger = , + heading_font = bslib::font_google("Public Sans", wght = "700"), + code_font = bslib::font_google("Open Sans"), + success = FreesearchR_colors("success"), + info = FreesearchR_colors("info"), + warning = FreesearchR_colors("warning"), + 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, @@ -6956,10 +7823,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 #' @@ -6968,16 +7862,16 @@ custom_theme <- function(..., #' @returns ggplot object #' @export #' -gg_theme_shiny <- function(){ - ggplot2::theme( - axis.title = ggplot2::element_text(size = 18), - axis.text = ggplot2::element_text(size = 14), - strip.text = ggplot2::element_text(size = 14), - legend.title = ggplot2::element_text(size = 18), - legend.text = ggplot2::element_text(size = 14), - plot.title = ggplot2::element_text(size = 24), - plot.subtitle = ggplot2::element_text(size = 18) - ) +gg_theme_shiny <- function() { + ggplot2::theme( + axis.title = ggplot2::element_text(size = 18), + axis.text = ggplot2::element_text(size = 14), + strip.text = ggplot2::element_text(size = 14), + legend.title = ggplot2::element_text(size = 18), + legend.text = ggplot2::element_text(size = 14), + plot.title = ggplot2::element_text(size = 24), + plot.subtitle = ggplot2::element_text(size = 18) + ) } @@ -6988,14 +7882,14 @@ gg_theme_shiny <- function(){ #' @returns ggplot object #' @export #' -gg_theme_export <- function(){ - ggplot2::theme( - axis.title = ggplot2::element_text(size = 18), - axis.text.x = ggplot2::element_text(size = 14), - legend.title = ggplot2::element_text(size = 18), - legend.text = ggplot2::element_text(size = 14), - plot.title = ggplot2::element_text(size = 24) - ) +gg_theme_export <- function() { + ggplot2::theme( + axis.title = ggplot2::element_text(size = 18), + axis.text.x = ggplot2::element_text(size = 14), + legend.title = ggplot2::element_text(size = 18), + legend.text = ggplot2::element_text(size = 14), + plot.title = ggplot2::element_text(size = 24) + ) } @@ -8474,7 +9368,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( @@ -8487,6 +9382,7 @@ ui_elements <- list( ), shiny::tags$br(), shiny::helpText("Reorder the levels of factor/categorical variables."), + shiny::tags$br(), shiny::tags$br() ), shiny::column( @@ -8498,6 +9394,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( @@ -8509,10 +9406,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( @@ -8739,7 +9636,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) ) @@ -8784,15 +9681,9 @@ dark <- custom_theme( ui <- bslib::page_fixed( prismDependencies, prismRDependency, - shiny::tags$head(includeHTML(("www/umami-app.html"))), - shiny::tags$style( - type = "text/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}" - ) - ), + shiny::tags$head( + includeHTML(("www/umami-app.html")), + tags$link(rel = "stylesheet", type = "text/css", href = "style.css")), title = "FreesearchR", theme = light, shiny::useBusyIndicators(), @@ -8831,7 +9722,7 @@ library(readr) library(MASS) library(stats) library(gt) -library(openxlsx2) +# library(openxlsx2) library(haven) library(readODS) require(shiny) @@ -8844,16 +9735,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) @@ -8861,7 +9752,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) @@ -9018,8 +9910,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") ) |> @@ -9144,13 +10039,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) ) @@ -9273,7 +10168,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({ @@ -9304,7 +10199,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({ diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/FreesearchR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/FreesearchR.dcf new file mode 100644 index 00000000..7d73d94f --- /dev/null +++ b/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 diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index f5bbfb79..dd1b9615 100644 --- a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/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 diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index 8f977371..c16cba09 100644 --- a/inst/apps/FreesearchR/server.R +++ b/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({ diff --git a/inst/apps/FreesearchR/ui.R b/inst/apps/FreesearchR/ui.R index 8dac4454..4dc60a57 100644 --- a/inst/apps/FreesearchR/ui.R +++ b/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$style( - type = "text/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}" - ) - ), + shiny::tags$head( + includeHTML(("www/umami-app.html")), + tags$link(rel = "stylesheet", type = "text/css", href = "style.css")), title = "FreesearchR", theme = light, shiny::useBusyIndicators(), diff --git a/inst/apps/FreesearchR/www/references.bib b/inst/apps/FreesearchR/www/references.bib index ca20ec82..ab4b8b80 100644 --- a/inst/apps/FreesearchR/www/references.bib +++ b/inst/apps/FreesearchR/www/references.bib @@ -1,24 +1,11 @@ @book{andreasgammelgaarddamsbo2025, - title = {agdamsbo/freesearcheR: freesearcheR 25.3.1}, - author = {Andreas Gammelgaard Damsbo, }, + title = {agdamsbo/FreesearchR: FreesearchR 25.4.3}, + author = {Damsbo, Andreas Gammelgaard}, year = {2025}, - month = {03}, - date = {2025-03-06}, + month = {04}, + 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} -} diff --git a/inst/apps/FreesearchR/www/style.css b/inst/apps/FreesearchR/www/style.css new file mode 100644 index 00000000..f84cc325 --- /dev/null +++ b/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; +} diff --git a/inst/assets/css/FreesearchR.css b/inst/assets/css/FreesearchR.css new file mode 100644 index 00000000..f84cc325 --- /dev/null +++ b/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; +} diff --git a/man/create-column.Rd b/man/create-column.Rd new file mode 100644 index 00000000..452cb3d4 --- /dev/null +++ b/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{
}}\preformatted{c(list_allowed_operations(), getNamespaceExports("lubridate")) +}\if{html}{\out{
}} +} diff --git a/man/cut_var.Rd b/man/cut_var.Rd index e753ccd5..c3226a6a 100644 --- a/man/cut_var.Rd +++ b/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") } diff --git a/man/get_var_icon.Rd b/man/get_var_icon.Rd new file mode 100644 index 00000000..c299ccfd --- /dev/null +++ b/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() +} diff --git a/man/show_data.Rd b/man/show_data.Rd new file mode 100644 index 00000000..de11852b --- /dev/null +++ b/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. +} diff --git a/renv.lock b/renv.lock index 1a386741..5e58e951 100644 --- a/renv.lock +++ b/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\")) )", diff --git a/umami-page.html b/umami-page.html index 57eeb5a2..1270d512 100644 --- a/umami-page.html +++ b/umami-page.html @@ -1 +1 @@ - +