rev text

DESCRIPTION

@@ -68,7 +68,8 @@ Imports:
     REDCapCAST,
     eulerr,
     ggforce,
-    RcppArmadillo
+    RcppArmadillo,
+    ggcorrplot
 Suggests: 
     styler,
     devtools,

NAMESPACE

@@ -104,21 +104,12 @@ 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)
@@ -127,7 +118,6 @@ importFrom(shiny,actionButton)
 importFrom(shiny,bindEvent)
 importFrom(shiny,checkboxInput)
 importFrom(shiny,column)
-importFrom(shiny,fileInput)
 importFrom(shiny,fluidRow)
 importFrom(shiny,getDefaultReactiveDomain)
 importFrom(shiny,icon)
@@ -139,7 +129,6 @@ importFrom(shiny,observeEvent)
 importFrom(shiny,plotOutput)
 importFrom(shiny,reactive)
 importFrom(shiny,reactiveValues)
-importFrom(shiny,removeUI)
 importFrom(shiny,renderPlot)
 importFrom(shiny,req)
 importFrom(shiny,restoreInput)
@@ -150,13 +139,8 @@ 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)
@@ -169,6 +153,4 @@ 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)

R/app_version.R

@@ -1 +1 @@
-app_version <- function()'250312_1817'
+app_version <- function()'250313_1502'

R/correlations-module.R

@@ -46,7 +46,8 @@ data_correlations_server <- function(id,
         } else {
           out <- data()
         }
-        out
+        out |> dplyr::mutate(dplyr::across(tidyselect::everything(),as.numeric))
+        # as.numeric()
       })
 
       # rv <- list()
@@ -74,7 +75,25 @@ data_correlations_server <- function(id,
       })
 
       output$correlation_plot <- shiny::renderPlot({
-        psych::pairs.panels(rv$data())
+        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())
       })
     }
   )
@@ -114,7 +133,7 @@ sentence_paste <- function(data, and.str = "and") {
 }
 
 
