andreas/FreesearchR
1
0
Fork 0
mirror of https://github.com/agdamsbo/FreesearchR.git synced 2025-09-12 09:59:39 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

quick additional update

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-05-10 13:02:04 +02:00
parent d3819b786e
commit d76c75bd93
No known key found for this signature in database
17 changed files with 138 additions and 138 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CITATION.cff
View file

@ -9,7 +9,7 @@ type: software
license: AGPL-3.0-or-later license: AGPL-3.0-or-later
title: 'FreesearchR: A free and open-source browser based data analysis tool for researchers title: 'FreesearchR: A free and open-source browser based data analysis tool for researchers
with publication ready output' with publication ready output'
version: 25.5.3 version: 25.5.4
doi: 10.5281/zenodo.14527429 doi: 10.5281/zenodo.14527429
identifiers: identifiers:
- type: url - type: url

2
DESCRIPTION
View file

@ -1,6 +1,6 @@
Package: FreesearchR Package: FreesearchR
Title: A free and open-source browser based data analysis tool for researchers with publication ready output Title: A free and open-source browser based data analysis tool for researchers with publication ready output
Version: 25.5.3 Version: 25.5.4
Authors@R: c( Authors@R: c(
person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"), person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"),
comment = c(ORCID = "0000-0002-7559-1154")), comment = c(ORCID = "0000-0002-7559-1154")),

10
NEWS.md
View file

@ -1,3 +1,13 @@
# FreesearchR 25.5.4
- *FIX* correctly omit NAs in `data_type()` call
- *FIX* omit NAs when plotting Euler diagrams.
- *FIX* print correct labels in horizontal stacked bars.
- *FIX* initial app load should feel faster.
# FreesearchR 25.5.3 # FreesearchR 25.5.3
- *FIX* a little polish on the data import - *FIX* a little polish on the data import

2
R/app_version.R
View file

@ -1 +1 @@
app_version <- function()'25.5.3' app_version <- function()'25.5.4'

1
R/contrast_text.R
View file

