mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 09:59:39 +02:00
Compare commits
7 commits
1613386096
...
2a39655e96
| Author | SHA1 | Date | |
|---|---|---|---|
| 2a39655e96 | |||
| d76c75bd93 | |||
| d3819b786e | |||
| 0c80bd2616 | |||
| a655dd3b87 | |||
| 91a3f19952 | |||
| 1b45c3fabf |
29 changed files with 323 additions and 208 deletions
|
|
@ -9,7 +9,7 @@ type: software
|
|||
license: AGPL-3.0-or-later
|
||||
title: 'FreesearchR: A free and open-source browser based data analysis tool for researchers
|
||||
with publication ready output'
|
||||
version: 25.5.2
|
||||
version: 25.5.4
|
||||
doi: 10.5281/zenodo.14527429
|
||||
identifiers:
|
||||
- type: url
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
Package: FreesearchR
|
||||
Title: A free and open-source browser based data analysis tool for researchers with publication ready output
|
||||
Version: 25.5.2
|
||||
Version: 25.5.4
|
||||
Authors@R: c(
|
||||
person("Andreas Gammelgaard", "Damsbo",email="agdamsbo@clin.au.dk", role = c("aut", "cre"),
|
||||
comment = c(ORCID = "0000-0002-7559-1154")),
|
||||
|
|
|
|||
|
|
@ -108,6 +108,7 @@ export(sankey_ready)
|
|||
export(selectInputIcon)
|
||||
export(set_column_label)
|
||||
export(show_data)
|
||||
export(simple_snake)
|
||||
export(sort_by)
|
||||
export(specify_qmd_format)
|
||||
export(subset_types)
|
||||
|
|
@ -130,7 +131,6 @@ export(write_quarto)
|
|||
importFrom(classInt,classIntervals)
|
||||
importFrom(data.table,as.data.table)
|
||||
importFrom(data.table,data.table)
|
||||
importFrom(grDevices,col2rgb)
|
||||
importFrom(graphics,abline)
|
||||
importFrom(graphics,axis)
|
||||
importFrom(graphics,hist)
|
||||
|
|
@ -141,7 +141,6 @@ importFrom(htmltools,css)
|
|||
importFrom(htmltools,tagList)
|
||||
importFrom(htmltools,tags)
|
||||
importFrom(htmltools,validateCssUnit)
|
||||
importFrom(phosphoricons,ph)
|
||||
importFrom(rlang,"%||%")
|
||||
importFrom(rlang,call2)
|
||||
importFrom(rlang,expr)
|
||||
|
|
@ -160,25 +159,20 @@ 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)
|
||||
|
|
|
|||
18
NEWS.md
18
NEWS.md
|
|
@ -1,3 +1,21 @@
|
|||
# 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
|
||||
|
||||
- *FIX* a little polish on the data import
|
||||
|
||||
- *FIX* polished REDCap import and new code to reference the `REDCapCAST::easy_redcap()` function.
|
||||
|
||||
- *FIX* updated documentation to reflect new private hosting on a Hetzner server in Germany.
|
||||
|
||||
# FreesearchR 25.5.2
|
||||
|
||||
- *FIX*: correct export of plots. The solution in the last version broke more than it solved.
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'25.5.2'
|
||||
app_version <- function()'25.5.4'
|
||||
|
|
|
|||
|
|
@ -25,7 +25,6 @@
|
|||
#' contrast_text(c("#F2F2F2", "blue"), method="relative")
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom grDevices col2rgb
|
||||
#'
|
||||
contrast_text <- function(background,
|
||||
light_text = 'white',
|
||||
|
|
|
|||
|
|
@ -17,20 +17,17 @@
|
|||
#' @export
|
||||
#'
|
||||
#' @importFrom htmltools tagList tags css
|
||||
#' @importFrom shiny NS textInput textAreaInput uiOutput actionButton
|
||||
#' @importFrom phosphoricons ph
|
||||
#' @importFrom shinyWidgets virtualSelectInput
|
||||
#'
|
||||
#' @name create-column
|
||||
#'
|
||||
#' @example examples/create_column_module_demo.R
|
||||
create_column_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
htmltools::tagList(
|
||||
# datamods:::html_dependency_datamods(),
|
||||
# html_dependency_FreesearchR(),
|
||||
tags$head(
|
||||
tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
|
||||
shiny::tags$head(
|
||||
shiny::tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
|
||||
),
|
||||
# tags$head(
|
||||
# # Note the wrapping of the string in HTML()
|
||||
|
|
@ -84,7 +81,7 @@ create_column_ui <- function(id) {
|
|||
)
|
||||
)
|
||||
),
|
||||
textAreaInput(
|
||||
shiny::textAreaInput(
|
||||
inputId = ns("expression"),
|
||||
label = i18n("Enter an expression to define new column:"),
|
||||
value = "",
|
||||
|
|
@ -132,9 +129,6 @@ create_column_ui <- function(id) {
|
|||
#'
|
||||
#' @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()) {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
#'
|
||||
#' @param x an object inheriting from class "hms"
|
||||
|
|
@ -212,9 +206,9 @@ cut_variable_ui <- function(id) {
|
|||
shiny::fluidRow(
|
||||
column(
|
||||
width = 3,
|
||||
virtualSelectInput(
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Variable to cut:"),
|
||||
label = datamods:::i18n("Variable to cut:"),
|
||||
choices = NULL,
|
||||
width = "100%"
|
||||
)
|
||||
|
|
@ -227,7 +221,7 @@ cut_variable_ui <- function(id) {
|
|||
width = 3,
|
||||
numericInput(
|
||||
inputId = ns("n_breaks"),
|
||||
label = i18n("Number of breaks:"),
|
||||
label = datamods:::i18n("Number of breaks:"),
|
||||
value = 3,
|
||||
min = 2,
|
||||
max = 12,
|
||||
|
|
@ -238,12 +232,12 @@ cut_variable_ui <- function(id) {
|
|||
width = 3,
|
||||
checkboxInput(
|
||||
inputId = ns("right"),
|
||||
label = i18n("Close intervals on the right"),
|
||||
label = datamods:::i18n("Close intervals on the right"),
|
||||
value = TRUE
|
||||
),
|
||||
checkboxInput(
|
||||
inputId = ns("include_lowest"),
|
||||
label = i18n("Include lowest value"),
|
||||
label = datamods:::i18n("Include lowest value"),
|
||||
value = TRUE
|
||||
)
|
||||
)
|
||||
|
|
@ -254,10 +248,10 @@ cut_variable_ui <- function(id) {
|
|||
uiOutput(outputId = ns("slider_fixed"))
|
||||
),
|
||||
plotOutput(outputId = ns("plot"), width = "100%", height = "270px"),
|
||||
datagridOutput2(outputId = ns("count")),
|
||||
toastui::datagridOutput2(outputId = ns("count")),
|
||||
actionButton(
|
||||
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"
|
||||
),
|
||||
tags$div(class = "clearfix")
|
||||
|
|
@ -288,7 +282,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
is.numeric(.x) || is_datetime(.x)
|
||||
}, logical(1))
|
||||
vars_num <- names(vars_num)[vars_num]
|
||||
updateVirtualSelect(
|
||||
shinyWidgets::updateVirtualSelect(
|
||||
inputId = "variable",
|
||||
choices = vars_num,
|
||||
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"),
|
||||
label = i18n("Fixed breaks:"),
|
||||
label = datamods:::i18n("Fixed breaks:"),
|
||||
min = lower,
|
||||
max = upper,
|
||||
value = brks,
|
||||
|
|
@ -382,7 +376,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = session$ns("method"),
|
||||
label = i18n("Method:"),
|
||||
label = datamods:::i18n("Method:"),
|
||||
choices = choices,
|
||||
selected = NULL,
|
||||
width = "100%"
|
||||
|
|
@ -525,7 +519,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
data
|
||||
})
|
||||
|
||||
output$count <- renderDatagrid2({
|
||||
output$count <- toastui::renderDatagrid2({
|
||||
# shiny::req(rv$new_var_name)
|
||||
data <- req(data_cutted_r())
|
||||
# variable <- req(input$variable)
|
||||
|
|
@ -541,14 +535,14 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
datamods:::apply_grid_theme()
|
||||
}
|
||||
on.exit(toastui::reset_grid_theme())
|
||||
grid <- datagrid(
|
||||
grid <- toastui::datagrid(
|
||||
data = count_data,
|
||||
colwidths = "guess",
|
||||
theme = "default",
|
||||
bodyHeight = "auto"
|
||||
)
|
||||
grid <- toastui::grid_columns(grid, className = "font-monospace")
|
||||
grid_colorbar(
|
||||
toastui::grid_colorbar(
|
||||
grid,
|
||||
column = "count",
|
||||
label_outside = TRUE,
|
||||
|
|
@ -576,7 +570,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
#'
|
||||
#' @rdname cut-variable
|
||||
modal_cut_variable <- function(id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
title = datamods:::i18n("Convert Numeric to Factor"),
|
||||
easyClose = TRUE,
|
||||
size = "l",
|
||||
footer = NULL) {
|
||||
|
|
|
|||
|
|
@ -681,6 +681,7 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
|
|||
#' mtcars |> get_label()
|
||||
#' mtcars$mpg |> get_label()
|
||||
#' gtsummary::trial |> get_label(var = "trt")
|
||||
#' gtsummary::trial$trt |> get_label()
|
||||
#' 1:10 |> get_label()
|
||||
get_label <- function(data, var = NULL) {
|
||||
# data <- if (is.reactive(data)) data() else data
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ show_data <- function(data,
|
|||
if (is.null(options))
|
||||
options <- list()
|
||||
|
||||
options$height <- 550
|
||||
options$height <- 500
|
||||
options$minBodyHeight <- 400
|
||||
options$data <- data
|
||||
options$theme <- "default"
|
||||
|
|
|
|||
14
R/helpers.R
14
R/helpers.R
|
|
@ -652,3 +652,17 @@ is_identical_to_previous <- function(data, no.name = TRUE) {
|
|||
}
|
||||
}, FUN.VALUE = logical(1))
|
||||
}
|
||||
|
||||
|
||||
#' Simplified version of the snakecase packages to_snake_case
|
||||
#'
|
||||
#' @param data character string vector
|
||||
#'
|
||||
#' @returns vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake()
|
||||
simple_snake <- function(data){
|
||||
gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
hosted_version <- function()'v25.5.2-250508'
|
||||
hosted_version <- function()'v25.5.4-250510'
|
||||
|
|
|
|||
|
|
@ -87,10 +87,11 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
|||
out <- lapply(ds, \(.x){
|
||||
.x[c(pri, sec)] |>
|
||||
as.data.frame() |>
|
||||
na.omit() |>
|
||||
plot_euler_single()
|
||||
})
|
||||
|
||||
# names(out)
|
||||
# names(out)
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -62,9 +62,8 @@ vertical_stacked_bars <- function(data,
|
|||
contrast_cut <-
|
||||
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"))
|
||||
group_label <- ifelse(is.na(REDCapCAST::get_attr(data$group, "label")), group, REDCapCAST::get_attr(data$group, "label"))
|
||||
|
||||
score_label <- data |> get_label(var = score)
|
||||
group_label <- data |> get_label(var = group)
|
||||
|
||||
p |>
|
||||
(\(.x){
|
||||
|
|
|
|||
|
|
@ -119,7 +119,6 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
|
|||
#' plot_sankey_single("first", "last", color.group = "pri")
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' str()
|
||||
#' plot_sankey_single("cyl", "vs", color.group = "pri")
|
||||
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
|
||||
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, ...)
|
||||
|
||||
library(ggalluvial)
|
||||
|
||||
na.color <- "#2986cc"
|
||||
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 +
|
||||
ggplot2::geom_text(
|
||||
stat = "stratum",
|
||||
|
|
|
|||
|
|
@ -200,9 +200,12 @@ m_redcap_readServer <- function(id) {
|
|||
)
|
||||
|
||||
# browser()
|
||||
shiny::withProgress({
|
||||
shiny::withProgress(
|
||||
{
|
||||
imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE)
|
||||
},message = paste("Connecting to",data_rv$uri))
|
||||
},
|
||||
message = paste("Connecting to", data_rv$uri)
|
||||
)
|
||||
|
||||
## TODO: Simplify error messages
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) {
|
||||
|
|
@ -228,7 +231,7 @@ m_redcap_readServer <- function(id) {
|
|||
status = "success",
|
||||
include_data_alert(
|
||||
see_data_text = "Click to see data dictionary",
|
||||
dataIdName = "see_data",
|
||||
dataIdName = "see_dd",
|
||||
extra = tags$p(
|
||||
tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"),
|
||||
glue::glue("The {data_rv$info$project_title} project is loaded.")
|
||||
|
|
@ -254,8 +257,8 @@ m_redcap_readServer <- function(id) {
|
|||
output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success"))
|
||||
shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE)
|
||||
|
||||
shiny::observeEvent(input$see_data, {
|
||||
datamods::show_data(
|
||||
shiny::observeEvent(input$see_dd, {
|
||||
show_data(
|
||||
purrr::pluck(data_rv$dd_list, "data"),
|
||||
title = "Data dictionary",
|
||||
type = "modal",
|
||||
|
|
@ -264,6 +267,17 @@ m_redcap_readServer <- function(id) {
|
|||
)
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$see_data, {
|
||||
show_data(
|
||||
# purrr::pluck(data_rv$dd_list, "data"),
|
||||
data_rv$data,
|
||||
title = "Imported data set",
|
||||
type = "modal",
|
||||
show_classes = FALSE,
|
||||
tags$b("Preview:")
|
||||
)
|
||||
})
|
||||
|
||||
arms <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(data_rv$uri)
|
||||
|
|
@ -378,13 +392,24 @@ m_redcap_readServer <- function(id) {
|
|||
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE)
|
||||
})
|
||||
|
||||
code <- rlang::call2("read_redcap_tables",
|
||||
!!!utils::modifyList(parameters, list(token = "PERSONAL_API_TOKEN")), ,
|
||||
parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")]
|
||||
|
||||
code <- rlang::call2(
|
||||
"easy_redcap",
|
||||
!!!utils::modifyList(
|
||||
parameters_code,
|
||||
list(
|
||||
data_format = ifelse(
|
||||
input$data_type == "long" && !is.null(input$data_type),
|
||||
"long",
|
||||
"wide"
|
||||
),
|
||||
project.name = simple_snake(data_rv$info$project_title)
|
||||
)
|
||||
),
|
||||
.ns = "REDCapCAST"
|
||||
)
|
||||
|
||||
# browser()
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
data_rv$data_status <- "error"
|
||||
data_rv$data_list <- NULL
|
||||
|
|
@ -453,9 +478,17 @@ m_redcap_readServer <- function(id) {
|
|||
datamods:::insert_alert(
|
||||
selector = ns("retrieved"),
|
||||
status = data_rv$data_status,
|
||||
tags$p(
|
||||
tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"),
|
||||
data_rv$data_message
|
||||
# tags$p(
|
||||
# tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"),
|
||||
# data_rv$data_message
|
||||
# ),
|
||||
include_data_alert(
|
||||
see_data_text = "Click to see the imported data",
|
||||
dataIdName = "see_data",
|
||||
extra = tags$p(
|
||||
tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message)
|
||||
),
|
||||
btn_show_data = TRUE
|
||||
)
|
||||
)
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -271,12 +271,13 @@ data_type <- function(data) {
|
|||
sapply(data, data_type)
|
||||
} else {
|
||||
cl_d <- class(data)
|
||||
l_unique <- length(unique(na.omit(data)))
|
||||
if (all(is.na(data))) {
|
||||
out <- "empty"
|
||||
} else if (length(unique(data)) < 2) {
|
||||
} else if (l_unique < 2) {
|
||||
out <- "monotone"
|
||||
} else if (any(c("factor", "logical") %in% cl_d) | length(unique(data)) == 2) {
|
||||
if (identical("logical", cl_d) | length(unique(data)) == 2) {
|
||||
} else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) {
|
||||
if (identical("logical", cl_d) | l_unique == 2) {
|
||||
out <- "dichotomous"
|
||||
} else {
|
||||
# if (is.ordered(data)) {
|
||||
|
|
@ -289,7 +290,7 @@ data_type <- function(data) {
|
|||
out <- "text"
|
||||
} else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) {
|
||||
out <- "datetime"
|
||||
} else if (!length(unique(data)) == 2) {
|
||||
} else if (l_unique > 2) {
|
||||
## Previously had all thinkable classes
|
||||
## Now just assumes the class has not been defined above
|
||||
## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) &
|
||||
|
|
|
|||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
|
|
@ -31,7 +31,7 @@ update_factor_ui <- function(id) {
|
|||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
virtualSelectInput(
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Factor variable to reorder:"),
|
||||
choices = NULL,
|
||||
|
|
@ -66,10 +66,10 @@ update_factor_ui <- function(id) {
|
|||
)
|
||||
)
|
||||
),
|
||||
datagridOutput(ns("grid")),
|
||||
toastui::datagridOutput(ns("grid")),
|
||||
tags$div(
|
||||
class = "float-end",
|
||||
prettyCheckbox(
|
||||
shinyWidgets::prettyCheckbox(
|
||||
inputId = ns("new_var"),
|
||||
label = i18n("Create a new variable (otherwise replaces the one selected)"),
|
||||
value = FALSE,
|
||||
|
|
|
|||
|
|
@ -1,7 +1,3 @@
|
|||
library(data.table)
|
||||
library(rlang)
|
||||
|
||||
|
||||
#' Select, rename and convert variables
|
||||
#'
|
||||
#' @param id Module id. See [shiny::moduleServer()].
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@
|
|||
[](https://agdamsbo.shinyapps.io/FreesearchR/)
|
||||
<!-- badges: end -->
|
||||
|
||||
The [***FreesearchR***](https://agdamsbo.shinyapps.io/FreesearchR/) is a simple, clinical health data exploration and analysis tool to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results.
|
||||
The [***FreesearchR***](https://app.freesearchr.org) is a simple, clinical health data exploration and analysis tool to democratise clinical research by assisting any researcher to easily evaluate and analyse data and export publication ready results.
|
||||
|
||||
[***FreesearchR***](https://agdamsbo.shinyapps.io/FreesearchR/) is free and open-source, and is directly accessible here: [link to the app freely hosted on shinyapps.io](https://agdamsbo.shinyapps.io/FreesearchR/). The app can also run locally, please see below.
|
||||
[***FreesearchR***](https://app.freesearchr.org) is free and open-source, and is [accessible in your web browser through this link](https://app.freesearchr.org). The app can also run locally, please [see below](#run-locally-on-your-own-machine-sec-run-locally).
|
||||
|
||||
All feedback is welcome and can be shared as a GitHub issue. Any suggestions on collaboration is much welcomed. Please reach out!
|
||||
|
||||
|
|
|
|||
25
SESSION.md
25
SESSION.md
|
|
@ -11,11 +11,11 @@
|
|||
|collate |en_US.UTF-8 |
|
||||
|ctype |en_US.UTF-8 |
|
||||
|tz |Europe/Copenhagen |
|
||||
|date |2025-05-08 |
|
||||
|date |2025-05-10 |
|
||||
|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.5.2.250508 |
|
||||
|quarto |1.7.30 @ /usr/local/bin/quarto |
|
||||
|FreesearchR |25.5.4.250510 |
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -44,7 +44,6 @@
|
|||
|commonmark |1.9.5 |2025-03-17 |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) |
|
||||
|crosstalk |1.2.1 |2023-11-23 |CRAN (R 4.4.0) |
|
||||
|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) |
|
||||
|datamods |1.5.3 |2024-10-02 |CRAN (R 4.4.1) |
|
||||
|
|
@ -59,6 +58,7 @@
|
|||
|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) |
|
||||
|eulerr |7.0.2 |2024-03-28 |CRAN (R 4.4.0) |
|
||||
|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) |
|
||||
|
|
@ -66,8 +66,11 @@
|
|||
|forcats |1.0.0 |2023-01-29 |CRAN (R 4.4.0) |
|
||||
|fs |1.6.6 |2025-04-12 |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) |
|
||||
|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) |
|
||||
|gtable |0.3.6 |2024-10-25 |CRAN (R 4.4.1) |
|
||||
|gtsummary |2.2.0 |2025-04-14 |CRAN (R 4.4.1) |
|
||||
|
|
@ -85,6 +88,7 @@
|
|||
|KernSmooth |2.23-26 |2025-01-01 |CRAN (R 4.4.1) |
|
||||
|keyring |1.3.2 |2023-12-11 |CRAN (R 4.4.0) |
|
||||
|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) |
|
||||
|lattice |0.22-7 |2025-04-02 |CRAN (R 4.4.1) |
|
||||
|lifecycle |1.0.4 |2023-11-07 |CRAN (R 4.4.1) |
|
||||
|
|
@ -101,7 +105,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.15 |2025-04-25 |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) |
|
||||
|
|
@ -110,6 +113,8 @@
|
|||
|pkgbuild |1.4.7 |2025-03-24 |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) |
|
||||
|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) |
|
||||
|profvis |0.4.0 |2024-09-20 |CRAN (R 4.4.1) |
|
||||
|promises |1.3.2 |2024-11-28 |CRAN (R 4.4.1) |
|
||||
|
|
@ -122,6 +127,8 @@
|
|||
|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) |
|
||||
|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) |
|
||||
|RColorBrewer |1.1-3 |2022-04-03 |CRAN (R 4.4.1) |
|
||||
|Rcpp |1.0.14 |2025-01-12 |CRAN (R 4.4.1) |
|
||||
|
|
@ -139,6 +146,7 @@
|
|||
|rio |1.2.3 |2024-09-25 |CRAN (R 4.4.1) |
|
||||
|rlang |1.1.6 |2025-04-11 |CRAN (R 4.4.1) |
|
||||
|rmarkdown |2.29 |2024-11-04 |CRAN (R 4.4.1) |
|
||||
|roxygen2 |7.3.2 |2024-06-28 |CRAN (R 4.4.0) |
|
||||
|rprojroot |2.0.4 |2023-11-05 |CRAN (R 4.4.1) |
|
||||
|rsconnect |1.3.4 |2025-01-22 |CRAN (R 4.4.1) |
|
||||
|rstudioapi |0.17.1 |2024-10-22 |CRAN (R 4.4.1) |
|
||||
|
|
@ -152,16 +160,23 @@
|
|||
|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) |
|
||||
|stringr |1.5.1 |2023-11-14 |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) |
|
||||
|tidyr |1.3.1 |2024-01-24 |CRAN (R 4.4.1) |
|
||||
|tidyselect |1.2.1 |2024-03-11 |CRAN (R 4.4.0) |
|
||||
|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) |
|
||||
|urlchecker |1.0.1 |2021-11-30 |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) |
|
||||
|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) |
|
||||
|withr |3.0.2 |2024-10-28 |CRAN (R 4.4.1) |
|
||||
|writexl |1.5.4 |2025-04-15 |CRAN (R 4.4.1) |
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ template:
|
|||
# Adding the switch destroys the theme colors
|
||||
light-switch: false
|
||||
includes:
|
||||
in_header: <script defer src="https://analytics.gdamsbo.dk/script.js" data-website-id="1f3baf18-29aa-4612-931b-58ea35922ae4"></script>
|
||||
in_header: <script defer src="https://stats.freesearchr.org/script.js" data-website-id="85bfd1e8-2cbe-4a4a-aa34-1dfb2960905b"></script>
|
||||
|
||||
navbar:
|
||||
bg: primary
|
||||
|
|
|
|||
|
|
@ -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
|
||||
########
|
||||
|
|
@ -10,7 +49,7 @@
|
|||
#### 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")
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom grDevices col2rgb
|
||||
#'
|
||||
contrast_text <- function(background,
|
||||
light_text = 'white',
|
||||
|
|
@ -323,20 +361,17 @@ sentence_paste <- function(data, and.str = "and") {
|
|||
#' @export
|
||||
#'
|
||||
#' @importFrom htmltools tagList tags css
|
||||
#' @importFrom shiny NS textInput textAreaInput uiOutput actionButton
|
||||
#' @importFrom phosphoricons ph
|
||||
#' @importFrom shinyWidgets virtualSelectInput
|
||||
#'
|
||||
#' @name create-column
|
||||
#'
|
||||
#' @example examples/create_column_module_demo.R
|
||||
create_column_ui <- function(id) {
|
||||
ns <- NS(id)
|
||||
tagList(
|
||||
htmltools::tagList(
|
||||
# datamods:::html_dependency_datamods(),
|
||||
# html_dependency_FreesearchR(),
|
||||
tags$head(
|
||||
tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
|
||||
shiny::tags$head(
|
||||
shiny::tags$link(rel = "stylesheet", type = "text/css", href = "FreesearchR/inst/assets/css/FreesearchR.css")
|
||||
),
|
||||
# tags$head(
|
||||
# # Note the wrapping of the string in HTML()
|
||||
|
|
@ -390,7 +425,7 @@ create_column_ui <- function(id) {
|
|||
)
|
||||
)
|
||||
),
|
||||
textAreaInput(
|
||||
shiny::textAreaInput(
|
||||
inputId = ns("expression"),
|
||||
label = i18n("Enter an expression to define new column:"),
|
||||
value = "",
|
||||
|
|
@ -438,9 +473,6 @@ create_column_ui <- function(id) {
|
|||
#'
|
||||
#' @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()) {
|
||||
|
|
@ -947,12 +979,6 @@ vectorSelectInput <- function(inputId,
|
|||
#### 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
|
||||
#'
|
||||
#' @param x an object inheriting from class "hms"
|
||||
|
|
@ -1161,9 +1187,9 @@ cut_variable_ui <- function(id) {
|
|||
shiny::fluidRow(
|
||||
column(
|
||||
width = 3,
|
||||
virtualSelectInput(
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Variable to cut:"),
|
||||
label = datamods:::i18n("Variable to cut:"),
|
||||
choices = NULL,
|
||||
width = "100%"
|
||||
)
|
||||
|
|
@ -1176,7 +1202,7 @@ cut_variable_ui <- function(id) {
|
|||
width = 3,
|
||||
numericInput(
|
||||
inputId = ns("n_breaks"),
|
||||
label = i18n("Number of breaks:"),
|
||||
label = datamods:::i18n("Number of breaks:"),
|
||||
value = 3,
|
||||
min = 2,
|
||||
max = 12,
|
||||
|
|
@ -1187,12 +1213,12 @@ cut_variable_ui <- function(id) {
|
|||
width = 3,
|
||||
checkboxInput(
|
||||
inputId = ns("right"),
|
||||
label = i18n("Close intervals on the right"),
|
||||
label = datamods:::i18n("Close intervals on the right"),
|
||||
value = TRUE
|
||||
),
|
||||
checkboxInput(
|
||||
inputId = ns("include_lowest"),
|
||||
label = i18n("Include lowest value"),
|
||||
label = datamods:::i18n("Include lowest value"),
|
||||
value = TRUE
|
||||
)
|
||||
)
|
||||
|
|
@ -1203,10 +1229,10 @@ cut_variable_ui <- function(id) {
|
|||
uiOutput(outputId = ns("slider_fixed"))
|
||||
),
|
||||
plotOutput(outputId = ns("plot"), width = "100%", height = "270px"),
|
||||
datagridOutput2(outputId = ns("count")),
|
||||
toastui::datagridOutput2(outputId = ns("count")),
|
||||
actionButton(
|
||||
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"
|
||||
),
|
||||
tags$div(class = "clearfix")
|
||||
|
|
@ -1237,7 +1263,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
is.numeric(.x) || is_datetime(.x)
|
||||
}, logical(1))
|
||||
vars_num <- names(vars_num)[vars_num]
|
||||
updateVirtualSelect(
|
||||
shinyWidgets::updateVirtualSelect(
|
||||
inputId = "variable",
|
||||
choices = vars_num,
|
||||
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"),
|
||||
label = i18n("Fixed breaks:"),
|
||||
label = datamods:::i18n("Fixed breaks:"),
|
||||
min = lower,
|
||||
max = upper,
|
||||
value = brks,
|
||||
|
|
@ -1331,7 +1357,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = session$ns("method"),
|
||||
label = i18n("Method:"),
|
||||
label = datamods:::i18n("Method:"),
|
||||
choices = choices,
|
||||
selected = NULL,
|
||||
width = "100%"
|
||||
|
|
@ -1474,7 +1500,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
data
|
||||
})
|
||||
|
||||
output$count <- renderDatagrid2({
|
||||
output$count <- toastui::renderDatagrid2({
|
||||
# shiny::req(rv$new_var_name)
|
||||
data <- req(data_cutted_r())
|
||||
# variable <- req(input$variable)
|
||||
|
|
@ -1490,14 +1516,14 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
datamods:::apply_grid_theme()
|
||||
}
|
||||
on.exit(toastui::reset_grid_theme())
|
||||
grid <- datagrid(
|
||||
grid <- toastui::datagrid(
|
||||
data = count_data,
|
||||
colwidths = "guess",
|
||||
theme = "default",
|
||||
bodyHeight = "auto"
|
||||
)
|
||||
grid <- toastui::grid_columns(grid, className = "font-monospace")
|
||||
grid_colorbar(
|
||||
toastui::grid_colorbar(
|
||||
grid,
|
||||
column = "count",
|
||||
label_outside = TRUE,
|
||||
|
|
@ -1525,7 +1551,7 @@ cut_variable_server <- function(id, data_r = reactive(NULL)) {
|
|||
#'
|
||||
#' @rdname cut-variable
|
||||
modal_cut_variable <- function(id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
title = datamods:::i18n("Convert Numeric to Factor"),
|
||||
easyClose = TRUE,
|
||||
size = "l",
|
||||
footer = NULL) {
|
||||
|
|
@ -2255,6 +2281,7 @@ create_plot <- function(data, type, pri, sec, ter = NULL, ...) {
|
|||
#' mtcars |> get_label()
|
||||
#' mtcars$mpg |> get_label()
|
||||
#' gtsummary::trial |> get_label(var = "trt")
|
||||
#' gtsummary::trial$trt |> get_label()
|
||||
#' 1:10 |> get_label()
|
||||
get_label <- function(data, var = NULL) {
|
||||
# data <- if (is.reactive(data)) data() else data
|
||||
|
|
@ -2983,7 +3010,7 @@ show_data <- function(data,
|
|||
if (is.null(options))
|
||||
options <- list()
|
||||
|
||||
options$height <- 550
|
||||
options$height <- 500
|
||||
options$minBodyHeight <- 400
|
||||
options$data <- data
|
||||
options$theme <- "default"
|
||||
|
|
@ -3951,11 +3978,25 @@ is_identical_to_previous <- function(data, no.name = TRUE) {
|
|||
}
|
||||
|
||||
|
||||
#' Simplified version of the snakecase packages to_snake_case
|
||||
#'
|
||||
#' @param data character string vector
|
||||
#'
|
||||
#' @returns vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake()
|
||||
simple_snake <- function(data){
|
||||
gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE)
|
||||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
|
||||
########
|
||||
|
||||
hosted_version <- function()'v25.5.2-250508'
|
||||
hosted_version <- function()'v25.5.3-250510'
|
||||
|
||||
|
||||
########
|
||||
|
|
@ -4793,10 +4834,11 @@ plot_euler <- function(data, pri, sec, ter = NULL, seed = 2103) {
|
|||
out <- lapply(ds, \(.x){
|
||||
.x[c(pri, sec)] |>
|
||||
as.data.frame() |>
|
||||
na.omit() |>
|
||||
plot_euler_single()
|
||||
})
|
||||
|
||||
# names(out)
|
||||
# names(out)
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
|
@ -4908,9 +4950,8 @@ vertical_stacked_bars <- function(data,
|
|||
contrast_cut <-
|
||||
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"))
|
||||
group_label <- ifelse(is.na(REDCapCAST::get_attr(data$group, "label")), group, REDCapCAST::get_attr(data$group, "label"))
|
||||
|
||||
score_label <- data |> get_label(var = score)
|
||||
group_label <- data |> get_label(var = group)
|
||||
|
||||
p |>
|
||||
(\(.x){
|
||||
|
|
@ -5100,7 +5141,6 @@ plot_sankey <- function(data, pri, sec, ter = NULL, color.group = "pri", colors
|
|||
#' plot_sankey_single("first", "last", color.group = "pri")
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' str()
|
||||
#' plot_sankey_single("cyl", "vs", color.group = "pri")
|
||||
plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), colors = NULL, ...) {
|
||||
color.group <- match.arg(color.group)
|
||||
|
|
@ -5113,8 +5153,6 @@ plot_sankey_single <- function(data, pri, sec, color.group = c("pri", "sec"), co
|
|||
|
||||
data <- data |> sankey_ready(pri = pri, sec = sec, ...)
|
||||
|
||||
library(ggalluvial)
|
||||
|
||||
na.color <- "#2986cc"
|
||||
box.color <- "#1E4B66"
|
||||
|
||||
|
|
@ -5178,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 +
|
||||
ggplot2::geom_text(
|
||||
stat = "stratum",
|
||||
|
|
@ -5566,9 +5606,12 @@ m_redcap_readServer <- function(id) {
|
|||
)
|
||||
|
||||
# browser()
|
||||
shiny::withProgress({
|
||||
shiny::withProgress(
|
||||
{
|
||||
imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE)
|
||||
},message = paste("Connecting to",data_rv$uri))
|
||||
},
|
||||
message = paste("Connecting to", data_rv$uri)
|
||||
)
|
||||
|
||||
## TODO: Simplify error messages
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) {
|
||||
|
|
@ -5594,7 +5637,7 @@ m_redcap_readServer <- function(id) {
|
|||
status = "success",
|
||||
include_data_alert(
|
||||
see_data_text = "Click to see data dictionary",
|
||||
dataIdName = "see_data",
|
||||
dataIdName = "see_dd",
|
||||
extra = tags$p(
|
||||
tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"),
|
||||
glue::glue("The {data_rv$info$project_title} project is loaded.")
|
||||
|
|
@ -5620,8 +5663,8 @@ m_redcap_readServer <- function(id) {
|
|||
output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success"))
|
||||
shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE)
|
||||
|
||||
shiny::observeEvent(input$see_data, {
|
||||
datamods::show_data(
|
||||
shiny::observeEvent(input$see_dd, {
|
||||
show_data(
|
||||
purrr::pluck(data_rv$dd_list, "data"),
|
||||
title = "Data dictionary",
|
||||
type = "modal",
|
||||
|
|
@ -5630,6 +5673,17 @@ m_redcap_readServer <- function(id) {
|
|||
)
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$see_data, {
|
||||
show_data(
|
||||
# purrr::pluck(data_rv$dd_list, "data"),
|
||||
data_rv$data,
|
||||
title = "Imported data set",
|
||||
type = "modal",
|
||||
show_classes = FALSE,
|
||||
tags$b("Preview:")
|
||||
)
|
||||
})
|
||||
|
||||
arms <- shiny::reactive({
|
||||
shiny::req(input$api)
|
||||
shiny::req(data_rv$uri)
|
||||
|
|
@ -5744,13 +5798,24 @@ m_redcap_readServer <- function(id) {
|
|||
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE)
|
||||
})
|
||||
|
||||
code <- rlang::call2("read_redcap_tables",
|
||||
!!!utils::modifyList(parameters, list(token = "PERSONAL_API_TOKEN")), ,
|
||||
parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")]
|
||||
|
||||
code <- rlang::call2(
|
||||
"easy_redcap",
|
||||
!!!utils::modifyList(
|
||||
parameters_code,
|
||||
list(
|
||||
data_format = ifelse(
|
||||
input$data_type == "long" && !is.null(input$data_type),
|
||||
"long",
|
||||
"wide"
|
||||
),
|
||||
project.name = simple_snake(data_rv$info$project_title)
|
||||
)
|
||||
),
|
||||
.ns = "REDCapCAST"
|
||||
)
|
||||
|
||||
# browser()
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
data_rv$data_status <- "error"
|
||||
data_rv$data_list <- NULL
|
||||
|
|
@ -5819,9 +5884,17 @@ m_redcap_readServer <- function(id) {
|
|||
datamods:::insert_alert(
|
||||
selector = ns("retrieved"),
|
||||
status = data_rv$data_status,
|
||||
tags$p(
|
||||
tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"),
|
||||
data_rv$data_message
|
||||
# tags$p(
|
||||
# tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"),
|
||||
# data_rv$data_message
|
||||
# ),
|
||||
include_data_alert(
|
||||
see_data_text = "Click to see the imported data",
|
||||
dataIdName = "see_data",
|
||||
extra = tags$p(
|
||||
tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message)
|
||||
),
|
||||
btn_show_data = TRUE
|
||||
)
|
||||
)
|
||||
} else {
|
||||
|
|
@ -6022,13 +6095,6 @@ redcap_demo_app <- function() {
|
|||
}
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//redcap.R
|
||||
########
|
||||
|
||||
|
||||
|
||||
|
||||
########
|
||||
#### Current file: /Users/au301842/FreesearchR/R//regression_model.R
|
||||
########
|
||||
|
|
@ -6306,12 +6372,13 @@ data_type <- function(data) {
|
|||
sapply(data, data_type)
|
||||
} else {
|
||||
cl_d <- class(data)
|
||||
l_unique <- length(unique(na.omit(data)))
|
||||
if (all(is.na(data))) {
|
||||
out <- "empty"
|
||||
} else if (length(unique(data)) < 2) {
|
||||
} else if (l_unique < 2) {
|
||||
out <- "monotone"
|
||||
} else if (any(c("factor", "logical") %in% cl_d) | length(unique(data)) == 2) {
|
||||
if (identical("logical", cl_d) | length(unique(data)) == 2) {
|
||||
} else if (any(c("factor", "logical") %in% cl_d) | l_unique == 2) {
|
||||
if (identical("logical", cl_d) | l_unique == 2) {
|
||||
out <- "dichotomous"
|
||||
} else {
|
||||
# if (is.ordered(data)) {
|
||||
|
|
@ -6324,7 +6391,7 @@ data_type <- function(data) {
|
|||
out <- "text"
|
||||
} else if (any(c("hms", "Date", "POSIXct", "POSIXt") %in% cl_d)) {
|
||||
out <- "datetime"
|
||||
} else if (!length(unique(data)) == 2) {
|
||||
} else if (l_unique > 2) {
|
||||
## Previously had all thinkable classes
|
||||
## Now just assumes the class has not been defined above
|
||||
## any(c("numeric", "integer", "hms", "Date", "timediff") %in% cl_d) &
|
||||
|
|
@ -7999,7 +8066,7 @@ update_factor_ui <- function(id) {
|
|||
fluidRow(
|
||||
column(
|
||||
width = 6,
|
||||
virtualSelectInput(
|
||||
shinyWidgets::virtualSelectInput(
|
||||
inputId = ns("variable"),
|
||||
label = i18n("Factor variable to reorder:"),
|
||||
choices = NULL,
|
||||
|
|
@ -8034,10 +8101,10 @@ update_factor_ui <- function(id) {
|
|||
)
|
||||
)
|
||||
),
|
||||
datagridOutput(ns("grid")),
|
||||
toastui::datagridOutput(ns("grid")),
|
||||
tags$div(
|
||||
class = "float-end",
|
||||
prettyCheckbox(
|
||||
shinyWidgets::prettyCheckbox(
|
||||
inputId = ns("new_var"),
|
||||
label = i18n("Create a new variable (otherwise replaces the one selected)"),
|
||||
value = FALSE,
|
||||
|
|
@ -8263,10 +8330,6 @@ winbox_update_factor <- function(id,
|
|||
#### Current file: /Users/au301842/FreesearchR/R//update-variables-ext.R
|
||||
########
|
||||
|
||||
library(data.table)
|
||||
library(rlang)
|
||||
|
||||
|
||||
#' Select, rename and convert variables
|
||||
#'
|
||||
#' @param id Module id. See [shiny::moduleServer()].
|
||||
|
|
@ -9317,10 +9380,10 @@ ui_elements <- list(
|
|||
condition = "input.source=='env'",
|
||||
import_globalenv_ui(id = "env", title = NULL)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='redcap'",
|
||||
DT::DTOutput(outputId = "redcap_prev")
|
||||
),
|
||||
# shiny::conditionalPanel(
|
||||
# condition = "input.source=='redcap'",
|
||||
# DT::DTOutput(outputId = "redcap_prev")
|
||||
# ),
|
||||
shiny::conditionalPanel(
|
||||
condition = "output.data_loaded == true",
|
||||
shiny::br(),
|
||||
|
|
@ -9329,13 +9392,8 @@ ui_elements <- list(
|
|||
shiny::fluidRow(
|
||||
shiny::column(
|
||||
width = 6,
|
||||
shiny::p("Filter by completeness threshold:"),
|
||||
shiny::br(),
|
||||
shiny::p("Filter by completeness threshold and manual selection:"),
|
||||
shiny::br(),
|
||||
shiny::br()
|
||||
),
|
||||
shiny::column(
|
||||
width = 6,
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = "complete_cutoff",
|
||||
label = NULL,
|
||||
|
|
@ -9348,12 +9406,17 @@ ui_elements <- list(
|
|||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::helpText("Exclude variables with completeness below the specified percentage."),
|
||||
shiny::br(),
|
||||
shiny::br()
|
||||
),
|
||||
shiny::column(
|
||||
width = 6,
|
||||
shiny::p("Specify manually:"),
|
||||
shiny::br(),
|
||||
shiny::uiOutput(outputId = "import_var"),
|
||||
shiny::br()
|
||||
)
|
||||
),
|
||||
shiny::uiOutput(outputId = "data_info_import", inline = TRUE)
|
||||
)
|
||||
)
|
||||
),
|
||||
shiny::br(),
|
||||
shiny::br(),
|
||||
|
|
@ -9830,33 +9893,7 @@ ui <- bslib::page_fixed(
|
|||
#### Current file: /Users/au301842/FreesearchR/app/server.R
|
||||
########
|
||||
|
||||
library(readr)
|
||||
library(MASS)
|
||||
library(stats)
|
||||
library(gt)
|
||||
# library(openxlsx2)
|
||||
library(haven)
|
||||
library(readODS)
|
||||
require(shiny)
|
||||
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(shinyjs)
|
||||
|
||||
|
||||
data(starwars)
|
||||
data(mtcars)
|
||||
|
|
@ -9864,8 +9901,8 @@ data(trial)
|
|||
|
||||
load_data <- function() {
|
||||
Sys.sleep(1)
|
||||
hide("loading_page")
|
||||
show("main_content")
|
||||
shinyjs::hide("loading_page")
|
||||
shinyjs::show("main_content")
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -9946,14 +9983,14 @@ server <- function(input, output, session) {
|
|||
})
|
||||
|
||||
## This is used to ensure the reactive data is retrieved
|
||||
output$redcap_prev <- DT::renderDT(
|
||||
{
|
||||
DT::datatable(head(from_redcap$data(), 5),
|
||||
caption = "First 5 observations"
|
||||
)
|
||||
},
|
||||
server = TRUE
|
||||
)
|
||||
# output$redcap_prev <- DT::renderDT(
|
||||
# {
|
||||
# DT::datatable(head(from_redcap$data(), 5),
|
||||
# caption = "First 5 observations"
|
||||
# )
|
||||
# },
|
||||
# server = TRUE
|
||||
# )
|
||||
|
||||
from_env <- datamods::import_globalenv_server(
|
||||
id = "env",
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ cut_variable_server(id, data_r = reactive(NULL))
|
|||
|
||||
modal_cut_variable(
|
||||
id,
|
||||
title = i18n("Convert Numeric to Factor"),
|
||||
title = datamods:::i18n("Convert Numeric to Factor"),
|
||||
easyClose = TRUE,
|
||||
size = "l",
|
||||
footer = NULL
|
||||
|
|
|
|||
|
|
@ -22,5 +22,6 @@ mtcars |> get_label(var = "mpg")
|
|||
mtcars |> get_label()
|
||||
mtcars$mpg |> get_label()
|
||||
gtsummary::trial |> get_label(var = "trt")
|
||||
gtsummary::trial$trt |> get_label()
|
||||
1:10 |> get_label()
|
||||
}
|
||||
|
|
|
|||
|
|
@ -39,6 +39,5 @@ data.frame(
|
|||
plot_sankey_single("first", "last", color.group = "pri")
|
||||
mtcars |>
|
||||
default_parsing() |>
|
||||
str()
|
||||
plot_sankey_single("cyl", "vs", color.group = "pri")
|
||||
}
|
||||
|
|
|
|||
20
man/simple_snake.Rd
Normal file
20
man/simple_snake.Rd
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/helpers.R
|
||||
\name{simple_snake}
|
||||
\alias{simple_snake}
|
||||
\title{Simplified version of the snakecase packages to_snake_case}
|
||||
\usage{
|
||||
simple_snake(data)
|
||||
}
|
||||
\arguments{
|
||||
\item{data}{character string vector}
|
||||
}
|
||||
\value{
|
||||
vector
|
||||
}
|
||||
\description{
|
||||
Simplified version of the snakecase packages to_snake_case
|
||||
}
|
||||
\examples{
|
||||
c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake()
|
||||
}
|
||||
Loading…
Add table
Reference in a new issue