-cor_app <- function() {
+cor_demo_app <- function() {
   ui <- shiny::fluidPage(
     shiny::sliderInput(
       inputId = "cor_cutoff",
@@ -128,9 +147,9 @@ cor_app <- function() {
     data_correlations_ui("data", height = 600)
   )
   server <- function(input, output, session) {
-    data_correlations_server("data", data = shiny::reactive(mtcars), cutoff = shiny::reactive(input$cor_cutoff))
+    data_correlations_server("data", data = shiny::reactive(default_parsing(mtcars)), cutoff = shiny::reactive(input$cor_cutoff))
   }
   shiny::shinyApp(ui, server)
 }
 
-cor_app()
+cor_demo_app()

R/data-import.R

@@ -0,0 +1,250 @@
+#' 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)
+#' }

R/data-summary.R

@@ -31,14 +31,6 @@ 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(
           {

R/data_plots.R

@@ -4,7 +4,7 @@
 #'
 #' @param id Module id. (Use 'ns("id")')
 #'
-#' @name data-correlations
+#' @name data-plots
 #' @returns Shiny ui module
 #' @export
 #'
@@ -24,12 +24,21 @@ 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::uiOutput(outputId = ns("tertiary")),
+          shiny::br(),
+          shiny::actionButton(
+            inputId = ns("act_plot"),
+            label = "Plot",
+            width = "100%",
+            icon = shiny::icon("palette"),
+            disabled = FALSE
           ),
-        bslib::accordion_panel(
+          shiny::helpText('Adjust settings, then press "Plot".')
-          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"),
@@ -87,7 +96,7 @@ data_visuals_ui <- function(id, tab_title = "Plots", ...) {
 #' @param data data
 #' @param ... ignored
 #'
-#' @name data-correlations
+#' @name data-plots
 #' @returns shiny server module
 #' @export
 data_visuals_server <- function(id,
@@ -148,7 +157,6 @@ data_visuals_server <- function(id,
 
       output$secondary <- shiny::renderUI({
         shiny::req(input$type)
-        # browser()
 
         cols <- c(
           rv$plot.params()[["secondary.extra"]],
@@ -164,9 +172,9 @@ data_visuals_server <- function(id,
         columnSelectInput(
           inputId = ns("secondary"),
           data = data,
-          selected = 1,
+          selected = cols[1],
-          placeholder = "Select variable",
+          placeholder = "Please select",
-          label = "Secondary/group variable",
+          label = if (isTRUE(rv$plot.params()[["secondary.multi"]])) "Additional variables" else "Secondary variable",
           multiple = rv$plot.params()[["secondary.multi"]],
           maxItems = rv$plot.params()[["secondary.max"]],
           col_subset = cols,
@@ -179,8 +187,8 @@ data_visuals_server <- function(id,
         columnSelectInput(
           inputId = ns("tertiary"),
           data = data,
-          placeholder = "Select variable",
+          placeholder = "Please select",
-          label = "Strata variable",
+          label = "Grouping variable",
           multiple = FALSE,
           col_subset = c(
             "none",
@@ -197,25 +205,32 @@ data_visuals_server <- function(id,
         )
       })
 
-      rv$plot <- shiny::reactive({
+      shiny::observeEvent(input$act_plot,
-        shiny::req(input$primary)
+        {
-        shiny::req(input$type)
+          tryCatch(
-        shiny::req(input$secondary)
+            {
-        shiny::req(input$tertiary)
+              rv$plot <- create_plot(
-        # if (length(input$secondary)>1){
-        #   browser()
-        # }
-        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
+      )
 
       output$plot <- shiny::renderPlot({
-        rv$plot()
+        shiny::req(rv$plot)
+        rv$plot
       })
 
       output$download_plot <- shiny::downloadHandler(
@@ -226,7 +241,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,
@@ -245,7 +260,6 @@ data_visuals_server <- function(id,
 }
 
 
-
 #' Select all from vector but
 #'
 #' @param data vector
@@ -364,36 +378,6 @@ 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
@@ -494,104 +478,6 @@ 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
@@ -626,62 +512,6 @@ 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
@@ -705,3 +535,39 @@ 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))
+}

R/import-file-ext.R

@@ -1,4 +1,3 @@
-
 #' @title Import data from a file
 #'
 #' @description Let user upload a file and import data
@@ -11,26 +10,20 @@
 #'
 #' @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 = TRUE,
+                           title = "",
                            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 <- tags$h4(
+    title <- shiny::tags$h4(
       datamods:::i18n("Import a file"),
       class = "datamods-title"
     )
@@ -58,7 +51,7 @@ import_file_ui <- function(id,
           size = "sm",
           width = "100%"
         ),
-        shiny::helpText(ph("info"), datamods:::i18n("if several use a comma (',') to separate them"))
+        shiny::helpText(phosphoricons::ph("info"), datamods:::i18n("if several use a comma (',') to separate them"))
       )
     ),
     shiny::column(
@@ -74,8 +67,10 @@ import_file_ui <- function(id,
       selectInputIcon(
         inputId = ns("encoding"),
         label = datamods:::i18n("Encoding:"),
-        choices = c("UTF-8"="UTF-8",
+        choices = c(
-                    "Latin1"="latin1"),
+          "UTF-8" = "UTF-8",
+          "Latin1" = "latin1"
+        ),
         icon = phosphoricons::ph("text-aa"),
         size = "sm",
         width = "100%"
@@ -113,7 +108,7 @@ import_file_ui <- function(id,
         shinyWidgets::dropMenu(
           shiny::actionButton(
             inputId = ns("dropdown_params"),
-            label = ph("gear", title = "Parameters"),
+            label = phosphoricons::ph("gear", title = "Parameters"),
             width = "50px",
             class = "px-1"
           ),
@@ -122,23 +117,24 @@ import_file_ui <- function(id,
       )
     )
   }
-  tags$div(
+  shiny::tags$div(
     class = "datamods-import",
     datamods:::html_dependency_datamods(),
     title,
     file_ui,
     if (identical(layout_params, "inline")) params_ui,
-    tags$div(
+    shiny::tags$div(
       class = "hidden",
       id = ns("sheet-container"),
       shinyWidgets::pickerInput(
         inputId = ns("sheet"),
         label = datamods:::i18n("Select sheet to import:"),
         choices = NULL,
-        width = "100%"
+        width = "100%",
+        multiple = TRUE
       )
     ),
-    tags$div(
+    shiny::tags$div(
       id = ns("import-placeholder"),
       shinyWidgets::alert(
         id = ns("import-result"),
@@ -150,8 +146,9 @@ import_file_ui <- function(id,
     ),
     if (isTRUE(preview_data)) {
     toastui::datagridOutput2(outputId = ns("table"))
-    },
+    }
-    uiOutput(
+    ,
+    shiny::uiOutput(
       outputId = ns("container_confirm_btn"),
       style = "margin-top: 20px;"
     )  ,
@@ -180,16 +177,6 @@ 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,
@@ -199,48 +186,49 @@ 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 (!is_named(read_fns))
+    if (!rlang::is_named(read_fns)) {
       stop("import_file_server: `read_fns` must be a named list.", call. = FALSE)
-    if (!all(vapply(read_fns, is_function, logical(1))))
+    }
+    if (!all(vapply(read_fns, rlang::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 <- reactiveValues(data = NULL, name = NULL)
+    imported_rv <- shiny::reactiveValues(data = NULL, name = NULL)
-    temporary_rv <- reactiveValues(data = NULL, name = NULL, status = NULL)
+    temporary_rv <- shiny::reactiveValues(data = NULL, name = NULL, status = NULL)
 
-    observeEvent(reset(), {
+    shiny::observeEvent(reset(), {
       temporary_rv$data <- NULL
       temporary_rv$name <- NULL
       temporary_rv$status <- NULL
     })
 
-    output$container_confirm_btn <- renderUI({
+    output$container_confirm_btn <- shiny::renderUI({
       if (identical(trigger_return, "button")) {
         datamods:::button_import()
       }
     })
 
-    observeEvent(input$file, {
+    shiny::observeEvent(input$file, {
+      if (isTRUE(is_workbook(input$file$datapath))) {
         if (isTRUE(is_excel(input$file$datapath))) {
-        shinyWidgets::updatePickerInput(
+          choices <- readxl::excel_sheets(input$file$datapath)
-          session = session,
-          inputId = "sheet",
-          choices = readxl::excel_sheets(input$file$datapath)
-        )
-        datamods:::showUI(paste0("#", ns("sheet-container")))
         } else if (isTRUE(is_ods(input$file$datapath))) {
+          choices <- readODS::ods_sheets(input$file$datapath)
+        }
+        selected <- choices[1]
+
         shinyWidgets::updatePickerInput(
           session = session,
           inputId = "sheet",
-          choices = readODS::ods_sheets(input$file$datapath)
+          choices = choices,
+          selected = selected
         )
         datamods:::showUI(paste0("#", ns("sheet-container")))
       } else {
@@ -248,18 +236,24 @@ import_file_server <- function(id,
       }
     })
 
-    observeEvent(list(
+    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)
-      if (isTRUE(extension %in% names(read_fns))) {
+
         parameters <- list(
           file = input$file$datapath,
           sheet = input$sheet,
@@ -270,34 +264,7 @@ 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 <- call2(read_fns[[extension]], !!!modifyList(parameters, list(file = input$file$name)))
+        code <- rlang::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)
-          )
-        }
-        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)
@@ -305,16 +272,13 @@ import_file_server <- function(id,
         }
 
         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(
@@ -332,7 +296,9 @@ import_file_server <- function(id,
           temporary_rv$name <- input$file$name
           temporary_rv$code <- code
         }
-    }, ignoreInit = TRUE)
+      },
+      ignoreInit = TRUE
+    )
 
     observeEvent(input$see_data, {
       datamods:::show_data(temporary_rv$data, title = datamods:::i18n("Imported data"), type = show_data_in)
@@ -391,6 +357,10 @@ 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
@@ -414,6 +384,54 @@ 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,
@@ -437,11 +455,11 @@ selectInputIcon <- function(inputId,
                             width = NULL,
                             icon = NULL) {
   selected <- shiny::restoreInput(id = inputId, default = selected)
-  tags$div(
+  shiny::tags$div(
     class = "form-group shiny-input-container",
     shinyWidgets:::label_input(inputId, label),
     style = htmltools:::css(width = htmltools:::validateCssUnit(width)),
-    tags$div(
+    shiny::tags$div(
       class = "input-group",
       class = shinyWidgets:::validate_size(size),
       shinyWidgets:::markup_input_group(icon, "left", theme_func = shiny::getCurrentTheme),
@@ -457,71 +475,89 @@ selectInputIcon <- function(inputId,
 }
 
 
-
+#' Test app for the import_file module
-
+#'
-
+#' @rdname import-file_module
-# library(shiny)
+#'
-# library(datamods)
+#' @examples
-
+#' \dontrun{
-ui <- fluidPage(
+#' 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"),
-  tags$h3("Import data from a file"),
+    shiny::tags$h3("Import data from a file"),
-  fluidRow(
+    shiny::fluidRow(
-    column(
+      shiny::column(
         width = 4,
         import_file_ui(
           id = "myid",
-        file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".json"),
+          file_extensions = c(".csv", ".tsv", ".txt", ".xls", ".xlsx", ".rds", ".sas7bdat", ".ods", ".dta"),
           layout_params = "dropdown" # "inline" # or "dropdown"
         )
       ),
-    column(
+      shiny::column(
         width = 8,
-      tags$b("Import status:"),
+        shiny::tags$b("Import status:"),
-      verbatimTextOutput(outputId = "status"),
+        shiny::verbatimTextOutput(outputId = "status"),
-      tags$b("Name:"),
+        shiny::tags$b("Name:"),
-      verbatimTextOutput(outputId = "name"),
+        shiny::verbatimTextOutput(outputId = "name"),
-      tags$b("Code:"),
+        shiny::tags$b("Code:"),
-      verbatimTextOutput(outputId = "code"),
+        shiny::verbatimTextOutput(outputId = "code"),
-      tags$b("Data:"),
+        shiny::tags$b("Data:"),
-      verbatimTextOutput(outputId = "data")
+        shiny::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(
-      xls = function(file, sheet, skip, encoding) {
+        ods = import_ods,
-        readxl::read_xls(path = file, sheet = sheet, skip = skip)
+        dta = function(file) {
+          haven::read_dta(
+            file = file,
+            .name_repair = "unique_quiet"
+          )
         },
-      json = function(file) {
+        # csv = function(file) {
-        jsonlite::read_json(file, simplifyVector = TRUE)
+        #   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"
+          )
         }
-    ),
+      )
-    show_data_in = "modal"
     )
 
-  output$status <- renderPrint({
+    output$status <- shiny::renderPrint({
       imported$status()
     })
-  output$name <- renderPrint({
+    output$name <- shiny::renderPrint({
       imported$name()
     })
-  output$code <- renderPrint({
+    output$code <- shiny::renderPrint({
       imported$code()
     })
-  output$data <- renderPrint({
+    output$data <- shiny::renderPrint({
       imported$data()
     })
-
   }
-
+  shiny::shinyApp(ui, server)
-if (interactive())
+}
-  shinyApp(ui, server)
-
-

R/plot_euler.R

@@ -93,7 +93,8 @@ plot_euler <- function(data, x, y, z = NULL, seed = 2103) {
       plot_euler_single()
   })
 
-  patchwork::wrap_plots(out, guides = "collect")
+  wrap_plot_list(out)
+  # patchwork::wrap_plots(out, guides = "collect")
 }
 
 

R/plot_hbar.R

@@ -0,0 +1,95 @@
+#' 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")
+    })()
+}

R/plot_ridge.R

@@ -0,0 +1,28 @@
+#' 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)
+}

R/plot_scatter.R

@@ -0,0 +1,25 @@
+#' 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)
+    )
+  }
+}

R/plot_violin.R

@@ -0,0 +1,27 @@
+#' 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")
+}

R/redcap_read_shiny_module.R

@@ -7,9 +7,16 @@
 #'
 #' @return shiny ui element
 #' @export
-m_redcap_readUI <- function(id, include_title = TRUE) {
+m_redcap_readUI <- function(id, 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"),
@@ -75,7 +82,7 @@ m_redcap_readUI <- function(id, include_title = TRUE) {
 
 
   shiny::fluidPage(
-    if (include_title) shiny::tags$h3("Import data from REDCap"),
+    title=title,
     bslib::layout_columns(
       server_ui,
       params_ui,
@@ -140,7 +147,13 @@ 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

R/update-variables-ext.R

@@ -13,7 +13,7 @@ library(rlang)
 #'
 #' @name update-variables
 #'
-update_variables_ui <- function(id, title = TRUE) {
+update_variables_ui <- function(id, title = "") {
   ns <- NS(id)
   if (isTRUE(title)) {
     title <- htmltools::tags$h4(

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

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

inst/apps/freesearcheR/server.R

@@ -93,23 +93,13 @@ 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 = function(file, which, skip, na) {
+      ods = import_ods,
-        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,
@@ -126,24 +116,8 @@ server <- function(input, output, session) {
       csv = import_delim,
       tsv = import_delim,
       txt = import_delim,
-      xls = function(file, which, skip, na) {
+      xls = import_xls,
-        openxlsx2::read_xlsx(
+      xlsx = import_xls,
-          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,
@@ -160,8 +134,7 @@ server <- function(input, output, session) {
   })
 
   data_redcap <- m_redcap_readServer(
-    id = "redcap_import" # ,
+    id = "redcap_import"
-    # output.format = "list"
   )
 
   shiny::observeEvent(data_redcap(), {
@@ -203,7 +176,7 @@ server <- function(input, output, session) {
       label = "Select variables to include",
       selected = preselect,
       choices = names(rv$data_temp),
-      updateOn = "close",
+      updateOn = "change",
       multiple = TRUE,
       search = TRUE,
       showValueAsTags = TRUE
@@ -299,7 +272,7 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     input$modal_variables,
-    modal_update_variables("modal_variables", title = "Modify factor levels")
+    modal_update_variables("modal_variables", title = "Update and select variables")
   )
 
 
@@ -307,7 +280,7 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     input$modal_cut,
-    modal_cut_variable("modal_cut", title = "Modify factor levels")
+    modal_cut_variable("modal_cut", title = "Create new factor")
   )
 
   data_modal_cut <- cut_variable_server(
@@ -321,7 +294,7 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     input$modal_update,
-    datamods::modal_update_factor(id = "modal_update")
+    datamods::modal_update_factor(id = "modal_update", title = "Reorder factor levels")
   )
 
   data_modal_update <- datamods::update_factor_server(
@@ -338,7 +311,11 @@ server <- function(input, output, session) {
 
   shiny::observeEvent(
     input$modal_column,
-    datamods::modal_create_column(id = "modal_column", footer = "This is only for advanced users!")
+    datamods::modal_create_column(
+      id = "modal_column",
+      footer = "This window is aimed at advanced users and require some R-experience!",
+      title = "Create new variables"
+    )
   )
   data_modal_r <- datamods::create_column_server(
     id = "modal_column",
@@ -600,8 +577,8 @@ server <- function(input, output, session) {
       data_filter(),
       input$strat_var,
       input$include_vars,
-      input$add_p,
+      input$complete_cutoff,
-      input$complete_cutoff
+      input$add_p
     ),
     {
       shiny::req(input$strat_var)
@@ -644,13 +621,14 @@ server <- function(input, output, session) {
   )
 
   output$outcome_var_cor <- shiny::renderUI({
-    shiny::selectInput(
+    columnSelectInput(
       inputId = "outcome_var_cor",
-      selected = NULL,
+      selected = "none",
+      data = rv$list$data,
       label = "Select outcome variable",
-      choices = c(
+      col_subset = c(
+        "none",
         colnames(rv$list$data)
-        # ,"none"
       ),
       multiple = FALSE
     )
@@ -668,10 +646,10 @@ server <- function(input, output, session) {
     id = "correlations",
     data = shiny::reactive({
       shiny::req(rv$list$data)
-      out <- dplyr::select(rv$list$data, -!!input$outcome_var_cor)
+      out <- rv$list$data
-      #  input$outcome_var_cor=="none"){
+      if (!is.null(input$outcome_var_cor) && input$outcome_var_cor != "none") {
-      #   out <- rv$list$data
+        out <- out[!names(out) %in% input$outcome_var_cor]
-      # }
+      }
       out
     }),
     cutoff = shiny::reactive(input$cor_cutoff)

inst/apps/freesearcheR/ui.R

@@ -49,13 +49,16 @@ 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("redcap_import")
+          m_redcap_readUI(
+            id = "redcap_import",
+            title = ""
+          )
         ),
         shiny::conditionalPanel(
           condition = "input.source=='env'",
@@ -169,9 +172,7 @@ ui_elements <- list(
           fluidRow(
             shiny::column(
               width = 9,
-              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.).
+              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."))
-                            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(),
@@ -185,7 +186,7 @@ ui_elements <- list(
               fluidRow(
                 shiny::column(
                   width = 6,
-                  tags$h4("Update variables"),
+                  tags$h4("Update or modify variables"),
                   shiny::tags$br(),
                   shiny::actionButton(
                     inputId = "modal_variables",
@@ -212,11 +213,11 @@ ui_elements <- list(
                   shiny::tags$br(),
                   shiny::actionButton(
                     inputId = "modal_cut",
-                    label = "Create factor variable",
+                    label = "New factor",
                     width = "100%"
                   ),
                   shiny::tags$br(),
-                  shiny::helpText("Create factor/categorical variable from an other value."),
+                  shiny::helpText("Create factor/categorical variable from a continous variable (number/date/time)."),
                   shiny::tags$br(),
                   shiny::tags$br(),
                   shiny::actionButton(
@@ -308,9 +309,9 @@ ui_elements <- list(
             bslib::accordion_panel(
               vlaue = "acc_cor",
               title = "Correlations",
-              icon = bsicons::bs_icon("table"),
+              icon = bsicons::bs_icon("bounding-box"),
               shiny::uiOutput("outcome_var_cor"),
-              shiny::helpText("This variable will be excluded from the correlation plot."),
+              shiny::helpText("To avoid evaluating the correlation of the outcome variable, this can be excluded from the plot or select 'none'."),
               shiny::br(),
               shinyWidgets::noUiSliderInput(
                 inputId = "cor_cutoff",
@@ -321,7 +322,8 @@ 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'.")
             )
           )
         ),

man/data-correlations.Rd

@@ -1,25 +1,19 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/correlations-module.R, R/data_plots.R
+% Please edit documentation in R/correlations-module.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{...}{ignored}
+\item{...}{arguments passed to toastui::datagrid}
 
 \item{data}{data}
 
@@ -30,14 +24,8 @@ data_visuals_server(id, data, ...)
 \value{
 Shiny ui module
 
-shiny server module
-
-Shiny ui module
-
 shiny server module
 }
 \description{
-Data correlations evaluation module
-
 Data correlations evaluation module
 }

man/data-plots.Rd

@@ -1,47 +1,56 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data_plots.R, R/plot_sankey.R
+% 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
 \name{data-plots}
 \alias{data-plots}
-\alias{plot_ridge}
+\alias{data_visuals_ui}
+\alias{data_visuals_server}
 \alias{create_plot}
 \alias{plot_hbars}
-\alias{plot_violin}
+\alias{plot_ridge}
-\alias{plot_scatter}
 \alias{sankey_ready}
 \alias{plot_sankey}
-\title{Plot nice ridge plot}
+\alias{plot_scatter}
+\alias{plot_violin}
+\title{Data correlations evaluation module}
 \usage{
-plot_ridge(data, x, y, z = NULL, ...)
+data_visuals_ui(id, tab_title = "Plots", ...)
+
+data_visuals_server(id, data, ...)
 
 create_plot(data, type, x, y, z = NULL, ...)
 
 plot_hbars(data, x, y, z = NULL)
 
-plot_violin(data, x, y, z = NULL)
+plot_ridge(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{
-ggplot2 object
+Shiny ui module
 
-ggplot2 object
+shiny server module
 
 ggplot2 object
 
@@ -51,33 +60,37 @@ ggplot2 object
 
 data.frame
 
+ggplot2 object
+
+ggplot2 object
+
 ggplot2 object
 }
 \description{
-Plot nice ridge plot
+Data correlations evaluation module
 
 Wrapper to create plot based on provided type
 
 Nice horizontal stacked bars (Grotta bars)
 
-Beatiful violin plot
+Plot nice ridge 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")
@@ -91,4 +104,6 @@ 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")
 }

man/import-file.Rd

@@ -8,7 +8,7 @@
 \usage{
 import_file_ui(
   id,
-  title = TRUE,
+  title = "",
   preview_data = TRUE,
   file_extensions = c(".csv", ".txt", ".xls", ".xlsx", ".rds", ".fst", ".sas7bdat",
     ".sav"),

man/redcap_read_shiny_module.Rd

@@ -6,7 +6,7 @@
 \alias{redcap_demo_app}
 \title{Shiny module to browser and export REDCap data}
 \usage{
-m_redcap_readUI(id, include_title = TRUE)
+m_redcap_readUI(id, title = TRUE)
 
 m_redcap_readServer(id)
 

man/vertical_stacked_bars.Rd

@@ -1,5 +1,5 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/data_plots.R
+% Please edit documentation in R/plot_hbar.R
 \name{vertical_stacked_bars}
 \alias{vertical_stacked_bars}
 \title{Vertical stacked bar plot wrapper}

renv.lock

@@ -3683,6 +3683,40 @@
       "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",