@ -25,7 +25,6 @@
#' contrast_text(c("#F2F2F2", "blue"), method="relative") #' contrast_text(c("#F2F2F2", "blue"), method="relative")
#' @export #' @export
#' #'
#' @importFrom grDevices col2rgb
#' #'
contrast_text <- function(background, contrast_text <- function(background,
light_text = 'white', light_text = 'white',

14
R/create-column-mod.R
View file

@ -17,20 +17,17 @@
#' @export #' @export
#' #'
#' @importFrom htmltools tagList tags css #' @importFrom htmltools tagList tags css
#' @importFrom shiny NS textInput textAreaInput uiOutput actionButton
#' @importFrom phosphoricons ph
#' @importFrom shinyWidgets virtualSelectInput
#' #'
#' @name create-column #' @name create-column
#' #'
#' @example examples/create_column_module_demo.R #' @example examples/create_column_module_demo.R
create_column_ui <- function(id) { create_column_ui <- function(id) {
ns <- NS(id) ns <- NS(id)
tagList( htmltools::tagList(
# datamods:::html_dependency_datamods(), # datamods:::html_dependency_datamods(),
# html_dependency_FreesearchR(), # html_dependency_FreesearchR(),
tags$head( shiny::tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css") shiny::tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
), ),
# tags$head( # tags$head(
# # Note the wrapping of the string in HTML() # # Note the wrapping of the string in HTML()
@ -84,7 +81,7 @@ create_column_ui <- function(id) {
) )
) )
), ),
textAreaInput( shiny::textAreaInput(
inputId = ns("expression"), inputId = ns("expression"),
label = i18n("Enter an expression to define new column:"), label = i18n("Enter an expression to define new column:"),
value = "", value = "",
@ -132,9 +129,6 @@ create_column_ui <- function(id) {
#' #'
#' @rdname create-column #' @rdname create-column
#' #'
#' @importFrom shiny moduleServer reactiveValues observeEvent renderUI req
#' updateTextAreaInput reactive bindEvent observe
#' @importFrom shinyWidgets alert updateVirtualSelect
create_column_server <- function(id, create_column_server <- function(id,
data_r = reactive(NULL), data_r = reactive(NULL),
allowed_operations = list_allowed_operations()) { allowed_operations = list_allowed_operations()) {

36
R/cut-variable-dates.R
View file

@ -1,9 +1,3 @@
library(datamods)
library(toastui)
library(phosphoricons)
library(rlang)
library(shiny)
#' Extended cutting function with fall-back to the native base::cut #' Extended cutting function with fall-back to the native base::cut
#' #'
#' @param x an object inheriting from class "hms" #' @param x an object inheriting from class "hms"
@ -212,9 +206,9 @@ cut_variable_ui <- function(id) {
shiny::fluidRow( shiny::fluidRow(
column( column(
width = 3, width = 3,
virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("variable"), inputId = ns("variable"),
label = i18n("Variable to cut:"), label = datamods:::i18n("Variable to cut:"),
choices = NULL, choices = NULL,
width = "100%" width = "100%"
) )
@ -227,7 +221,7 @@ cut_variable_ui <- function(id) {
width = 3, width = 3,
numericInput( numericInput(
inputId = ns("n_breaks"), inputId = ns("n_breaks"),
label = i18n("Number of breaks:"), label = datamods:::i18n("Number of breaks:"),
value = 3, value = 3,
min = 2, min = 2,
max = 12, max = 12,
@ -238,12 +232,12 @@ cut_variable_ui <- function(id) {
width = 3, width = 3,
checkboxInput( checkboxInput(
inputId = ns("right"), inputId = ns("right"),
label = i18n("Close intervals on the right"), label = datamods:::i18n("Close intervals on the right"),
value = TRUE value = TRUE
), ),
checkboxInput( checkboxInput(
inputId = ns("include_lowest"), inputId = ns("include_lowest"),
label = i18n("Include lowest value"), label = datamods:::i18n("Include lowest value"),
value = TRUE value = TRUE
) )
) )
@ -254,10 +248,10 @@ cut_variable_ui <- function(id) {
uiOutput(outputId = ns("slider_fixed")) uiOutput(outputId = ns("slider_fixed"))
), ),
plotOutput(outputId = ns("plot"), width = "100%", height = "270px"), plotOutput(outputId = ns("plot"), width = "100%", height = "270px"),
datagridOutput2(outputId = ns("count")), toastui::datagridOutput2(outputId = ns("count")),
actionButton( actionButton(
inputId = ns("create"), inputId = ns("create"),
label = tagList(ph("scissors"), i18n("Create factor variable")), label = tagList(phosphoricons::ph("scissors"), datamods:::i18n("Create factor variable")),
class = "btn-outline-primary float-end" class = "btn-outline-primary float-end"
), ),
tags$div(class = "clearfix") tags$div(class = "clearfix")
@ -288,7 +282,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
is.numeric(.x) || is_datetime(.x) is.numeric(.x) || is_datetime(.x)
}, logical(1)) }, logical(1))
vars_num <- names(vars_num)[vars_num] vars_num <- names(vars_num)[vars_num]
updateVirtualSelect( shinyWidgets::updateVirtualSelect(
inputId = "variable", inputId = "variable",
choices = vars_num, choices = vars_num,
selected = if (isTruthy(input$variable)) input$variable else vars_num[1] selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
@ -325,9 +319,9 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
} }
noUiSliderInput( shinyWidgets::noUiSliderInput(
inputId = session$ns("fixed_brks"), inputId = session$ns("fixed_brks"),
label = i18n("Fixed breaks:"), label = datamods:::i18n("Fixed breaks:"),
min = lower, min = lower,
max = upper, max = upper,
value = brks, value = brks,
@ -382,7 +376,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
shinyWidgets::virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = session$ns("method"), inputId = session$ns("method"),
label = i18n("Method:"), label = datamods:::i18n("Method:"),
choices = choices, choices = choices,
selected = NULL, selected = NULL,
width = "100%" width = "100%"
@ -525,7 +519,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
data data
}) })
output$count <- renderDatagrid2({ output$count <- toastui::renderDatagrid2({
# shiny::req(rv$new_var_name) # shiny::req(rv$new_var_name)
data <- req(data_cutted_r()) data <- req(data_cutted_r())
# variable <- req(input$variable) # variable <- req(input$variable)
@ -541,14 +535,14 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
datamods:::apply_grid_theme() datamods:::apply_grid_theme()
} }
on.exit(toastui::reset_grid_theme()) on.exit(toastui::reset_grid_theme())
grid <- datagrid( grid <- toastui::datagrid(
data = count_data, data = count_data,
colwidths = "guess", colwidths = "guess",
theme = "default", theme = "default",
bodyHeight = "auto" bodyHeight = "auto"
) )
grid <- toastui::grid_columns(grid, className = "font-monospace") grid <- toastui::grid_columns(grid, className = "font-monospace")
grid_colorbar( toastui::grid_colorbar(
grid, grid,
column = "count", column = "count",
label_outside = TRUE, label_outside = TRUE,
@ -576,7 +570,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
#' #'
#' @rdname cut-variable #' @rdname cut-variable
modal_cut_variable <- function(id, modal_cut_variable <- function(id,
title = i18n("Convert Numeric to Factor"), title = datamods:::i18n("Convert Numeric to Factor"),
easyClose = TRUE, easyClose = TRUE,
size = "l", size = "l",
footer = NULL) { footer = NULL) {

1
R/data_plots.R
View file

@ -681,6 +681,7 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
#' mtcars |> get_label() #' mtcars |> get_label()
#' mtcars$mpg |> get_label() #' mtcars$mpg |> get_label()
#' gtsummary::trial |> get_label(var = "trt") #' gtsummary::trial |> get_label(var = "trt")
#' gtsummary::trial$trt |> get_label()
#' 1:10 |> get_label() #' 1:10 |> get_label()
get_label <- function(data, var = NULL) { get_label <- function(data, var = NULL) {
# data <- if (is.reactive(data)) data() else data # data <- if (is.reactive(data)) data() else data

2
R/hosted_version.R
View file

@ -1 +1 @@
hosted_version <- function()'v25.5.3-250510' hosted_version <- function()'v25.5.4-250510'

5
R/plot_hbar.R
View file

@ -62,9 +62,8 @@ vertical_stacked_bars <- function(data,
contrast_cut <- contrast_cut <-
sum(contrast_text(colors, threshold = .3) == "white") sum(contrast_text(colors, threshold = .3) == "white")
score_label <- ifelse(is.na(REDCapCAST::get_attr(data$score, "label")), score, REDCapCAST::get_attr(data$score, "label")) score_label <- data |> get_label(var = score)
group_label <- ifelse(is.na(REDCapCAST::get_attr(data$group, "label")), group, REDCapCAST::get_attr(data$group, "label")) group_label <- data |> get_label(var = group)
p |> p |>
(\(.x){ (\(.x){

5
R/plot_sankey.R
View file

@ -119,7 +119,6 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
#' plot_sankey_single("first", "last", color.group = "pri") #' plot_sankey_single("first", "last", color.group = "pri")
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' str()
#' plot_sankey_single("cyl", "vs", color.group = "pri") #' plot_sankey_single("cyl", "vs", color.group = "pri")
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
@ -132,8 +131,6 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
data <- data |> sankey_ready(pri = pri, sec = sec, ...) data <- data |> sankey_ready(pri = pri, sec = sec, ...)
library(ggalluvial)
na.color <- "#2986cc" na.color <- "#2986cc"
box.color <- "#1E4B66" box.color <- "#1E4B66"
@ -197,6 +194,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
) )
} }
## Will fail to use stat="stratum" if library is not loaded.
library(ggalluvial)
p + p +
ggplot2::geom_text( ggplot2::geom_text(
stat = "stratum", stat = "stratum",

9
R/regression_model.R
View file

@ -271,12 +271,13 @@ data_type <- function(data) {
sapply(data, data_type) sapply(data, data_type)
} else { } else {
cl_d <- class(data) cl_d <- class(data)
l_unique <- length(unique(na.omit(data)))
if (all(is.na(data))) { if (all(is.na(data))) {
out <- "empty" out <- "empty"
} else if (length(unique(data)) < 2) { } else if (l_unique < 2) {
out <- "monotone" out <- "monotone"
} else if (any(c("factor", "logical") %in% cl_d) | length(unique(data)) == 2) { } else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) {
if (identical("logical", cl_d) | length(unique(data)) == 2) { if (identical("logical", cl_d) | l_unique == 2) {
out <- "dichotomous" out <- "dichotomous"
} else { } else {
# if (is.ordered(data)) { # if (is.ordered(data)) {
@ -289,7 +290,7 @@ data_type <- function(data) {
out <- "text" out <- "text"
} else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) { } else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) {
out <- "datetime" out <- "datetime"
} else if (!length(unique(data)) == 2) { } else if (l_unique > 2) {
## Previously had all thinkable classes ## Previously had all thinkable classes
## Now just assumes the class has not been defined above ## Now just assumes the class has not been defined above
## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) &

BIN
R/sysdata.rda
View file

Binary file not shown.

6
R/update-factor-ext.R
View file

@ -31,7 +31,7 @@ update_factor_ui <- function(id) {
fluidRow( fluidRow(
column( column(
width = 6, width = 6,
virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("variable"), inputId = ns("variable"),
label = i18n("Factor variable to reorder:"), label = i18n("Factor variable to reorder:"),
choices = NULL, choices = NULL,
@ -66,10 +66,10 @@ update_factor_ui <- function(id) {
) )
) )
), ),
datagridOutput(ns("grid")), toastui::datagridOutput(ns("grid")),
tags$div( tags$div(
class = "float-end", class = "float-end",
prettyCheckbox( shinyWidgets::prettyCheckbox(
inputId = ns("new_var"), inputId = ns("new_var"),
label = i18n("Create a new variable (otherwise replaces the one selected)"), label = i18n("Create a new variable (otherwise replaces the one selected)"),
value = FALSE, value = FALSE,

4
R/update-variables-ext.R
View file

@ -1,7 +1,3 @@
library(data.table)
library(rlang)
#' Select, rename and convert variables #' Select, rename and convert variables
#' #'
#' @param id Module id. See [shiny::moduleServer()]. #' @param id Module id. See [shiny::moduleServer()].

20
SESSION.md
View file

@ -15,7 +15,7 @@
|rstudio |2024.12.1+563 Kousa Dogwood (desktop) | |rstudio |2024.12.1+563 Kousa Dogwood (desktop) |
|pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) | |pandoc |3.6.4 @ /opt/homebrew/bin/ (via rmarkdown) |
|quarto |1.7.30 @ /usr/local/bin/quarto | |quarto |1.7.30 @ /usr/local/bin/quarto |
|FreesearchR |25.5.3.250510 | |FreesearchR |25.5.4.250510 |
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -38,14 +38,12 @@
|cachem |1.1.0 |2024-05-16 |CRAN (R 4.4.1) | |cachem |1.1.0 |2024-05-16 |CRAN (R 4.4.1) |
|cellranger |1.1.0 |2016-07-27 |CRAN (R 4.4.0) | |cellranger |1.1.0 |2016-07-27 |CRAN (R 4.4.0) |
|cffr |1.2.0 |2025-01-25 |CRAN (R 4.4.1) | |cffr |1.2.0 |2025-01-25 |CRAN (R 4.4.1) |
|checkmate |2.3.2 |2024-07-29 |CRAN (R 4.4.0) |
|class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) | |class |7.3-23 |2025-01-01 |CRAN (R 4.4.1) |
|classInt |0.4-11 |2025-01-08 |CRAN (R 4.4.1) | |classInt |0.4-11 |2025-01-08 |CRAN (R 4.4.1) |
|cli |3.6.5 |2025-04-23 |CRAN (R 4.4.1) | |cli |3.6.5 |2025-04-23 |CRAN (R 4.4.1) |
|commonmark |1.9.5 |2025-03-17 |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) | |correlation |0.8.7 |2025-03-03 |CRAN (R 4.4.1) |
|crayon |1.5.3 |2024-06-20 |CRAN (R 4.4.1) | |crayon |1.5.3 |2024-06-20 |CRAN (R 4.4.1) |
|crosstalk |1.2.1 |2023-11-23 |CRAN (R 4.4.0) |
|curl |6.2.2 |2025-03-24 |CRAN (R 4.4.1) | |curl |6.2.2 |2025-03-24 |CRAN (R 4.4.1) |
|data.table |1.17.0 |2025-02-22 |CRAN (R 4.4.1) | |data.table |1.17.0 |2025-02-22 |CRAN (R 4.4.1) |
|datamods |1.5.3 |2024-10-02 |CRAN (R 4.4.1) | |datamods |1.5.3 |2024-10-02 |CRAN (R 4.4.1) |
@ -60,6 +58,7 @@
|easystats |0.7.4 |2025-02-06 |CRAN (R 4.4.1) | |easystats |0.7.4 |2025-02-06 |CRAN (R 4.4.1) |
|effectsize |1.0.0 |2024-12-10 |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) | |ellipsis |0.3.2 |2021-04-29 |CRAN (R 4.4.1) |
|eulerr |7.0.2 |2024-03-28 |CRAN (R 4.4.0) |
|evaluate |1.0.3 |2025-01-10 |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) | |farver |2.1.2 |2024-05-13 |CRAN (R 4.4.1) |
|fastmap |1.2.0 |2024-05-15 |CRAN (R 4.4.1) | |fastmap |1.2.0 |2024-05-15 |CRAN (R 4.4.1) |
@ -67,8 +66,11 @@
|forcats |1.0.0 |2023-01-29 |CRAN (R 4.4.0) | |forcats |1.0.0 |2023-01-29 |CRAN (R 4.4.0) |
|fs |1.6.6 |2025-04-12 |CRAN (R 4.4.1) | |fs |1.6.6 |2025-04-12 |CRAN (R 4.4.1) |
|generics |0.1.3 |2022-07-05 |CRAN (R 4.4.1) | |generics |0.1.3 |2022-07-05 |CRAN (R 4.4.1) |
|ggalluvial |0.12.5 |2023-02-22 |CRAN (R 4.4.0) |
|ggforce |0.4.2 |2024-02-19 |CRAN (R 4.4.0) |
|ggplot2 |3.5.2 |2025-04-09 |CRAN (R 4.4.1) | |ggplot2 |3.5.2 |2025-04-09 |CRAN (R 4.4.1) |
|glue |1.8.0 |2024-09-30 |CRAN (R 4.4.1) | |glue |1.8.0 |2024-09-30 |CRAN (R 4.4.1) |
|gridExtra |2.3 |2017-09-09 |CRAN (R 4.4.1) |
|gt |1.0.0 |2025-04-05 |CRAN (R 4.4.1) | |gt |1.0.0 |2025-04-05 |CRAN (R 4.4.1) |
|gtable |0.3.6 |2024-10-25 |CRAN (R 4.4.1) | |gtable |0.3.6 |2024-10-25 |CRAN (R 4.4.1) |
|gtsummary |2.2.0 |2025-04-14 |CRAN (R 4.4.1) | |gtsummary |2.2.0 |2025-04-14 |CRAN (R 4.4.1) |
@ -78,7 +80,6 @@
|htmltools |0.5.8.1 |2024-04-04 |CRAN (R 4.4.1) | |htmltools |0.5.8.1 |2024-04-04 |CRAN (R 4.4.1) |
|htmlwidgets |1.6.4 |2023-12-06 |CRAN (R 4.4.0) | |htmlwidgets |1.6.4 |2023-12-06 |CRAN (R 4.4.0) |
|httpuv |1.6.16 |2025-04-16 |CRAN (R 4.4.1) | |httpuv |1.6.16 |2025-04-16 |CRAN (R 4.4.1) |
|httr |1.4.7 |2023-08-15 |CRAN (R 4.4.0) |
|IDEAFilter |0.2.0 |2024-04-15 |CRAN (R 4.4.0) | |IDEAFilter |0.2.0 |2024-04-15 |CRAN (R 4.4.0) |
|insight |1.2.0 |2025-04-22 |CRAN (R 4.4.1) | |insight |1.2.0 |2025-04-22 |CRAN (R 4.4.1) |
|jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) | |jquerylib |0.1.4 |2021-04-26 |CRAN (R 4.4.0) |
@ -87,6 +88,7 @@
|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) | |KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) |
|keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) | |keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) |
|knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) | |knitr |1.50 |2025-03-16 |CRAN (R 4.4.1) |
|labeling |0.4.3 |2023-08-29 |CRAN (R 4.4.1) |
|later |1.4.2 |2025-04-08 |CRAN (R 4.4.1) | |later |1.4.2 |2025-04-08 |CRAN (R 4.4.1) |
|lattice |0.22-7 |2025-04-02 |CRAN (R 4.4.1) | |lattice |0.22-7 |2025-04-02 |CRAN (R 4.4.1) |
|lifecycle |1.0.4 |2023-11-07 |CRAN (R 4.4.1) | |lifecycle |1.0.4 |2023-11-07 |CRAN (R 4.4.1) |
@ -111,6 +113,8 @@
|pkgbuild |1.4.7 |2025-03-24 |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) | |pkgconfig |2.0.3 |2019-09-22 |CRAN (R 4.4.1) |
|pkgload |1.4.0 |2024-06-28 |CRAN (R 4.4.0) | |pkgload |1.4.0 |2024-06-28 |CRAN (R 4.4.0) |
|polyclip |1.10-7 |2024-07-23 |CRAN (R 4.4.1) |
|polylabelr |0.3.0 |2024-11-19 |CRAN (R 4.4.1) |
|processx |3.8.6 |2025-02-21 |CRAN (R 4.4.1) | |processx |3.8.6 |2025-02-21 |CRAN (R 4.4.1) |
|profvis |0.4.0 |2024-09-20 |CRAN (R 4.4.1) | |profvis |0.4.0 |2024-09-20 |CRAN (R 4.4.1) |
|promises |1.3.2 |2024-11-28 |CRAN (R 4.4.1) | |promises |1.3.2 |2024-11-28 |CRAN (R 4.4.1) |
@ -123,6 +127,8 @@
|R.oo |1.27.0 |2024-11-01 |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) | |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) | |R6 |2.6.1 |2025-02-15 |CRAN (R 4.4.1) |
|ragg |1.4.0 |2025-04-10 |CRAN (R 4.4.1) |
|rankinPlot |1.1.0 |2023-01-30 |CRAN (R 4.4.0) |
|rbibutils |2.3 |2024-10-04 |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) | |RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.4.1) |
|Rcpp |1.0.14 |2025-01-12 |CRAN (R 4.4.1) | |Rcpp |1.0.14 |2025-01-12 |CRAN (R 4.4.1) |
@ -156,15 +162,21 @@
|stringi |1.8.7 |2025-03-27 |CRAN (R 4.4.1) | |stringi |1.8.7 |2025-03-27 |CRAN (R 4.4.1) |
|stringr |1.5.1 |2023-11-14 |CRAN (R 4.4.0) | |stringr |1.5.1 |2023-11-14 |CRAN (R 4.4.0) |
|styler |1.10.3 |2024-04-07 |CRAN (R 4.4.0) | |styler |1.10.3 |2024-04-07 |CRAN (R 4.4.0) |
|systemfonts |1.2.2 |2025-04-04 |CRAN (R 4.4.1) |
|textshaping |1.0.0 |2025-01-20 |CRAN (R 4.4.1) |
|tibble |3.2.1 |2023-03-20 |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) | |tidyr |1.3.1 |2024-01-24 |CRAN (R 4.4.1) |
|tidyselect |1.2.1 |2024-03-11 |CRAN (R 4.4.0) | |tidyselect |1.2.1 |2024-03-11 |CRAN (R 4.4.0) |
|toastui |0.4.0 |2025-04-03 |CRAN (R 4.4.1) | |toastui |0.4.0 |2025-04-03 |CRAN (R 4.4.1) |
|tweenr |2.0.3 |2024-02-26 |CRAN (R 4.4.0) |
|tzdb |0.5.0 |2025-03-15 |CRAN (R 4.4.1) | |tzdb |0.5.0 |2025-03-15 |CRAN (R 4.4.1) |
|urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) | |urlchecker |1.0.1 |2021-11-30 |CRAN (R 4.4.1) |
|usethis |3.1.0 |2024-11-26 |CRAN (R 4.4.1) | |usethis |3.1.0 |2024-11-26 |CRAN (R 4.4.1) |
|utf8 |1.2.4 |2023-10-22 |CRAN (R 4.4.1) |
|V8 |6.0.3 |2025-03-26 |CRAN (R 4.4.1) | |V8 |6.0.3 |2025-03-26 |CRAN (R 4.4.1) |
|vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) | |vctrs |0.6.5 |2023-12-01 |CRAN (R 4.4.0) |
|viridis |0.6.5 |2024-01-29 |CRAN (R 4.4.0) |
|viridisLite |0.4.2 |2023-05-02 |CRAN (R 4.4.1) |
|vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) | |vroom |1.6.5 |2023-12-05 |CRAN (R 4.4.0) |
|withr |3.0.2 |2024-10-28 |CRAN (R 4.4.1) | |withr |3.0.2 |2024-10-28 |CRAN (R 4.4.1) |
|writexl |1.5.4 |2025-04-15 |CRAN (R 4.4.1) | |writexl |1.5.4 |2025-04-15 |CRAN (R 4.4.1) |

155
inst/apps/FreesearchR/app.R
View file

@ -1,5 +1,44 @@
########
#### Current file: /Users/au301842/FreesearchR/app/libs.R
########
library(shiny)
# library(shinyjs)
# library(methods)
# library(readr)
# library(MASS)
# library(stats)
# library(gt)
# library(openxlsx2)
# library(haven)
# library(readODS)
# library(bslib)
# library(assertthat)
# library(dplyr)
# library(quarto)
# library(here)
# library(broom)
# library(broom.helpers)
# library(easystats)
# library(patchwork)
# library(DHARMa)
# library(apexcharter)
library(toastui)
# library(datamods)
# library(IDEAFilter)
library(shinyWidgets)
# library(DT)
# library(data.table)
# library(gtsummary)
library(bsicons)
library(rlang)
# library(datamods)
# library(toastui)
# library(phosphoricons)
######## ########
#### Current file: /Users/au301842/FreesearchR/app/functions.R #### Current file: /Users/au301842/FreesearchR/app/functions.R
######## ########
@ -10,7 +49,7 @@
#### Current file: /Users/au301842/FreesearchR/R//app_version.R #### Current file: /Users/au301842/FreesearchR/R//app_version.R
######## ########
app_version <- function()'25.5.2' app_version <- function()'25.5.3'
######## ########
@ -129,7 +168,6 @@ create_baseline <- function(data, ..., by.var, add.p = FALSE, add.overall = FALS
#' contrast_text(c("#F2F2F2", "blue"), method="relative") #' contrast_text(c("#F2F2F2", "blue"), method="relative")
#' @export #' @export
#' #'
#' @importFrom grDevices col2rgb
#' #'
contrast_text <- function(background, contrast_text <- function(background,
light_text = 'white', light_text = 'white',
@ -323,20 +361,17 @@ sentence_paste <- function(data, and.str = "and") {
#' @export #' @export
#' #'
#' @importFrom htmltools tagList tags css #' @importFrom htmltools tagList tags css
#' @importFrom shiny NS textInput textAreaInput uiOutput actionButton
#' @importFrom phosphoricons ph
#' @importFrom shinyWidgets virtualSelectInput
#' #'
#' @name create-column #' @name create-column
#' #'
#' @example examples/create_column_module_demo.R #' @example examples/create_column_module_demo.R
create_column_ui <- function(id) { create_column_ui <- function(id) {
ns <- NS(id) ns <- NS(id)
tagList( htmltools::tagList(
# datamods:::html_dependency_datamods(), # datamods:::html_dependency_datamods(),
# html_dependency_FreesearchR(), # html_dependency_FreesearchR(),
tags$head( shiny::tags$head(
tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css") shiny::tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
), ),
# tags$head( # tags$head(
# # Note the wrapping of the string in HTML() # # Note the wrapping of the string in HTML()
@ -390,7 +425,7 @@ create_column_ui <- function(id) {
) )
) )
), ),
textAreaInput( shiny::textAreaInput(
inputId = ns("expression"), inputId = ns("expression"),
label = i18n("Enter an expression to define new column:"), label = i18n("Enter an expression to define new column:"),
value = "", value = "",
@ -438,9 +473,6 @@ create_column_ui <- function(id) {
#' #'
#' @rdname create-column #' @rdname create-column
#' #'
#' @importFrom shiny moduleServer reactiveValues observeEvent renderUI req
#' updateTextAreaInput reactive bindEvent observe
#' @importFrom shinyWidgets alert updateVirtualSelect
create_column_server <- function(id, create_column_server <- function(id,
data_r = reactive(NULL), data_r = reactive(NULL),
allowed_operations = list_allowed_operations()) { allowed_operations = list_allowed_operations()) {
@ -947,12 +979,6 @@ vectorSelectInput <- function(inputId,
#### Current file: /Users/au301842/FreesearchR/R//cut-variable-dates.R #### Current file: /Users/au301842/FreesearchR/R//cut-variable-dates.R
######## ########
library(datamods)
library(toastui)
library(phosphoricons)
library(rlang)
library(shiny)
#' Extended cutting function with fall-back to the native base::cut #' Extended cutting function with fall-back to the native base::cut
#' #'
#' @param x an object inheriting from class "hms" #' @param x an object inheriting from class "hms"
@ -1161,9 +1187,9 @@ cut_variable_ui <- function(id) {
shiny::fluidRow( shiny::fluidRow(
column( column(
width = 3, width = 3,
virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("variable"), inputId = ns("variable"),
label = i18n("Variable to cut:"), label = datamods:::i18n("Variable to cut:"),
choices = NULL, choices = NULL,
width = "100%" width = "100%"
) )
@ -1176,7 +1202,7 @@ cut_variable_ui <- function(id) {
width = 3, width = 3,
numericInput( numericInput(
inputId = ns("n_breaks"), inputId = ns("n_breaks"),
label = i18n("Number of breaks:"), label = datamods:::i18n("Number of breaks:"),
value = 3, value = 3,
min = 2, min = 2,
max = 12, max = 12,
@ -1187,12 +1213,12 @@ cut_variable_ui <- function(id) {
width = 3, width = 3,
checkboxInput( checkboxInput(
inputId = ns("right"), inputId = ns("right"),
label = i18n("Close intervals on the right"), label = datamods:::i18n("Close intervals on the right"),
value = TRUE value = TRUE
), ),
checkboxInput( checkboxInput(
inputId = ns("include_lowest"), inputId = ns("include_lowest"),
label = i18n("Include lowest value"), label = datamods:::i18n("Include lowest value"),
value = TRUE value = TRUE
) )
) )
@ -1203,10 +1229,10 @@ cut_variable_ui <- function(id) {
uiOutput(outputId = ns("slider_fixed")) uiOutput(outputId = ns("slider_fixed"))
), ),
plotOutput(outputId = ns("plot"), width = "100%", height = "270px"), plotOutput(outputId = ns("plot"), width = "100%", height = "270px"),
datagridOutput2(outputId = ns("count")), toastui::datagridOutput2(outputId = ns("count")),
actionButton( actionButton(
inputId = ns("create"), inputId = ns("create"),
label = tagList(ph("scissors"), i18n("Create factor variable")), label = tagList(phosphoricons::ph("scissors"), datamods:::i18n("Create factor variable")),
class = "btn-outline-primary float-end" class = "btn-outline-primary float-end"
), ),
tags$div(class = "clearfix") tags$div(class = "clearfix")
@ -1237,7 +1263,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
is.numeric(.x) || is_datetime(.x) is.numeric(.x) || is_datetime(.x)
}, logical(1)) }, logical(1))
vars_num <- names(vars_num)[vars_num] vars_num <- names(vars_num)[vars_num]
updateVirtualSelect( shinyWidgets::updateVirtualSelect(
inputId = "variable", inputId = "variable",
choices = vars_num, choices = vars_num,
selected = if (isTruthy(input$variable)) input$variable else vars_num[1] selected = if (isTruthy(input$variable)) input$variable else vars_num[1]
@ -1274,9 +1300,9 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
} }
noUiSliderInput( shinyWidgets::noUiSliderInput(
inputId = session$ns("fixed_brks"), inputId = session$ns("fixed_brks"),
label = i18n("Fixed breaks:"), label = datamods:::i18n("Fixed breaks:"),
min = lower, min = lower,
max = upper, max = upper,
value = brks, value = brks,
@ -1331,7 +1357,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
shinyWidgets::virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = session$ns("method"), inputId = session$ns("method"),
label = i18n("Method:"), label = datamods:::i18n("Method:"),
choices = choices, choices = choices,
selected = NULL, selected = NULL,
width = "100%" width = "100%"
@ -1474,7 +1500,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
data data
}) })
output$count <- renderDatagrid2({ output$count <- toastui::renderDatagrid2({
# shiny::req(rv$new_var_name) # shiny::req(rv$new_var_name)
data <- req(data_cutted_r()) data <- req(data_cutted_r())
# variable <- req(input$variable) # variable <- req(input$variable)
@ -1490,14 +1516,14 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
datamods:::apply_grid_theme() datamods:::apply_grid_theme()
} }
on.exit(toastui::reset_grid_theme()) on.exit(toastui::reset_grid_theme())
grid <- datagrid( grid <- toastui::datagrid(
data = count_data, data = count_data,
colwidths = "guess", colwidths = "guess",
theme = "default", theme = "default",
bodyHeight = "auto" bodyHeight = "auto"
) )
grid <- toastui::grid_columns(grid, className = "font-monospace") grid <- toastui::grid_columns(grid, className = "font-monospace")
grid_colorbar( toastui::grid_colorbar(
grid, grid,
column = "count", column = "count",
label_outside = TRUE, label_outside = TRUE,
@ -1525,7 +1551,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
#' #'
#' @rdname cut-variable #' @rdname cut-variable
modal_cut_variable <- function(id, modal_cut_variable <- function(id,
title = i18n("Convert Numeric to Factor"), title = datamods:::i18n("Convert Numeric to Factor"),
easyClose = TRUE, easyClose = TRUE,
size = "l", size = "l",
footer = NULL) { footer = NULL) {
@ -2255,6 +2281,7 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
#' mtcars |> get_label() #' mtcars |> get_label()
#' mtcars$mpg |> get_label() #' mtcars$mpg |> get_label()
#' gtsummary::trial |> get_label(var = "trt") #' gtsummary::trial |> get_label(var = "trt")
#' gtsummary::trial$trt |> get_label()
#' 1:10 |> get_label() #' 1:10 |> get_label()
get_label <- function(data, var = NULL) { get_label <- function(data, var = NULL) {
# data <- if (is.reactive(data)) data() else data # data <- if (is.reactive(data)) data() else data
@ -3969,7 +3996,7 @@ simple_snake <- function(data){
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
######## ########
hosted_version <- function()'v25.5.2-250510' hosted_version <- function()'v25.5.3-250510'
######## ########
@ -4807,6 +4834,7 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
out <- lapply(ds, \(.x){ out <- lapply(ds, \(.x){
.x[c(pri, sec)] |> .x[c(pri, sec)] |>
as.data.frame() |> as.data.frame() |>
na.omit() |>
plot_euler_single() plot_euler_single()
}) })
@ -4922,9 +4950,8 @@ vertical_stacked_bars <- function(data,
contrast_cut <- contrast_cut <-
sum(contrast_text(colors, threshold = .3) == "white") sum(contrast_text(colors, threshold = .3) == "white")
score_label <- ifelse(is.na(REDCapCAST::get_attr(data$score, "label")), score, REDCapCAST::get_attr(data$score, "label")) score_label <- data |> get_label(var = score)
group_label <- ifelse(is.na(REDCapCAST::get_attr(data$group, "label")), group, REDCapCAST::get_attr(data$group, "label")) group_label <- data |> get_label(var = group)
p |> p |>
(\(.x){ (\(.x){
@ -5114,7 +5141,6 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
#' plot_sankey_single("first", "last", color.group = "pri") #' plot_sankey_single("first", "last", color.group = "pri")
#' mtcars |> #' mtcars |>
#' default_parsing() |> #' default_parsing() |>
#' str()
#' plot_sankey_single("cyl", "vs", color.group = "pri") #' plot_sankey_single("cyl", "vs", color.group = "pri")
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) { plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
color.group <- match.arg(color.group) color.group <- match.arg(color.group)
@ -5127,8 +5153,6 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
data <- data |> sankey_ready(pri = pri, sec = sec, ...) data <- data |> sankey_ready(pri = pri, sec = sec, ...)
library(ggalluvial)
na.color <- "#2986cc" na.color <- "#2986cc"
box.color <- "#1E4B66" box.color <- "#1E4B66"
@ -5192,6 +5216,8 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
) )
} }
## Will fail to use stat="stratum" if library is not loaded.
library(ggalluvial)
p + p +
ggplot2::geom_text( ggplot2::geom_text(
stat = "stratum", stat = "stratum",
@ -6346,12 +6372,13 @@ data_type <- function(data) {
sapply(data, data_type) sapply(data, data_type)
} else { } else {
cl_d <- class(data) cl_d <- class(data)
l_unique <- length(unique(na.omit(data)))
if (all(is.na(data))) { if (all(is.na(data))) {
out <- "empty" out <- "empty"
} else if (length(unique(data)) < 2) { } else if (l_unique < 2) {
out <- "monotone" out <- "monotone"
} else if (any(c("factor", "logical") %in% cl_d) | length(unique(data)) == 2) { } else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) {
if (identical("logical", cl_d) | length(unique(data)) == 2) { if (identical("logical", cl_d) | l_unique == 2) {
out <- "dichotomous" out <- "dichotomous"
} else { } else {
# if (is.ordered(data)) { # if (is.ordered(data)) {
@ -6364,7 +6391,7 @@ data_type <- function(data) {
out <- "text" out <- "text"
} else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) { } else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) {
out <- "datetime" out <- "datetime"
} else if (!length(unique(data)) == 2) { } else if (l_unique > 2) {
## Previously had all thinkable classes ## Previously had all thinkable classes
## Now just assumes the class has not been defined above ## Now just assumes the class has not been defined above
## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) & ## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) &
@ -8039,7 +8066,7 @@ update_factor_ui <- function(id) {
fluidRow( fluidRow(
column( column(
width = 6, width = 6,
virtualSelectInput( shinyWidgets::virtualSelectInput(
inputId = ns("variable"), inputId = ns("variable"),
label = i18n("Factor variable to reorder:"), label = i18n("Factor variable to reorder:"),
choices = NULL, choices = NULL,
@ -8074,10 +8101,10 @@ update_factor_ui <- function(id) {
) )
) )
), ),
datagridOutput(ns("grid")), toastui::datagridOutput(ns("grid")),
tags$div( tags$div(
class = "float-end", class = "float-end",
prettyCheckbox( shinyWidgets::prettyCheckbox(
inputId = ns("new_var"), inputId = ns("new_var"),
label = i18n("Create a new variable (otherwise replaces the one selected)"), label = i18n("Create a new variable (otherwise replaces the one selected)"),
value = FALSE, value = FALSE,
@ -8303,10 +8330,6 @@ winbox_update_factor <- function(id,
#### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R #### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R
######## ########
library(data.table)
library(rlang)
#' Select, rename and convert variables #' Select, rename and convert variables
#' #'
#' @param id Module id. See [shiny::moduleServer()]. #' @param id Module id. See [shiny::moduleServer()].
@ -9870,35 +9893,7 @@ ui <- bslib::page_fixed(
#### Current file: /Users/au301842/FreesearchR/app/server.R #### Current file: /Users/au301842/FreesearchR/app/server.R
######## ########
library(shiny)
# library(shinyjs)
# library(methods)
library(readr)
library(MASS)
library(stats)
library(gt)
# library(openxlsx2)
library(haven)
library(readODS)
library(bslib)
library(assertthat)
library(dplyr)
library(quarto)
library(here)
library(broom)
library(broom.helpers)
library(easystats)
library(patchwork)
library(DHARMa)
library(apexcharter)
library(toastui)
library(datamods)
library(IDEAFilter)
library(shinyWidgets)
library(DT)
library(data.table)
library(gtsummary)
library(bsicons)
data(starwars) data(starwars)
data(mtcars) data(mtcars)