mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2025-09-12 18:09:39 +02:00
Compare commits
No commits in common. "268038e49e179954b712bc8c8973f5a3e7719c99" and "efc3f8acc37a541ea3d123c0d0fa186c7b7401f2" have entirely different histories.
268038e49e
...
efc3f8acc3
25 changed files with 1037 additions and 1751 deletions
|
|
@ -68,8 +68,7 @@ Imports:
|
|||
REDCapCAST,
|
||||
eulerr,
|
||||
ggforce,
|
||||
RcppArmadillo,
|
||||
ggcorrplot
|
||||
RcppArmadillo
|
||||
Suggests:
|
||||
styler,
|
||||
devtools,
|
||||
|
|
|
|||
18
NAMESPACE
18
NAMESPACE
|
|
@ -104,12 +104,21 @@ importFrom(graphics,par)
|
|||
importFrom(graphics,plot.new)
|
||||
importFrom(graphics,plot.window)
|
||||
importFrom(htmltools,css)
|
||||
importFrom(htmltools,tagAppendAttributes)
|
||||
importFrom(htmltools,tagAppendChild)
|
||||
importFrom(htmltools,tagList)
|
||||
importFrom(htmltools,tags)
|
||||
importFrom(htmltools,validateCssUnit)
|
||||
importFrom(phosphoricons,ph)
|
||||
importFrom(readxl,excel_sheets)
|
||||
importFrom(rio,import)
|
||||
importFrom(rlang,"%||%")
|
||||
importFrom(rlang,call2)
|
||||
importFrom(rlang,exec)
|
||||
importFrom(rlang,expr)
|
||||
importFrom(rlang,fn_fmls_names)
|
||||
importFrom(rlang,is_function)
|
||||
importFrom(rlang,is_named)
|
||||
importFrom(rlang,set_names)
|
||||
importFrom(rlang,sym)
|
||||
importFrom(rlang,syms)
|
||||
|
|
@ -118,6 +127,7 @@ importFrom(shiny,actionButton)
|
|||
importFrom(shiny,bindEvent)
|
||||
importFrom(shiny,checkboxInput)
|
||||
importFrom(shiny,column)
|
||||
importFrom(shiny,fileInput)
|
||||
importFrom(shiny,fluidRow)
|
||||
importFrom(shiny,getDefaultReactiveDomain)
|
||||
importFrom(shiny,icon)
|
||||
|
|
@ -129,6 +139,7 @@ importFrom(shiny,observeEvent)
|
|||
importFrom(shiny,plotOutput)
|
||||
importFrom(shiny,reactive)
|
||||
importFrom(shiny,reactiveValues)
|
||||
importFrom(shiny,removeUI)
|
||||
importFrom(shiny,renderPlot)
|
||||
importFrom(shiny,req)
|
||||
importFrom(shiny,restoreInput)
|
||||
|
|
@ -139,8 +150,13 @@ importFrom(shiny,textInput)
|
|||
importFrom(shiny,uiOutput)
|
||||
importFrom(shiny,updateActionButton)
|
||||
importFrom(shinyWidgets,WinBox)
|
||||
importFrom(shinyWidgets,dropMenu)
|
||||
importFrom(shinyWidgets,noUiSliderInput)
|
||||
importFrom(shinyWidgets,numericInputIcon)
|
||||
importFrom(shinyWidgets,pickerInput)
|
||||
importFrom(shinyWidgets,prettyCheckbox)
|
||||
importFrom(shinyWidgets,textInputIcon)
|
||||
importFrom(shinyWidgets,updatePickerInput)
|
||||
importFrom(shinyWidgets,updateVirtualSelect)
|
||||
importFrom(shinyWidgets,virtualSelectInput)
|
||||
importFrom(shinyWidgets,wbControls)
|
||||
|
|
@ -153,4 +169,6 @@ importFrom(toastui,grid_colorbar)
|
|||
importFrom(toastui,grid_columns)
|
||||
importFrom(toastui,renderDatagrid)
|
||||
importFrom(toastui,renderDatagrid2)
|
||||
importFrom(tools,file_ext)
|
||||
importFrom(utils,head)
|
||||
importFrom(utils,type.convert)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
app_version <- function()'250313_1502'
|
||||
app_version <- function()'250312_1817'
|
||||
|
|
|
|||
|
|
@ -46,8 +46,7 @@ data_correlations_server <- function(id,
|
|||
} else {
|
||||
out <- data()
|
||||
}
|
||||
out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
|
||||
# as.numeric()
|
||||
out
|
||||
})
|
||||
|
||||
# rv <- list()
|
||||
|
|
@ -75,25 +74,7 @@ data_correlations_server <- function(id,
|
|||
})
|
||||
|
||||
output$correlation_plot <- shiny::renderPlot({
|
||||
ggcorrplot::ggcorrplot(cor(rv$data())) +
|
||||
# ggplot2::theme_void() +
|
||||
ggplot2::theme(
|
||||
# legend.position = "none",
|
||||
legend.title = ggplot2::element_text(size = 20),
|
||||
legend.text = ggplot2::element_text(size = 14),
|
||||
# panel.grid.major = element_blank(),
|
||||
# panel.grid.minor = element_blank(),
|
||||
# axis.text.y = element_blank(),
|
||||
# axis.title.y = element_blank(),
|
||||
axis.text.x = ggplot2::element_text(size = 20),
|
||||
axis.text.y = ggplot2::element_text(size = 20),
|
||||
# text = element_text(size = 5),
|
||||
# plot.title = element_blank(),
|
||||
# panel.background = ggplot2::element_rect(fill = "white"),
|
||||
# plot.background = ggplot2::element_rect(fill = "white"),
|
||||
panel.border = ggplot2::element_blank()
|
||||
)
|
||||
# psych::pairs.panels(rv$data())
|
||||
psych::pairs.panels(rv$data())
|
||||
})
|
||||
}
|
||||
)
|
||||
|
|
@ -133,7 +114,7 @@ sentence_paste <- function(data, and.str = "and") {
|
|||
}
|
||||
|
||||
|
||||
cor_demo_app <- function() {
|
||||
cor_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
shiny::sliderInput(
|
||||
inputId = "cor_cutoff",
|
||||
|
|
@ -147,9 +128,9 @@ cor_demo_app <- function() {
|
|||
data_correlations_ui("data", height = 600)
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
data_correlations_server("data", data = shiny::reactive(default_parsing(mtcars)), cutoff = shiny::reactive(input$cor_cutoff))
|
||||
data_correlations_server("data", data = shiny::reactive(mtcars), cutoff = shiny::reactive(input$cor_cutoff))
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
cor_demo_app()
|
||||
cor_app()
|
||||
|
|
|
|||
250
R/data-import.R
250
R/data-import.R
|
|
@ -1,250 +0,0 @@
|
|||
#' data_import_ui <- function(id, include_title = TRUE) {
|
||||
#' ns <- shiny::NS(id)
|
||||
#'
|
||||
#' shiny::fluidRow(
|
||||
#' shiny::column(width = 2),
|
||||
#' shiny::column(
|
||||
#' width = 8,
|
||||
#' shiny::h4("Choose your data source"),
|
||||
#' shiny::br(),
|
||||
#' shinyWidgets::radioGroupButtons(
|
||||
#' inputId = "source",
|
||||
#' selected = "env",
|
||||
#' choices = c(
|
||||
#' "File upload" = "file",
|
||||
#' "REDCap server export" = "redcap",
|
||||
#' "Local or sample data" = "env"
|
||||
#' ),
|
||||
#' width = "100%"
|
||||
#' ),
|
||||
#' shiny::helpText("Upload a file from your device, get data directly from REDCap or select a sample data set for testing from the app."),
|
||||
#' shiny::br(),
|
||||
#' shiny::br(),
|
||||
#' shiny::conditionalPanel(
|
||||
#' condition = "input.source=='file'",
|
||||
#' import_file_ui(
|
||||
#' id = "file_import",
|
||||
#' layout_params = "dropdown",
|
||||
#' title = "Choose a datafile to upload",
|
||||
#' file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".sas7bdat", ".ods", ".dta")
|
||||
#' )
|
||||
#' ),
|
||||
#' shiny::conditionalPanel(
|
||||
#' condition = "input.source=='redcap'",
|
||||
#' m_redcap_readUI("redcap_import")
|
||||
#' ),
|
||||
#' shiny::conditionalPanel(
|
||||
#' condition = "input.source=='env'",
|
||||
#' import_globalenv_ui(id = "env", title = NULL)
|
||||
#' ),
|
||||
#' shiny::conditionalPanel(
|
||||
#' condition = "input.source=='redcap'",
|
||||
#' DT::DTOutput(outputId = "redcap_prev")
|
||||
#' ),
|
||||
#' shiny::br(),
|
||||
#' shiny::br(),
|
||||
#' shiny::h5("Specify variables to include"),
|
||||
#' shiny::fluidRow(
|
||||
#' shiny::column(
|
||||
#' width = 6,
|
||||
#' 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,
|
||||
#' min = 0,
|
||||
#' max = 100,
|
||||
#' step = 5,
|
||||
#' value = 70,
|
||||
#' format = shinyWidgets::wNumbFormat(decimals = 0),
|
||||
#' color = datamods:::get_primary_color()
|
||||
#' ),
|
||||
#' shiny::helpText("Filter variables with completeness above the specified percentage."),
|
||||
#' shiny::br(),
|
||||
#' shiny::br(),
|
||||
#' shiny::uiOutput(outputId = "import_var")
|
||||
#' )
|
||||
#' ),
|
||||
#' shiny::br(),
|
||||
#' shiny::br(),
|
||||
#' shiny::actionButton(
|
||||
#' inputId = "act_start",
|
||||
#' label = "Start",
|
||||
#' width = "100%",
|
||||
#' icon = shiny::icon("play"),
|
||||
#' disabled = TRUE
|
||||
#' ),
|
||||
#' shiny::helpText('After importing, hit "Start" or navigate to the desired tab.'),
|
||||
#' shiny::br(),
|
||||
#' shiny::br(),
|
||||
#' shiny::column(width = 2)
|
||||
#' )
|
||||
#' )
|
||||
#' }
|
||||
#'
|
||||
#'
|
||||
#' data_import_server <- function(id) {
|
||||
#' module <- function(input, output, session) {
|
||||
#' ns <- session$ns
|
||||
#'
|
||||
#' rv <- shiny::reactiveValues(
|
||||
#' data_original = NULL,
|
||||
#' data_temp = NULL,
|
||||
#' data = NULL,
|
||||
#' code = list()
|
||||
#' )
|
||||
#'
|
||||
#' data_file <- import_file_server(
|
||||
#' id = "file_import",
|
||||
#' show_data_in = "popup",
|
||||
#' trigger_return = "change",
|
||||
#' return_class = "data.frame",
|
||||
#' read_fns = list(
|
||||
#' ods = import_ods,
|
||||
#' dta = function(file) {
|
||||
#' haven::read_dta(
|
||||
#' file = file,
|
||||
#' .name_repair = "unique_quiet"
|
||||
#' )
|
||||
#' },
|
||||
#' # csv = function(file) {
|
||||
#' # readr::read_csv(
|
||||
#' # file = file,
|
||||
#' # na = consider.na,
|
||||
#' # name_repair = "unique_quiet"
|
||||
#' # )
|
||||
#' # },
|
||||
#' csv = import_delim,
|
||||
#' tsv = import_delim,
|
||||
#' txt = import_delim,
|
||||
#' xls = import_xls,
|
||||
#' xlsx = import_xls,
|
||||
#' rds = function(file) {
|
||||
#' readr::read_rds(
|
||||
#' file = file,
|
||||
#' name_repair = "unique_quiet"
|
||||
#' )
|
||||
#' }
|
||||
#' )
|
||||
#' )
|
||||
#'
|
||||
#' shiny::observeEvent(data_file$data(), {
|
||||
#' shiny::req(data_file$data())
|
||||
#' rv$data_temp <- data_file$data()
|
||||
#' rv$code <- append_list(data = data_file$code(), list = rv$code, index = "import")
|
||||
#' })
|
||||
#'
|
||||
#' data_redcap <- m_redcap_readServer(
|
||||
#' id = "redcap_import" # ,
|
||||
#' # output.format = "list"
|
||||
#' )
|
||||
#'
|
||||
#' shiny::observeEvent(data_redcap(), {
|
||||
#' # rv$data_original <- purrr::pluck(data_redcap(), "data")()
|
||||
#' rv$data_temp <- data_redcap()
|
||||
#' })
|
||||
#'
|
||||
#' output$redcap_prev <- DT::renderDT(
|
||||
#' {
|
||||
#' DT::datatable(head(data_redcap(), 5),
|
||||
#' # DT::datatable(head(purrr::pluck(data_redcap(), "data")(), 5),
|
||||
#' caption = "First 5 observations"
|
||||
#' )
|
||||
#' },
|
||||
#' server = TRUE
|
||||
#' )
|
||||
#'
|
||||
#' from_env <- datamods::import_globalenv_server(
|
||||
#' id = "env",
|
||||
#' trigger_return = "change",
|
||||
#' btn_show_data = FALSE,
|
||||
#' reset = reactive(input$hidden)
|
||||
#' )
|
||||
#'
|
||||
#' shiny::observeEvent(from_env$data(), {
|
||||
#' shiny::req(from_env$data())
|
||||
#'
|
||||
#' rv$data_temp <- from_env$data()
|
||||
#' # rv$code <- append_list(data = from_env$code(),list = rv$code,index = "import")
|
||||
#' })
|
||||
#'
|
||||
#' output$import_var <- shiny::renderUI({
|
||||
#' shiny::req(rv$data_temp)
|
||||
#'
|
||||
#' preselect <- names(rv$data_temp)[sapply(rv$data_temp, missing_fraction) <= input$complete_cutoff / 100]
|
||||
#'
|
||||
#' shinyWidgets::virtualSelectInput(
|
||||
#' inputId = "import_var",
|
||||
#' label = "Select variables to include",
|
||||
#' selected = preselect,
|
||||
#' choices = names(rv$data_temp),
|
||||
#' updateOn = "close",
|
||||
#' multiple = TRUE,
|
||||
#' search = TRUE,
|
||||
#' showValueAsTags = TRUE
|
||||
#' )
|
||||
#' })
|
||||
#'
|
||||
#'
|
||||
#' shiny::observeEvent(
|
||||
#' eventExpr = list(
|
||||
#' input$import_var
|
||||
#' ),
|
||||
#' handlerExpr = {
|
||||
#' shiny::req(rv$data_temp)
|
||||
#'
|
||||
#' rv$data_original <- rv$data_temp |>
|
||||
#' dplyr::select(input$import_var) |>
|
||||
#' # janitor::clean_names() |>
|
||||
#' default_parsing()
|
||||
#' }
|
||||
#' )
|
||||
#'
|
||||
#' return(shiny::reactive(rv$data_original))
|
||||
#'
|
||||
#' }
|
||||
#'
|
||||
#' shiny::moduleServer(
|
||||
#' id = id,
|
||||
#' module = module
|
||||
#' )
|
||||
#'
|
||||
#' }
|
||||
#'
|
||||
#'
|
||||
#' #' Test app for the data-import module
|
||||
#' #'
|
||||
#' #' @rdname data-import
|
||||
#' #'
|
||||
#' #' @examples
|
||||
#' #' \dontrun{
|
||||
#' #' data_import_demo_app()
|
||||
#' #' }
|
||||
#' data_import_demo_app <- function() {
|
||||
#' ui <- shiny::fluidPage(
|
||||
#' data_import_ui("data")
|
||||
#' )
|
||||
#' server <- function(input, output, session) {
|
||||
#' data_val <- shiny::reactiveValues(data = NULL)
|
||||
#'
|
||||
#'
|
||||
#' data_val$data <- data_import_server(id = "data")
|
||||
#'
|
||||
#' output$data_summary <- DT::renderDataTable(
|
||||
#' {
|
||||
#' shiny::req(data_val$data)
|
||||
#' data_val$data()
|
||||
#' },
|
||||
#' options = list(
|
||||
#' scrollX = TRUE,
|
||||
#' pageLength = 5
|
||||
#' ),
|
||||
#' )
|
||||
#' }
|
||||
#' shiny::shinyApp(ui, server)
|
||||
#' }
|
||||
|
|
@ -31,6 +31,14 @@ data_summary_server <- function(id,
|
|||
module = function(input, output, session) {
|
||||
ns <- session$ns
|
||||
|
||||
# data_r <- shiny::reactive({
|
||||
# if (shiny::is.reactive(data)) {
|
||||
# data()
|
||||
# } else {
|
||||
# data
|
||||
# }
|
||||
# })
|
||||
|
||||
output$tbl_summary <-
|
||||
toastui::renderDatagrid(
|
||||
{
|
||||
|
|
|
|||
302
R/data_plots.R
302
R/data_plots.R
|
|
@ -4,7 +4,7 @@
|
|||
#'
|
||||
#' @param id Module id. (Use 'ns("id")')
|
||||
#'
|
||||
#' @name data-plots
|
||||
#' @name data-correlations
|
||||
#' @returns Shiny ui module
|
||||
#' @export
|
||||
#'
|
||||
|
|
@ -24,21 +24,12 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
shiny::uiOutput(outputId = ns("primary")),
|
||||
shiny::uiOutput(outputId = ns("type")),
|
||||
shiny::uiOutput(outputId = ns("secondary")),
|
||||
shiny::uiOutput(outputId = ns("tertiary")),
|
||||
shiny::br(),
|
||||
shiny::actionButton(
|
||||
inputId = ns("act_plot"),
|
||||
label = "Plot",
|
||||
width = "100%",
|
||||
icon = shiny::icon("palette"),
|
||||
disabled = FALSE
|
||||
),
|
||||
shiny::helpText('Adjust settings, then press "Plot".')
|
||||
shiny::uiOutput(outputId = ns("tertiary"))
|
||||
),
|
||||
bslib::accordion_panel(
|
||||
title = "Advanced",
|
||||
icon = bsicons::bs_icon("gear")
|
||||
),
|
||||
# bslib::accordion_panel(
|
||||
# title = "Advanced",
|
||||
# icon = bsicons::bs_icon("gear")
|
||||
# ),
|
||||
bslib::accordion_panel(
|
||||
title = "Download",
|
||||
icon = bsicons::bs_icon("download"),
|
||||
|
|
@ -96,7 +87,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
|
|||
#' @param data data
|
||||
#' @param ... ignored
|
||||
#'
|
||||
#' @name data-plots
|
||||
#' @name data-correlations
|
||||
#' @returns shiny server module
|
||||
#' @export
|
||||
data_visuals_server <- function(id,
|
||||
|
|
@ -139,14 +130,14 @@ data_visuals_server <- function(id,
|
|||
|
||||
plots_named <- get_plot_options(plots) |>
|
||||
lapply(\(.x){
|
||||
stats::setNames(.x$descr, .x$note)
|
||||
stats::setNames(.x$descr,.x$note)
|
||||
})
|
||||
|
||||
vectorSelectInput(
|
||||
inputId = ns("type"),
|
||||
selected = NULL,
|
||||
label = shiny::h4("Plot type"),
|
||||
choices = Reduce(c, plots_named),
|
||||
choices = Reduce(c,plots_named),
|
||||
multiple = FALSE
|
||||
)
|
||||
})
|
||||
|
|
@ -157,6 +148,7 @@ data_visuals_server <- function(id,
|
|||
|
||||
output$secondary <- shiny::renderUI({
|
||||
shiny::req(input$type)
|
||||
# browser()
|
||||
|
||||
cols <- c(
|
||||
rv$plot.params()[["secondary.extra"]],
|
||||
|
|
@ -172,9 +164,9 @@ data_visuals_server <- function(id,
|
|||
columnSelectInput(
|
||||
inputId = ns("secondary"),
|
||||
data = data,
|
||||
selected = cols[1],
|
||||
placeholder = "Please select",
|
||||
label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable",
|
||||
selected = 1,
|
||||
placeholder = "Select variable",
|
||||
label = "Secondary/group variable",
|
||||
multiple = rv$plot.params()[["secondary.multi"]],
|
||||
maxItems = rv$plot.params()[["secondary.max"]],
|
||||
col_subset = cols,
|
||||
|
|
@ -187,8 +179,8 @@ data_visuals_server <- function(id,
|
|||
columnSelectInput(
|
||||
inputId = ns("tertiary"),
|
||||
data = data,
|
||||
placeholder = "Please select",
|
||||
label = "Grouping variable",
|
||||
placeholder = "Select variable",
|
||||
label = "Strata variable",
|
||||
multiple = FALSE,
|
||||
col_subset = c(
|
||||
"none",
|
||||
|
|
@ -205,32 +197,25 @@ data_visuals_server <- function(id,
|
|||
)
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$act_plot,
|
||||
{
|
||||
tryCatch(
|
||||
{
|
||||
rv$plot <- create_plot(
|
||||
data = data(),
|
||||
type = rv$plot.params()[["fun"]],
|
||||
x = input$primary,
|
||||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
)
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
},
|
||||
ignoreInit = TRUE
|
||||
)
|
||||
rv$plot <- shiny::reactive({
|
||||
shiny::req(input$primary)
|
||||
shiny::req(input$type)
|
||||
shiny::req(input$secondary)
|
||||
shiny::req(input$tertiary)
|
||||
# if (length(input$secondary)>1){
|
||||
# browser()
|
||||
# }
|
||||
create_plot(
|
||||
data = data(),
|
||||
type = rv$plot.params()[["fun"]],
|
||||
x = input$primary,
|
||||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
)
|
||||
})
|
||||
|
||||
output$plot <- shiny::renderPlot({
|
||||
shiny::req(rv$plot)
|
||||
rv$plot
|
||||
rv$plot()
|
||||
})
|
||||
|
||||
output$download_plot <- shiny::downloadHandler(
|
||||
|
|
@ -241,7 +226,7 @@ data_visuals_server <- function(id,
|
|||
shiny::withProgress(message = "Drawing the plot. Hold on for a moment..", {
|
||||
ggplot2::ggsave(
|
||||
filename = file,
|
||||
plot = rv$plot,
|
||||
plot = rv$plot(),
|
||||
width = input$width,
|
||||
height = input$height,
|
||||
dpi = 300,
|
||||
|
|
@ -260,6 +245,7 @@ data_visuals_server <- function(id,
|
|||
}
|
||||
|
||||
|
||||
|
||||
#' Select all from vector but
|
||||
#'
|
||||
#' @param data vector
|
||||
|
|
@ -378,6 +364,36 @@ supported_plots <- function() {
|
|||
)
|
||||
}
|
||||
|
||||
#' Plot nice ridge plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_ridge(x = "mpg", y = "cyl")
|
||||
#' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_ridge <- function(data, x, y, z = NULL, ...) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) +
|
||||
ggridges::geom_density_ridges() +
|
||||
ggridges::theme_ridges() +
|
||||
ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa()
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
||||
|
||||
#' Get possible regression models
|
||||
#'
|
||||
#' @param data data
|
||||
|
|
@ -478,6 +494,104 @@ create_plot <- function(data, type, x, y, z = NULL, ...) {
|
|||
)
|
||||
}
|
||||
|
||||
|
||||
#' Nice horizontal stacked bars (Grotta bars)
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
#' mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
plot_hbars <- function(data, x, y, z = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Vertical stacked bar plot wrapper
|
||||
#'
|
||||
#' @param data data.frame
|
||||
#' @param score outcome variable
|
||||
#' @param group grouping variable
|
||||
#' @param strata stratifying variable
|
||||
#' @param t.size text size
|
||||
#'
|
||||
#' @return ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
vertical_stacked_bars <- function(data,
|
||||
score = "full_score",
|
||||
group = "pase_0_q",
|
||||
strata = NULL,
|
||||
t.size = 10,
|
||||
l.color = "black",
|
||||
l.size = .5,
|
||||
draw.lines = TRUE) {
|
||||
if (is.null(group)) {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
dplyr::mutate("All" = 1) |>
|
||||
table()
|
||||
group <- "All"
|
||||
draw.lines <- FALSE
|
||||
} else {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
table()
|
||||
}
|
||||
|
||||
p <- df.table |>
|
||||
rankinPlot::grottaBar(
|
||||
scoreName = score,
|
||||
groupName = group,
|
||||
textColor = c("black", "white"),
|
||||
strataName = strata,
|
||||
textCut = 6,
|
||||
textSize = 20,
|
||||
printNumbers = "none",
|
||||
lineSize = l.size,
|
||||
returnData = TRUE
|
||||
)
|
||||
|
||||
colors <- viridisLite::viridis(nrow(df.table))
|
||||
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"))
|
||||
|
||||
|
||||
p |>
|
||||
(\(.x){
|
||||
.x$plot +
|
||||
ggplot2::geom_text(
|
||||
data = .x$rectData[which(.x$rectData$n >
|
||||
0), ],
|
||||
size = t.size,
|
||||
fontface = "plain",
|
||||
ggplot2::aes(
|
||||
x = group,
|
||||
y = p_prev + 0.49 * p,
|
||||
color = as.numeric(score) > contrast_cut,
|
||||
# label = paste0(sprintf("%2.0f", 100 * p),"%"),
|
||||
label = sprintf("%2.0f", 100 * p)
|
||||
)
|
||||
) +
|
||||
ggplot2::labs(fill = score_label) +
|
||||
ggplot2::scale_fill_manual(values = rev(colors)) +
|
||||
ggplot2::theme(
|
||||
legend.position = "bottom",
|
||||
axis.title = ggplot2::element_text(),
|
||||
) +
|
||||
ggplot2::xlab(group_label) +
|
||||
ggplot2::ylab(NULL)
|
||||
# viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D")
|
||||
})()
|
||||
}
|
||||
|
||||
|
||||
#' Print label, and if missing print variable name
|
||||
#'
|
||||
#' @param data vector or data frame
|
||||
|
|
@ -512,6 +626,62 @@ get_label <- function(data, var = NULL) {
|
|||
}
|
||||
|
||||
|
||||
#' Beatiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_violin <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
rempsyc::nice_violin(
|
||||
data = .ds,
|
||||
group = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
||||
|
||||
#' Beautiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
plot_scatter <- function(data, x, y, z = NULL) {
|
||||
if (is.null(z)) {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
} else {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = y,
|
||||
response = x,
|
||||
group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Line breaking at given number of characters for nicely plotting labels
|
||||
#'
|
||||
#' @param data string
|
||||
|
|
@ -535,39 +705,3 @@ line_break <- function(data, lineLength = 20, fixed = FALSE) {
|
|||
}
|
||||
|
||||
|
||||
wrap_plot_list <- function(data) {
|
||||
if (length(data) > 1) {
|
||||
out <- data |>
|
||||
allign_axes() |>
|
||||
patchwork::wrap_plots(guides = "collect", axes = "collect", axis_titles = "collect")
|
||||
} else {
|
||||
out <- data
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
allign_axes <- function(...) {
|
||||
# https://stackoverflow.com/questions/62818776/get-axis-limits-from-ggplot-object
|
||||
# https://github.com/thomasp85/patchwork/blob/main/R/plot_multipage.R#L150
|
||||
if (ggplot2::is.ggplot(..1)) {
|
||||
p <- list(...)
|
||||
} else if (is.list(..1)) {
|
||||
p <- ..1
|
||||
} else {
|
||||
cli::cli_abort("Can only align {.cls ggplot} objects or a list of them")
|
||||
}
|
||||
|
||||
# browser()
|
||||
yr <- purrr::map(p, ~ ggplot2::layer_scales(.x)$y$get_limits()) |>
|
||||
unlist() |>
|
||||
range() |>
|
||||
unique()
|
||||
|
||||
xr <- purrr::map(p, ~ ggplot2::layer_scales(.x)$x$get_limits()) |>
|
||||
unlist() |>
|
||||
range() |>
|
||||
unique()
|
||||
|
||||
p |> purrr::map(~ .x + ggplot2::xlim(xr) + ggplot2::ylim(yr))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
|
||||
#' @title Import data from a file
|
||||
#'
|
||||
#' @description Let user upload a file and import data
|
||||
|
|
@ -10,20 +11,26 @@
|
|||
#'
|
||||
#' @name import-file
|
||||
#'
|
||||
#' @importFrom shiny NS fileInput actionButton icon
|
||||
#' @importFrom htmltools tags tagAppendAttributes css tagAppendChild
|
||||
#' @importFrom shinyWidgets pickerInput numericInputIcon textInputIcon dropMenu
|
||||
#' @importFrom phosphoricons ph
|
||||
#' @importFrom toastui datagridOutput2
|
||||
#'
|
||||
import_file_ui <- function(id,
|
||||
title = "",
|
||||
title = TRUE,
|
||||
preview_data = TRUE,
|
||||
file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat", ".sav"),
|
||||
layout_params = c("dropdown", "inline")) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
ns <- NS(id)
|
||||
|
||||
if (!is.null(layout_params)) {
|
||||
layout_params <- match.arg(layout_params)
|
||||
}
|
||||
|
||||
if (isTRUE(title)) {
|
||||
title <- shiny::tags$h4(
|
||||
title <- tags$h4(
|
||||
datamods:::i18n("Import a file"),
|
||||
class = "datamods-title"
|
||||
)
|
||||
|
|
@ -51,7 +58,7 @@ import_file_ui <- function(id,
|
|||
size = "sm",
|
||||
width = "100%"
|
||||
),
|
||||
shiny::helpText(phosphoricons::ph("info"), datamods:::i18n("if several use a comma (',') to separate them"))
|
||||
shiny::helpText(ph("info"), datamods:::i18n("if several use a comma (',') to separate them"))
|
||||
)
|
||||
),
|
||||
shiny::column(
|
||||
|
|
@ -67,10 +74,8 @@ import_file_ui <- function(id,
|
|||
selectInputIcon(
|
||||
inputId = ns("encoding"),
|
||||
label = datamods:::i18n("Encoding:"),
|
||||
choices = c(
|
||||
"UTF-8" = "UTF-8",
|
||||
"Latin1" = "latin1"
|
||||
),
|
||||
choices = c("UTF-8"="UTF-8",
|
||||
"Latin1"="latin1"),
|
||||
icon = phosphoricons::ph("text-aa"),
|
||||
size = "sm",
|
||||
width = "100%"
|
||||
|
|
@ -108,7 +113,7 @@ import_file_ui <- function(id,
|
|||
shinyWidgets::dropMenu(
|
||||
shiny::actionButton(
|
||||
inputId = ns("dropdown_params"),
|
||||
label = phosphoricons::ph("gear", title = "Parameters"),
|
||||
label = ph("gear", title = "Parameters"),
|
||||
width = "50px",
|
||||
class = "px-1"
|
||||
),
|
||||
|
|
@ -117,24 +122,23 @@ import_file_ui <- function(id,
|
|||
)
|
||||
)
|
||||
}
|
||||
shiny::tags$div(
|
||||
tags$div(
|
||||
class = "datamods-import",
|
||||
datamods:::html_dependency_datamods(),
|
||||
title,
|
||||
file_ui,
|
||||
if (identical(layout_params, "inline")) params_ui,
|
||||
shiny::tags$div(
|
||||
tags$div(
|
||||
class = "hidden",
|
||||
id = ns("sheet-container"),
|
||||
shinyWidgets::pickerInput(
|
||||
inputId = ns("sheet"),
|
||||
label = datamods:::i18n("Select sheet to import:"),
|
||||
choices = NULL,
|
||||
width = "100%",
|
||||
multiple = TRUE
|
||||
width = "100%"
|
||||
)
|
||||
),
|
||||
shiny::tags$div(
|
||||
tags$div(
|
||||
id = ns("import-placeholder"),
|
||||
shinyWidgets::alert(
|
||||
id = ns("import-result"),
|
||||
|
|
@ -145,20 +149,19 @@ import_file_ui <- function(id,
|
|||
)
|
||||
),
|
||||
if (isTRUE(preview_data)) {
|
||||
toastui::datagridOutput2(outputId = ns("table"))
|
||||
}
|
||||
,
|
||||
shiny::uiOutput(
|
||||
toastui::datagridOutput2(outputId = ns("table"))
|
||||
},
|
||||
uiOutput(
|
||||
outputId = ns("container_confirm_btn"),
|
||||
style = "margin-top: 20px;"
|
||||
) ,
|
||||
),
|
||||
tags$div(
|
||||
style = htmltools::css(display = "none"),
|
||||
shiny::checkboxInput(
|
||||
inputId = ns("preview_data"),
|
||||
label = NULL,
|
||||
value = isTRUE(preview_data)
|
||||
)
|
||||
shiny::checkboxInput(
|
||||
inputId = ns("preview_data"),
|
||||
label = NULL,
|
||||
value = isTRUE(preview_data)
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
|
|
@ -177,6 +180,16 @@ import_file_ui <- function(id,
|
|||
#'
|
||||
#' @export
|
||||
#'
|
||||
#' @importFrom shiny moduleServer
|
||||
#' @importFrom htmltools tags tagList
|
||||
#' @importFrom shiny reactiveValues reactive observeEvent removeUI req
|
||||
#' @importFrom shinyWidgets updatePickerInput
|
||||
#' @importFrom readxl excel_sheets
|
||||
#' @importFrom rio import
|
||||
#' @importFrom rlang exec fn_fmls_names is_named is_function
|
||||
#' @importFrom tools file_ext
|
||||
#' @importFrom utils head
|
||||
#' @importFrom toastui renderDatagrid2 datagrid
|
||||
#'
|
||||
#' @rdname import-file
|
||||
import_file_server <- function(id,
|
||||
|
|
@ -186,49 +199,48 @@ import_file_server <- function(id,
|
|||
return_class = c("data.frame", "data.table", "tbl_df", "raw"),
|
||||
reset = reactive(NULL),
|
||||
read_fns = list()) {
|
||||
|
||||
if (length(read_fns) > 0) {
|
||||
if (!rlang::is_named(read_fns)) {
|
||||
if (!is_named(read_fns))
|
||||
stop("import_file_server: `read_fns` must be a named list.", call. = FALSE)
|
||||
}
|
||||
if (!all(vapply(read_fns, rlang::is_function, logical(1)))) {
|
||||
if (!all(vapply(read_fns, is_function, logical(1))))
|
||||
stop("import_file_server: `read_fns` must be list of function(s).", call. = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
trigger_return <- match.arg(trigger_return)
|
||||
return_class <- match.arg(return_class)
|
||||
|
||||
module <- function(input, output, session) {
|
||||
ns <- session$ns
|
||||
imported_rv <- shiny::reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- shiny::reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
|
||||
shiny::observeEvent(reset(), {
|
||||
ns <- session$ns
|
||||
imported_rv <- reactiveValues(data = NULL, name = NULL)
|
||||
temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL)
|
||||
|
||||
observeEvent(reset(), {
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$status <- NULL
|
||||
})
|
||||
|
||||
output$container_confirm_btn <- shiny::renderUI({
|
||||
output$container_confirm_btn <- renderUI({
|
||||
if (identical(trigger_return, "button")) {
|
||||
datamods:::button_import()
|
||||
}
|
||||
})
|
||||
|
||||
shiny::observeEvent(input$file, {
|
||||
if (isTRUE(is_workbook(input$file$datapath))) {
|
||||
if (isTRUE(is_excel(input$file$datapath))) {
|
||||
choices <- readxl::excel_sheets(input$file$datapath)
|
||||
} else if (isTRUE(is_ods(input$file$datapath))) {
|
||||
choices <- readODS::ods_sheets(input$file$datapath)
|
||||
}
|
||||
selected <- choices[1]
|
||||
|
||||
observeEvent(input$file, {
|
||||
if (isTRUE(is_excel(input$file$datapath))) {
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = "sheet",
|
||||
choices = choices,
|
||||
selected = selected
|
||||
choices = readxl::excel_sheets(input$file$datapath)
|
||||
)
|
||||
datamods:::showUI(paste0("#", ns("sheet-container")))
|
||||
} else if (isTRUE(is_ods(input$file$datapath))) {
|
||||
shinyWidgets::updatePickerInput(
|
||||
session = session,
|
||||
inputId = "sheet",
|
||||
choices = readODS::ods_sheets(input$file$datapath)
|
||||
)
|
||||
datamods:::showUI(paste0("#", ns("sheet-container")))
|
||||
} else {
|
||||
|
|
@ -236,24 +248,18 @@ import_file_server <- function(id,
|
|||
}
|
||||
})
|
||||
|
||||
observeEvent(
|
||||
list(
|
||||
input$file,
|
||||
input$sheet,
|
||||
input$skip_rows,
|
||||
input$dec,
|
||||
input$encoding,
|
||||
input$na_label
|
||||
),
|
||||
{
|
||||
req(input$file)
|
||||
if (is_workbook(input$file$datapath)) shiny::req(input$sheet)
|
||||
# browser()
|
||||
|
||||
# browser()
|
||||
# req(input$skip_rows)
|
||||
extension <- tools::file_ext(input$file$datapath)
|
||||
|
||||
observeEvent(list(
|
||||
input$file,
|
||||
input$sheet,
|
||||
input$skip_rows,
|
||||
input$dec,
|
||||
input$encoding,
|
||||
input$na_label
|
||||
), {
|
||||
req(input$file)
|
||||
# req(input$skip_rows)
|
||||
extension <- tools::file_ext(input$file$datapath)
|
||||
if (isTRUE(extension %in% names(read_fns))) {
|
||||
parameters <- list(
|
||||
file = input$file$datapath,
|
||||
sheet = input$sheet,
|
||||
|
|
@ -264,41 +270,69 @@ import_file_server <- function(id,
|
|||
)
|
||||
parameters <- parameters[which(names(parameters) %in% rlang::fn_fmls_names(read_fns[[extension]]))]
|
||||
imported <- try(rlang::exec(read_fns[[extension]], !!!parameters), silent = TRUE)
|
||||
code <- rlang::call2(read_fns[[extension]], !!!modifyList(parameters, list(file = input$file$name)))
|
||||
|
||||
if (inherits(imported, "try-error")) {
|
||||
imported <- try(rlang::exec(rio::import, !!!parameters[1]), silent = TRUE)
|
||||
code <- rlang::call2("import", !!!list(file = input$file$name), .ns = "rio")
|
||||
}
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_error(mssg = datamods:::i18n(attr(imported, "condition")$message))
|
||||
temporary_rv$status <- "error"
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$code <- NULL
|
||||
} else {
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = TRUE)
|
||||
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "success",
|
||||
datamods:::make_success_alert(
|
||||
imported,
|
||||
trigger_return = trigger_return,
|
||||
btn_show_data = btn_show_data,
|
||||
extra = if (isTRUE(input$preview_data)) datamods:::i18n("First five rows are shown below:")
|
||||
)
|
||||
code <- call2(read_fns[[extension]], !!!modifyList(parameters, list(file = input$file$name)))
|
||||
} else {
|
||||
if (is_excel(input$file$datapath) || is_ods(input$file$datapath)) {
|
||||
req(input$sheet)
|
||||
parameters <- list(
|
||||
file = input$file$datapath,
|
||||
which = input$sheet,
|
||||
skip = input$skip_rows,
|
||||
na = datamods:::split_char(input$na_label)
|
||||
)
|
||||
} else if (is_sas(input$file$datapath)) {
|
||||
parameters <- list(
|
||||
file = input$file$datapath,
|
||||
skip = input$skip_rows,
|
||||
encoding = input$encoding
|
||||
)
|
||||
} else {
|
||||
parameters <- list(
|
||||
file = input$file$datapath,
|
||||
skip = input$skip_rows,
|
||||
dec = input$dec,
|
||||
encoding = input$encoding,
|
||||
na.strings = datamods:::split_char(input$na_label)
|
||||
)
|
||||
temporary_rv$status <- "success"
|
||||
temporary_rv$data <- imported
|
||||
temporary_rv$name <- input$file$name
|
||||
temporary_rv$code <- code
|
||||
}
|
||||
},
|
||||
ignoreInit = TRUE
|
||||
)
|
||||
imported <- try(rlang::exec(rio::import, !!!parameters), silent = TRUE)
|
||||
code <- rlang::call2("import", !!!utils::modifyList(parameters, list(file = input$file$name)), .ns = "rio")
|
||||
}
|
||||
|
||||
if (inherits(imported, "try-error")) {
|
||||
imported <- try(rlang::exec(rio::import, !!!parameters[1]), silent = TRUE)
|
||||
code <- rlang::call2("import", !!!list(file = input$file$name), .ns = "rio")
|
||||
}
|
||||
|
||||
if (inherits(imported, "try-error") || NROW(imported) < 1) {
|
||||
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = FALSE)
|
||||
datamods:::insert_error(mssg = datamods:::i18n(attr(imported, "condition")$message))
|
||||
temporary_rv$status <- "error"
|
||||
temporary_rv$data <- NULL
|
||||
temporary_rv$name <- NULL
|
||||
temporary_rv$code <- NULL
|
||||
|
||||
} else {
|
||||
|
||||
datamods:::toggle_widget(inputId = "confirm", enable = TRUE)
|
||||
|
||||
datamods:::insert_alert(
|
||||
selector = ns("import"),
|
||||
status = "success",
|
||||
datamods:::make_success_alert(
|
||||
imported,
|
||||
trigger_return = trigger_return,
|
||||
btn_show_data = btn_show_data,
|
||||
extra = if (isTRUE(input$preview_data)) datamods:::i18n("First five rows are shown below:")
|
||||
)
|
||||
)
|
||||
temporary_rv$status <- "success"
|
||||
temporary_rv$data <- imported
|
||||
temporary_rv$name <- input$file$name
|
||||
temporary_rv$code <- code
|
||||
}
|
||||
}, ignoreInit = TRUE)
|
||||
|
||||
observeEvent(input$see_data, {
|
||||
datamods:::show_data(temporary_rv$data, title = datamods:::i18n("Imported data"), type = show_data_in)
|
||||
|
|
@ -357,10 +391,6 @@ is_sas <- function(path) {
|
|||
isTRUE(tools::file_ext(path) %in% c("sas7bdat"))
|
||||
}
|
||||
|
||||
is_workbook <- function(path) {
|
||||
is_excel(path) || is_ods(path)
|
||||
}
|
||||
|
||||
#' Wrapper of data.table::fread to import delim files with few presets
|
||||
#'
|
||||
#' @param file file
|
||||
|
|
@ -375,7 +405,7 @@ import_delim <- function(file, skip, encoding, na.strings) {
|
|||
file = file,
|
||||
na.strings = na.strings,
|
||||
skip = skip,
|
||||
check.names = TRUE,
|
||||
check.names = TRUE,
|
||||
encoding = encoding,
|
||||
data.table = FALSE,
|
||||
logical01 = TRUE,
|
||||
|
|
@ -384,54 +414,6 @@ import_delim <- function(file, skip, encoding, na.strings) {
|
|||
)
|
||||
}
|
||||
|
||||
import_xls <- function(file, sheet, skip, na.strings) {
|
||||
tryCatch(
|
||||
{
|
||||
# browser()
|
||||
sheet |>
|
||||
purrr::map(\(.x){
|
||||
openxlsx2::read_xlsx(
|
||||
file = file,
|
||||
sheet = .x,
|
||||
skip_empty_rows = TRUE,
|
||||
start_row = skip - 1,
|
||||
na.strings = na.strings
|
||||
)
|
||||
}) |>
|
||||
purrr::reduce(dplyr::full_join)
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
import_ods <- function(file, sheet, skip, na.strings) {
|
||||
tryCatch(
|
||||
{
|
||||
sheet |>
|
||||
purrr::map(\(.x){
|
||||
readODS::read_ods(
|
||||
path = file,
|
||||
sheet = .x,
|
||||
skip = skip,
|
||||
na = na.strings
|
||||
)
|
||||
}) |>
|
||||
purrr::reduce(dplyr::full_join)
|
||||
},
|
||||
warning = function(warn) {
|
||||
showNotification(paste0(warn), type = "warning")
|
||||
},
|
||||
error = function(err) {
|
||||
showNotification(paste0(err), type = "err")
|
||||
}
|
||||
)
|
||||
}
|
||||
|
||||
#' @title Create a select input control with icon(s)
|
||||
#'
|
||||
#' @description Extend form controls by adding text or icons before,
|
||||
|
|
@ -455,11 +437,11 @@ selectInputIcon <- function(inputId,
|
|||
width = NULL,
|
||||
icon = NULL) {
|
||||
selected <- shiny::restoreInput(id = inputId, default = selected)
|
||||
shiny::tags$div(
|
||||
tags$div(
|
||||
class = "form-group shiny-input-container",
|
||||
shinyWidgets:::label_input(inputId, label),
|
||||
style = htmltools:::css(width = htmltools:::validateCssUnit(width)),
|
||||
shiny::tags$div(
|
||||
tags$div(
|
||||
class = "input-group",
|
||||
class = shinyWidgets:::validate_size(size),
|
||||
shinyWidgets:::markup_input_group(icon, "left", theme_func = shiny::getCurrentTheme),
|
||||
|
|
@ -475,89 +457,71 @@ selectInputIcon <- function(inputId,
|
|||
}
|
||||
|
||||
|
||||
#' Test app for the import_file module
|
||||
#'
|
||||
#' @rdname import-file_module
|
||||
#'
|
||||
#' @examples
|
||||
#' \dontrun{
|
||||
#' import_file_demo_app()
|
||||
#' }
|
||||
import_file_demo_app <- function() {
|
||||
ui <- shiny::fluidPage(
|
||||
# theme = bslib::bs_theme(version = 5L),
|
||||
# theme = bslib::bs_theme(version = 5L, preset = "bootstrap"),
|
||||
shiny::tags$h3("Import data from a file"),
|
||||
shiny::fluidRow(
|
||||
shiny::column(
|
||||
width = 4,
|
||||
import_file_ui(
|
||||
id = "myid",
|
||||
file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".sas7bdat", ".ods", ".dta"),
|
||||
layout_params = "dropdown" # "inline" # or "dropdown"
|
||||
)
|
||||
),
|
||||
shiny::column(
|
||||
width = 8,
|
||||
shiny::tags$b("Import status:"),
|
||||
shiny::verbatimTextOutput(outputId = "status"),
|
||||
shiny::tags$b("Name:"),
|
||||
shiny::verbatimTextOutput(outputId = "name"),
|
||||
shiny::tags$b("Code:"),
|
||||
shiny::verbatimTextOutput(outputId = "code"),
|
||||
shiny::tags$b("Data:"),
|
||||
shiny::verbatimTextOutput(outputId = "data")
|
||||
|
||||
|
||||
|
||||
# library(shiny)
|
||||
# library(datamods)
|
||||
|
||||
ui <- fluidPage(
|
||||
# theme = bslib::bs_theme(version = 5L),
|
||||
# theme = bslib::bs_theme(version = 5L, preset = "bootstrap"),
|
||||
tags$h3("Import data from a file"),
|
||||
fluidRow(
|
||||
column(
|
||||
width = 4,
|
||||
import_file_ui(
|
||||
id = "myid",
|
||||
file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".json"),
|
||||
layout_params = "dropdown" #"inline" # or "dropdown"
|
||||
)
|
||||
),
|
||||
column(
|
||||
width = 8,
|
||||
tags$b("Import status:"),
|
||||
verbatimTextOutput(outputId = "status"),
|
||||
tags$b("Name:"),
|
||||
verbatimTextOutput(outputId = "name"),
|
||||
tags$b("Code:"),
|
||||
verbatimTextOutput(outputId = "code"),
|
||||
tags$b("Data:"),
|
||||
verbatimTextOutput(outputId = "data")
|
||||
)
|
||||
)
|
||||
server <- function(input, output, session) {
|
||||
imported <- import_file_server(
|
||||
id = "myid",
|
||||
show_data_in = "popup",
|
||||
trigger_return = "change",
|
||||
return_class = "data.frame",
|
||||
# Custom functions to read data
|
||||
read_fns = list(
|
||||
ods = import_ods,
|
||||
dta = function(file) {
|
||||
haven::read_dta(
|
||||
file = file,
|
||||
.name_repair = "unique_quiet"
|
||||
)
|
||||
},
|
||||
# csv = function(file) {
|
||||
# readr::read_csv(
|
||||
# file = file,
|
||||
# na = consider.na,
|
||||
# name_repair = "unique_quiet"
|
||||
# )
|
||||
# },
|
||||
csv = import_delim,
|
||||
tsv = import_delim,
|
||||
txt = import_delim,
|
||||
xls = import_xls,
|
||||
xlsx = import_xls,
|
||||
rds = function(file) {
|
||||
readr::read_rds(
|
||||
file = file,
|
||||
name_repair = "unique_quiet"
|
||||
)
|
||||
}
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
server <- function(input, output, session) {
|
||||
|
||||
imported <- import_file_server(
|
||||
id = "myid",
|
||||
# Custom functions to read data
|
||||
read_fns = list(
|
||||
xls = function(file, sheet, skip, encoding) {
|
||||
readxl::read_xls(path = file, sheet = sheet, skip = skip)
|
||||
},
|
||||
json = function(file) {
|
||||
jsonlite::read_json(file, simplifyVector = TRUE)
|
||||
}
|
||||
),
|
||||
show_data_in = "modal"
|
||||
)
|
||||
|
||||
output$status <- renderPrint({
|
||||
imported$status()
|
||||
})
|
||||
output$name <- renderPrint({
|
||||
imported$name()
|
||||
})
|
||||
output$code <- renderPrint({
|
||||
imported$code()
|
||||
})
|
||||
output$data <- renderPrint({
|
||||
imported$data()
|
||||
})
|
||||
|
||||
output$status <- shiny::renderPrint({
|
||||
imported$status()
|
||||
})
|
||||
output$name <- shiny::renderPrint({
|
||||
imported$name()
|
||||
})
|
||||
output$code <- shiny::renderPrint({
|
||||
imported$code()
|
||||
})
|
||||
output$data <- shiny::renderPrint({
|
||||
imported$data()
|
||||
})
|
||||
}
|
||||
shiny::shinyApp(ui, server)
|
||||
}
|
||||
|
||||
if (interactive())
|
||||
shinyApp(ui, server)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -93,8 +93,7 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
|
|||
plot_euler_single()
|
||||
})
|
||||
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out, guides = "collect")
|
||||
patchwork::wrap_plots(out, guides = "collect")
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,95 +0,0 @@
|
|||
#' Nice horizontal stacked bars (Grotta bars)
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
#' mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
plot_hbars <- function(data, x, y, z = NULL) {
|
||||
out <- vertical_stacked_bars(data = data, score = x, group = y, strata = z)
|
||||
|
||||
out
|
||||
}
|
||||
|
||||
|
||||
#' Vertical stacked bar plot wrapper
|
||||
#'
|
||||
#' @param data data.frame
|
||||
#' @param score outcome variable
|
||||
#' @param group grouping variable
|
||||
#' @param strata stratifying variable
|
||||
#' @param t.size text size
|
||||
#'
|
||||
#' @return ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
vertical_stacked_bars <- function(data,
|
||||
score = "full_score",
|
||||
group = "pase_0_q",
|
||||
strata = NULL,
|
||||
t.size = 10,
|
||||
l.color = "black",
|
||||
l.size = .5,
|
||||
draw.lines = TRUE) {
|
||||
if (is.null(group)) {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
dplyr::mutate("All" = 1) |>
|
||||
table()
|
||||
group <- "All"
|
||||
draw.lines <- FALSE
|
||||
} else {
|
||||
df.table <- data[c(score, group, strata)] |>
|
||||
table()
|
||||
}
|
||||
|
||||
p <- df.table |>
|
||||
rankinPlot::grottaBar(
|
||||
scoreName = score,
|
||||
groupName = group,
|
||||
textColor = c("black", "white"),
|
||||
strataName = strata,
|
||||
textCut = 6,
|
||||
textSize = 20,
|
||||
printNumbers = "none",
|
||||
lineSize = l.size,
|
||||
returnData = TRUE
|
||||
)
|
||||
|
||||
colors <- viridisLite::viridis(nrow(df.table))
|
||||
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"))
|
||||
|
||||
|
||||
p |>
|
||||
(\(.x){
|
||||
.x$plot +
|
||||
ggplot2::geom_text(
|
||||
data = .x$rectData[which(.x$rectData$n >
|
||||
0), ],
|
||||
size = t.size,
|
||||
fontface = "plain",
|
||||
ggplot2::aes(
|
||||
x = group,
|
||||
y = p_prev + 0.49 * p,
|
||||
color = as.numeric(score) > contrast_cut,
|
||||
# label = paste0(sprintf("%2.0f", 100 * p),"%"),
|
||||
label = sprintf("%2.0f", 100 * p)
|
||||
)
|
||||
) +
|
||||
ggplot2::labs(fill = score_label) +
|
||||
ggplot2::scale_fill_manual(values = rev(colors)) +
|
||||
ggplot2::theme(
|
||||
legend.position = "bottom",
|
||||
axis.title = ggplot2::element_text(),
|
||||
) +
|
||||
ggplot2::xlab(group_label) +
|
||||
ggplot2::ylab(NULL)
|
||||
# viridis::scale_fill_viridis(discrete = TRUE, direction = -1, option = "D")
|
||||
})()
|
||||
}
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
#' Plot nice ridge plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |>
|
||||
#' default_parsing() |>
|
||||
#' plot_ridge(x = "mpg", y = "cyl")
|
||||
#' mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_ridge <- function(data, x, y, z = NULL, ...) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
ggplot2::ggplot(.ds, ggplot2::aes(x = !!dplyr::sym(x), y = !!dplyr::sym(y), fill = !!dplyr::sym(y))) +
|
||||
ggridges::geom_density_ridges() +
|
||||
ggridges::theme_ridges() +
|
||||
ggplot2::theme(legend.position = "none") |> rempsyc:::theme_apa()
|
||||
})
|
||||
|
||||
patchwork::wrap_plots(out)
|
||||
}
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
#' Beautiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
plot_scatter <- function(data, x, y, z = NULL) {
|
||||
if (is.null(z)) {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
} else {
|
||||
rempsyc::nice_scatter(
|
||||
data = data,
|
||||
predictor = y,
|
||||
response = x,
|
||||
group = z, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
}
|
||||
}
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
#' Beatiful violin plot
|
||||
#'
|
||||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
#' @name data-plots
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
plot_violin <- function(data, x, y, z = NULL) {
|
||||
if (!is.null(z)) {
|
||||
ds <- split(data, data[z])
|
||||
} else {
|
||||
ds <- list(data)
|
||||
}
|
||||
|
||||
out <- lapply(ds, \(.ds){
|
||||
rempsyc::nice_violin(
|
||||
data = .ds,
|
||||
group = y,
|
||||
response = x, xtitle = get_label(data, var = y), ytitle = get_label(data, var = x)
|
||||
)
|
||||
})
|
||||
|
||||
wrap_plot_list(out)
|
||||
# patchwork::wrap_plots(out,guides = "collect")
|
||||
}
|
||||
|
|
@ -7,16 +7,9 @@
|
|||
#'
|
||||
#' @return shiny ui element
|
||||
#' @export
|
||||
m_redcap_readUI <- function(id, title = TRUE) {
|
||||
m_redcap_readUI <- function(id, include_title = TRUE) {
|
||||
ns <- shiny::NS(id)
|
||||
|
||||
if (isTRUE(title)) {
|
||||
title <- shiny::tags$h4(
|
||||
"Import data from REDCap",
|
||||
class = "redcap-module-title"
|
||||
)
|
||||
}
|
||||
|
||||
server_ui <- shiny::tagList(
|
||||
# width = 6,
|
||||
shiny::tags$h4("REDCap server"),
|
||||
|
|
@ -82,7 +75,7 @@ m_redcap_readUI <- function(id, title = TRUE) {
|
|||
|
||||
|
||||
shiny::fluidPage(
|
||||
title=title,
|
||||
if (include_title) shiny::tags$h3("Import data from REDCap"),
|
||||
bslib::layout_columns(
|
||||
server_ui,
|
||||
params_ui,
|
||||
|
|
@ -147,13 +140,7 @@ m_redcap_readServer <- function(id) {
|
|||
)
|
||||
|
||||
shiny::observeEvent(list(input$api, input$uri), {
|
||||
shiny::req(input$api)
|
||||
shiny::req(input$uri)
|
||||
if (!is.null(input$uri)){
|
||||
uri <- paste0(ifelse(endsWith(input$uri, "/"), input$uri, paste0(input$uri, "/")), "api/")
|
||||
} else {
|
||||
uri <- input$uri
|
||||
}
|
||||
|
||||
if (is_valid_redcap_url(uri) & is_valid_token(input$api)) {
|
||||
data_rv$uri <- uri
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ library(rlang)
|
|||
#'
|
||||
#' @name update-variables
|
||||
#'
|
||||
update_variables_ui <- function(id, title = "") {
|
||||
update_variables_ui <- function(id, title = TRUE) {
|
||||
ns <- NS(id)
|
||||
if (isTRUE(title)) {
|
||||
title <- htmltools::tags$h4(
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -5,6 +5,6 @@ account: agdamsbo
|
|||
server: shinyapps.io
|
||||
hostUrl: https://api.shinyapps.io/v1
|
||||
appId: 13611288
|
||||
bundleId: 9937654
|
||||
bundleId: 9932726
|
||||
url: https://agdamsbo.shinyapps.io/freesearcheR/
|
||||
version: 1
|
||||
|
|
|
|||
|
|
@ -93,13 +93,23 @@ server <- function(input, output, session) {
|
|||
#########
|
||||
##############################################################################
|
||||
|
||||
consider.na <- c("NA", "\"\"", "", "\'\'", "na")
|
||||
|
||||
data_file <- import_file_server(
|
||||
id = "file_import",
|
||||
show_data_in = "popup",
|
||||
trigger_return = "change",
|
||||
return_class = "data.frame",
|
||||
read_fns = list(
|
||||
ods = import_ods,
|
||||
ods = function(file, which, skip, na) {
|
||||
readODS::read_ods(
|
||||
path = file,
|
||||
# Sheet and skip not implemented for .ods in the original implementation
|
||||
sheet = which,
|
||||
skip = skip,
|
||||
na = na
|
||||
)
|
||||
},
|
||||
dta = function(file) {
|
||||
haven::read_dta(
|
||||
file = file,
|
||||
|
|
@ -116,8 +126,24 @@ server <- function(input, output, session) {
|
|||
csv = import_delim,
|
||||
tsv = import_delim,
|
||||
txt = import_delim,
|
||||
xls = import_xls,
|
||||
xlsx = import_xls,
|
||||
xls = function(file, which, skip, na) {
|
||||
openxlsx2::read_xlsx(
|
||||
file = file,
|
||||
sheet = which,
|
||||
skip_empty_rows = TRUE,
|
||||
start_row = skip - 1,
|
||||
na.strings = na
|
||||
)
|
||||
},
|
||||
xlsx = function(file, which, skip, na) {
|
||||
openxlsx2::read_xlsx(
|
||||
file = file,
|
||||
sheet = sheet,
|
||||
skip_empty_rows = TRUE,
|
||||
start_row = skip - 1,
|
||||
na.strings = na
|
||||
)
|
||||
},
|
||||
rds = function(file) {
|
||||
readr::read_rds(
|
||||
file = file,
|
||||
|
|
@ -134,7 +160,8 @@ server <- function(input, output, session) {
|
|||
})
|
||||
|
||||
data_redcap <- m_redcap_readServer(
|
||||
id = "redcap_import"
|
||||
id = "redcap_import" # ,
|
||||
# output.format = "list"
|
||||
)
|
||||
|
||||
shiny::observeEvent(data_redcap(), {
|
||||
|
|
@ -176,7 +203,7 @@ server <- function(input, output, session) {
|
|||
label = "Select variables to include",
|
||||
selected = preselect,
|
||||
choices = names(rv$data_temp),
|
||||
updateOn = "change",
|
||||
updateOn = "close",
|
||||
multiple = TRUE,
|
||||
search = TRUE,
|
||||
showValueAsTags = TRUE
|
||||
|
|
@ -272,7 +299,7 @@ server <- function(input, output, session) {
|
|||
|
||||
shiny::observeEvent(
|
||||
input$modal_variables,
|
||||
modal_update_variables("modal_variables", title = "Update and select variables")
|
||||
modal_update_variables("modal_variables", title = "Modify factor levels")
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -280,7 +307,7 @@ server <- function(input, output, session) {
|
|||
|
||||
shiny::observeEvent(
|
||||
input$modal_cut,
|
||||
modal_cut_variable("modal_cut", title = "Create new factor")
|
||||
modal_cut_variable("modal_cut", title = "Modify factor levels")
|
||||
)
|
||||
|
||||
data_modal_cut <- cut_variable_server(
|
||||
|
|
@ -294,7 +321,7 @@ server <- function(input, output, session) {
|
|||
|
||||
shiny::observeEvent(
|
||||
input$modal_update,
|
||||
datamods::modal_update_factor(id = "modal_update", title = "Reorder factor levels")
|
||||
datamods::modal_update_factor(id = "modal_update")
|
||||
)
|
||||
|
||||
data_modal_update <- datamods::update_factor_server(
|
||||
|
|
@ -311,11 +338,7 @@ server <- function(input, output, session) {
|
|||
|
||||
shiny::observeEvent(
|
||||
input$modal_column,
|
||||
datamods::modal_create_column(
|
||||
id = "modal_column",
|
||||
footer = "This window is aimed at advanced users and require some R-experience!",
|
||||
title = "Create new variables"
|
||||
)
|
||||
datamods::modal_create_column(id = "modal_column", footer = "This is only for advanced users!")
|
||||
)
|
||||
data_modal_r <- datamods::create_column_server(
|
||||
id = "modal_column",
|
||||
|
|
@ -577,8 +600,8 @@ server <- function(input, output, session) {
|
|||
data_filter(),
|
||||
input$strat_var,
|
||||
input$include_vars,
|
||||
input$complete_cutoff,
|
||||
input$add_p
|
||||
input$add_p,
|
||||
input$complete_cutoff
|
||||
),
|
||||
{
|
||||
shiny::req(input$strat_var)
|
||||
|
|
@ -621,14 +644,13 @@ server <- function(input, output, session) {
|
|||
)
|
||||
|
||||
output$outcome_var_cor <- shiny::renderUI({
|
||||
columnSelectInput(
|
||||
shiny::selectInput(
|
||||
inputId = "outcome_var_cor",
|
||||
selected = "none",
|
||||
data = rv$list$data,
|
||||
selected = NULL,
|
||||
label = "Select outcome variable",
|
||||
col_subset = c(
|
||||
"none",
|
||||
choices = c(
|
||||
colnames(rv$list$data)
|
||||
# ,"none"
|
||||
),
|
||||
multiple = FALSE
|
||||
)
|
||||
|
|
@ -646,10 +668,10 @@ server <- function(input, output, session) {
|
|||
id = "correlations",
|
||||
data = shiny::reactive({
|
||||
shiny::req(rv$list$data)
|
||||
out <- rv$list$data
|
||||
if (!is.null(input$outcome_var_cor) && input$outcome_var_cor != "none") {
|
||||
out <- out[!names(out) %in% input$outcome_var_cor]
|
||||
}
|
||||
out <- dplyr::select(rv$list$data, -!!input$outcome_var_cor)
|
||||
# input$outcome_var_cor=="none"){
|
||||
# out <- rv$list$data
|
||||
# }
|
||||
out
|
||||
}),
|
||||
cutoff = shiny::reactive(input$cor_cutoff)
|
||||
|
|
|
|||
|
|
@ -49,16 +49,13 @@ ui_elements <- list(
|
|||
import_file_ui(
|
||||
id = "file_import",
|
||||
layout_params = "dropdown",
|
||||
# title = "Choose a datafile to upload",
|
||||
title = "Choose a datafile to upload",
|
||||
file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".sas7bdat", ".ods", ".dta")
|
||||
)
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='redcap'",
|
||||
m_redcap_readUI(
|
||||
id = "redcap_import",
|
||||
title = ""
|
||||
)
|
||||
m_redcap_readUI("redcap_import")
|
||||
),
|
||||
shiny::conditionalPanel(
|
||||
condition = "input.source=='env'",
|
||||
|
|
@ -172,7 +169,9 @@ ui_elements <- list(
|
|||
fluidRow(
|
||||
shiny::column(
|
||||
width = 9,
|
||||
shiny::tags$p(shiny::markdown("Below, are several options to update variables (rename, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).), modify factor/categorical variables as well as create new factor from a continous variable or new variables with *R* code."))
|
||||
shiny::tags$p(shiny::markdown("Below, you can subset the data (select variables to include on clicking 'Apply changes'), rename variables, set new labels (for nicer tables in the report) and change variable classes (numeric, factor/categorical etc.).
|
||||
Italic text can be edited/changed.
|
||||
On the right, you can create and modify factor/categorical variables as well as create new variables with *R* code."))
|
||||
)
|
||||
),
|
||||
shiny::tags$br(),
|
||||
|
|
@ -186,7 +185,7 @@ ui_elements <- list(
|
|||
fluidRow(
|
||||
shiny::column(
|
||||
width = 6,
|
||||
tags$h4("Update or modify variables"),
|
||||
tags$h4("Update variables"),
|
||||
shiny::tags$br(),
|
||||
shiny::actionButton(
|
||||
inputId = "modal_variables",
|
||||
|
|
@ -213,11 +212,11 @@ ui_elements <- list(
|
|||
shiny::tags$br(),
|
||||
shiny::actionButton(
|
||||
inputId = "modal_cut",
|
||||
label = "New factor",
|
||||
label = "Create factor variable",
|
||||
width = "100%"
|
||||
),
|
||||
shiny::tags$br(),
|
||||
shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time)."),
|
||||
shiny::helpText("Create factor/categorical variable from an other value."),
|
||||
shiny::tags$br(),
|
||||
shiny::tags$br(),
|
||||
shiny::actionButton(
|
||||
|
|
@ -309,9 +308,9 @@ ui_elements <- list(
|
|||
bslib::accordion_panel(
|
||||
vlaue = "acc_cor",
|
||||
title = "Correlations",
|
||||
icon = bsicons::bs_icon("bounding-box"),
|
||||
icon = bsicons::bs_icon("table"),
|
||||
shiny::uiOutput("outcome_var_cor"),
|
||||
shiny::helpText("To avoid evaluating the correlation of the outcome variable, this can be excluded from the plot or select 'none'."),
|
||||
shiny::helpText("This variable will be excluded from the correlation plot."),
|
||||
shiny::br(),
|
||||
shinyWidgets::noUiSliderInput(
|
||||
inputId = "cor_cutoff",
|
||||
|
|
@ -322,8 +321,7 @@ ui_elements <- list(
|
|||
value = .8,
|
||||
format = shinyWidgets::wNumbFormat(decimals = 2),
|
||||
color = datamods:::get_primary_color()
|
||||
),
|
||||
shiny::helpText("Set the cut-off for considered 'highly correlated'.")
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
|
|
|
|||
|
|
@ -1,19 +1,25 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/correlations-module.R
|
||||
% Please edit documentation in R/correlations-module.R, R/data_plots.R
|
||||
\name{data-correlations}
|
||||
\alias{data-correlations}
|
||||
\alias{data_correlations_ui}
|
||||
\alias{data_correlations_server}
|
||||
\alias{data_visuals_ui}
|
||||
\alias{data_visuals_server}
|
||||
\title{Data correlations evaluation module}
|
||||
\usage{
|
||||
data_correlations_ui(id, ...)
|
||||
|
||||
data_correlations_server(id, data, include.class = NULL, cutoff = 0.7, ...)
|
||||
|
||||
data_visuals_ui(id, tab_title = "Plots", ...)
|
||||
|
||||
data_visuals_server(id, data, ...)
|
||||
}
|
||||
\arguments{
|
||||
\item{id}{Module id. (Use 'ns("id")')}
|
||||
|
||||
\item{...}{arguments passed to toastui::datagrid}
|
||||
\item{...}{ignored}
|
||||
|
||||
\item{data}{data}
|
||||
|
||||
|
|
@ -24,8 +30,14 @@ data_correlations_server(id, data, include.class = NULL, cutoff = 0.7, ...)
|
|||
\value{
|
||||
Shiny ui module
|
||||
|
||||
shiny server module
|
||||
|
||||
Shiny ui module
|
||||
|
||||
shiny server module
|
||||
}
|
||||
\description{
|
||||
Data correlations evaluation module
|
||||
|
||||
Data correlations evaluation module
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,56 +1,47 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/data_plots.R, R/plot_hbar.R, R/plot_ridge.R,
|
||||
% R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R
|
||||
% Please edit documentation in R/data_plots.R, R/plot_sankey.R
|
||||
\name{data-plots}
|
||||
\alias{data-plots}
|
||||
\alias{data_visuals_ui}
|
||||
\alias{data_visuals_server}
|
||||
\alias{plot_ridge}
|
||||
\alias{create_plot}
|
||||
\alias{plot_hbars}
|
||||
\alias{plot_ridge}
|
||||
\alias{plot_violin}
|
||||
\alias{plot_scatter}
|
||||
\alias{sankey_ready}
|
||||
\alias{plot_sankey}
|
||||
\alias{plot_scatter}
|
||||
\alias{plot_violin}
|
||||
\title{Data correlations evaluation module}
|
||||
\title{Plot nice ridge plot}
|
||||
\usage{
|
||||
data_visuals_ui(id, tab_title = "Plots", ...)
|
||||
|
||||
data_visuals_server(id, data, ...)
|
||||
plot_ridge(data, x, y, z = NULL, ...)
|
||||
|
||||
create_plot(data, type, x, y, z = NULL, ...)
|
||||
|
||||
plot_hbars(data, x, y, z = NULL)
|
||||
|
||||
plot_ridge(data, x, y, z = NULL, ...)
|
||||
plot_violin(data, x, y, z = NULL)
|
||||
|
||||
plot_scatter(data, x, y, z = NULL)
|
||||
|
||||
sankey_ready(data, x, y, numbers = "count", ...)
|
||||
|
||||
plot_sankey(data, x, y, z = NULL, color.group = "x", colors = NULL)
|
||||
|
||||
plot_scatter(data, x, y, z = NULL)
|
||||
|
||||
plot_violin(data, x, y, z = NULL)
|
||||
}
|
||||
\arguments{
|
||||
\item{id}{Module id. (Use 'ns("id")')}
|
||||
|
||||
\item{...}{ignored for now}
|
||||
|
||||
\item{data}{data.frame}
|
||||
|
||||
\item{type}{plot type (derived from possible_plots() and matches custom function)}
|
||||
|
||||
\item{x}{primary variable}
|
||||
|
||||
\item{y}{secondary variable}
|
||||
|
||||
\item{z}{tertiary variable}
|
||||
|
||||
\item{...}{ignored for now}
|
||||
|
||||
\item{type}{plot type (derived from possible_plots() and matches custom function)}
|
||||
}
|
||||
\value{
|
||||
Shiny ui module
|
||||
ggplot2 object
|
||||
|
||||
shiny server module
|
||||
ggplot2 object
|
||||
|
||||
ggplot2 object
|
||||
|
||||
|
|
@ -60,37 +51,33 @@ ggplot2 object
|
|||
|
||||
data.frame
|
||||
|
||||
ggplot2 object
|
||||
|
||||
ggplot2 object
|
||||
|
||||
ggplot2 object
|
||||
}
|
||||
\description{
|
||||
Data correlations evaluation module
|
||||
Plot nice ridge plot
|
||||
|
||||
Wrapper to create plot based on provided type
|
||||
|
||||
Nice horizontal stacked bars (Grotta bars)
|
||||
|
||||
Plot nice ridge plot
|
||||
Beatiful violin plot
|
||||
|
||||
Beautiful violin plot
|
||||
|
||||
Readying data for sankey plot
|
||||
|
||||
Beautiful sankey plot with option to split by a tertiary group
|
||||
|
||||
Beautiful violin plot
|
||||
|
||||
Beatiful violin plot
|
||||
}
|
||||
\examples{
|
||||
create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
mtcars |>
|
||||
default_parsing() |>
|
||||
plot_ridge(x = "mpg", y = "cyl")
|
||||
mtcars |> plot_ridge(x = "mpg", y = "cyl", z = "gear")
|
||||
create_plot(mtcars, "plot_violin", "mpg", "cyl")
|
||||
mtcars |> plot_hbars(x = "carb", y = "cyl")
|
||||
mtcars |> plot_hbars(x = "carb", y = NULL)
|
||||
mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_factor(sample(letters[1:4], 100, TRUE)), last = sample(c(letters[1:4], NA), 100, TRUE, prob = c(rep(.23, 4), .08)))
|
||||
ds |> sankey_ready("first", "last")
|
||||
ds |> sankey_ready("first", "last", numbers = "percentage")
|
||||
|
|
@ -104,6 +91,4 @@ ds <- data.frame(g = sample(LETTERS[1:2], 100, TRUE), first = REDCapCAST::as_fac
|
|||
ds |> plot_sankey("first", "last")
|
||||
ds |> plot_sankey("first", "last", color.group = "y")
|
||||
ds |> plot_sankey("first", "last", z = "g", color.group = "y")
|
||||
mtcars |> plot_scatter(x = "mpg", y = "wt")
|
||||
mtcars |> plot_violin(x = "mpg", y = "cyl", z = "gear")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
\usage{
|
||||
import_file_ui(
|
||||
id,
|
||||
title = "",
|
||||
title = TRUE,
|
||||
preview_data = TRUE,
|
||||
file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat",
|
||||
".sav"),
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
\alias{redcap_demo_app}
|
||||
\title{Shiny module to browser and export REDCap data}
|
||||
\usage{
|
||||
m_redcap_readUI(id, title = TRUE)
|
||||
m_redcap_readUI(id, include_title = TRUE)
|
||||
|
||||
m_redcap_readServer(id)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
% Generated by roxygen2: do not edit by hand
|
||||
% Please edit documentation in R/plot_hbar.R
|
||||
% Please edit documentation in R/data_plots.R
|
||||
\name{vertical_stacked_bars}
|
||||
\alias{vertical_stacked_bars}
|
||||
\title{Vertical stacked bar plot wrapper}
|
||||
|
|
|
|||
34
renv.lock
34
renv.lock
|
|
@ -3683,40 +3683,6 @@
|
|||
"Author": "Jason Cory Brunson [aut, cre], Quentin D. Read [aut]",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"ggcorrplot": {
|
||||
"Package": "ggcorrplot",
|
||||
"Version": "0.1.4.1",
|
||||
"Source": "Repository",
|
||||
"Type": "Package",
|
||||
"Title": "Visualization of a Correlation Matrix using 'ggplot2'",
|
||||
"Authors@R": "c(person(given = \"Alboukadel\", family = \"Kassambara\", role = c(\"aut\", \"cre\"), email = \"alboukadel.kassambara@gmail.com\"), person(given = \"Indrajeet\", family = \"Patil\", role = \"ctb\", email = \"patilindrajeet.science@gmail.com\", comment = c(ORCID = \"0000-0003-1995-6531\", Twitter = \"@patilindrajeets\")))",
|
||||
"Description": "The 'ggcorrplot' package can be used to visualize easily a correlation matrix using 'ggplot2'. It provides a solution for reordering the correlation matrix and displays the significance level on the plot. It also includes a function for computing a matrix of correlation p-values.",
|
||||
"License": "GPL-2",
|
||||
"URL": "http://www.sthda.com/english/wiki/ggcorrplot-visualization-of-a-correlation-matrix-using-ggplot2",
|
||||
"BugReports": "https://github.com/kassambara/ggcorrplot/issues",
|
||||
"Depends": [
|
||||
"R (>= 3.3)",
|
||||
"ggplot2 (>= 3.3.6)"
|
||||
],
|
||||
"Imports": [
|
||||
"reshape2",
|
||||
"stats"
|
||||
],
|
||||
"Suggests": [
|
||||
"testthat (>= 3.0.0)",
|
||||
"knitr",
|
||||
"spelling",
|
||||
"vdiffr (>= 1.0.0)"
|
||||
],
|
||||
"Encoding": "UTF-8",
|
||||
"Language": "en-US",
|
||||
"RoxygenNote": "7.1.0",
|
||||
"Config/testthat/edition": "3",
|
||||
"NeedsCompilation": "no",
|
||||
"Author": "Alboukadel Kassambara [aut, cre], Indrajeet Patil [ctb] (<https://orcid.org/0000-0003-1995-6531>, @patilindrajeets)",
|
||||
"Maintainer": "Alboukadel Kassambara <alboukadel.kassambara@gmail.com>",
|
||||
"Repository": "CRAN"
|
||||
},
|
||||
"ggeffects": {
|
||||
"Package": "ggeffects",
|
||||
"Version": "2.2.0",
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue