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

polished import

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2025-05-10 11:31:26 +02:00
parent 91a3f19952
commit a655dd3b87
No known key found for this signature in database
3 changed files with 104 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
R/datagrid-infos-mod.R
View file

@ -35,7 +35,7 @@ show_data <- function(data,
if (is.null(options)) if (is.null(options))
options <- list() options <- list()
options$height <- 550 options$height <- 500
options$minBodyHeight <- 400 options$minBodyHeight <- 400
options$data <- data options$data <- data
options$theme <- "default" options$theme <- "default"

14
R/helpers.R
View file

@ -652,3 +652,17 @@ is_identical_to_previous <- function(data, no.name = TRUE) {
} }
}, FUN.VALUE = logical(1)) }, FUN.VALUE = logical(1))
} }
#' Simplified version of the snakecase packages to_snake_case
#'
#' @param data character string vector
#'
#' @returns vector
#' @export
#'
#' @examples
#' c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake()
simple_snake <- function(data){
gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE)
}

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

@ -2983,7 +2983,7 @@ show_data <- function(data,
if (is.null(options)) if (is.null(options))
options <- list() options <- list()
options$height <- 550 options$height <- 500
options$minBodyHeight <- 400 options$minBodyHeight <- 400
options$data <- data options$data <- data
options$theme <- "default" options$theme <- "default"
@ -3951,11 +3951,25 @@ is_identical_to_previous <- function(data, no.name = TRUE) {
} }
#' Simplified version of the snakecase packages to_snake_case
#'
#' @param data character string vector
#'
#' @returns vector
#' @export
#'
#' @examples
#' c("foo bar", "fooBar21", "!!Foo'B'a-r", "foo_bar", "F OO bar") |> simple_snake()
simple_snake <- function(data){
gsub("[\\s+]","_",gsub("[^\\w\\s:-]", "", tolower(data), perl=TRUE), perl=TRUE)
}
######## ########
#### Current file: /Users/au301842/FreesearchR/R//hosted_version.R #### Current file: /Users/au301842/FreesearchR/R//hosted_version.R
######## ########
hosted_version <- function()'v25.5.2-250508' hosted_version <- function()'v25.5.2-250510'
######## ########
@ -5566,9 +5580,12 @@ m_redcap_readServer <- function(id) {
) )
# browser() # browser()
shiny::withProgress({ shiny::withProgress(
{
imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE) imported <- try(rlang::exec(REDCapR::redcap_metadata_read, !!!parameters), silent = TRUE)
},message = paste("Connecting to",data_rv$uri)) },
message = paste("Connecting to", data_rv$uri)
)
## TODO: Simplify error messages ## TODO: Simplify error messages
if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) { if (inherits(imported, "try-error") || NROW(imported) < 1 || ifelse(is.list(imported), !isTRUE(imported$success), FALSE)) {
@ -5594,7 +5611,7 @@ m_redcap_readServer <- function(id) {
status = "success", status = "success",
include_data_alert( include_data_alert(
see_data_text = "Click to see data dictionary", see_data_text = "Click to see data dictionary",
dataIdName = "see_data", dataIdName = "see_dd",
extra = tags$p( extra = tags$p(
tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"), tags$b(phosphoricons::ph("check", weight = "bold"), "Connected to server!"),
glue::glue("The {data_rv$info$project_title} project is loaded.") glue::glue("The {data_rv$info$project_title} project is loaded.")
@ -5620,8 +5637,8 @@ m_redcap_readServer <- function(id) {
output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success")) output$connect_success <- shiny::reactive(identical(data_rv$dd_status, "success"))
shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE) shiny::outputOptions(output, "connect_success", suspendWhenHidden = FALSE)
shiny::observeEvent(input$see_data, { shiny::observeEvent(input$see_dd, {
datamods::show_data( show_data(
purrr::pluck(data_rv$dd_list, "data"), purrr::pluck(data_rv$dd_list, "data"),
title = "Data dictionary", title = "Data dictionary",
type = "modal", type = "modal",
@ -5630,6 +5647,17 @@ m_redcap_readServer <- function(id) {
) )
}) })
shiny::observeEvent(input$see_data, {
show_data(
# purrr::pluck(data_rv$dd_list, "data"),
data_rv$data,
title = "Imported data set",
type = "modal",
show_classes = FALSE,
tags$b("Preview:")
)
})
arms <- shiny::reactive({ arms <- shiny::reactive({
shiny::req(input$api) shiny::req(input$api)
shiny::req(data_rv$uri) shiny::req(data_rv$uri)
@ -5744,13 +5772,24 @@ m_redcap_readServer <- function(id) {
imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE) imported <- try(rlang::exec(REDCapCAST::read_redcap_tables, !!!parameters), silent = TRUE)
}) })
code <- rlang::call2("read_redcap_tables", parameters_code <- parameters[c("uri", "fields", "events", "raw_or_label", "filter_logic")]
!!!utils::modifyList(parameters, list(token = "PERSONAL_API_TOKEN")), ,
code <- rlang::call2(
"easy_redcap",
!!!utils::modifyList(
parameters_code,
list(
data_format = ifelse(
input$data_type == "long" && !is.null(input$data_type),
"long",
"wide"
),
project.name = simple_snake(data_rv$info$project_title)
)
),
.ns = "REDCapCAST" .ns = "REDCapCAST"
) )
# browser()
if (inherits(imported, "try-error") || NROW(imported) < 1) { if (inherits(imported, "try-error") || NROW(imported) < 1) {
data_rv$data_status <- "error" data_rv$data_status <- "error"
data_rv$data_list <- NULL data_rv$data_list <- NULL
@ -5819,9 +5858,17 @@ m_redcap_readServer <- function(id) {
datamods:::insert_alert( datamods:::insert_alert(
selector = ns("retrieved"), selector = ns("retrieved"),
status = data_rv$data_status, status = data_rv$data_status,
tags$p( # tags$p(
tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"), # tags$b(phosphoricons::ph("check", weight = "bold"), "Success!"),
data_rv$data_message # data_rv$data_message
# ),
include_data_alert(
see_data_text = "Click to see the imported data",
dataIdName = "see_data",
extra = tags$p(
tags$b(phosphoricons::ph("check", weight = "bold"), data_rv$data_message)
),
btn_show_data = TRUE
) )
) )
} else { } else {
@ -6022,13 +6069,6 @@ redcap_demo_app <- function() {
} }
########
#### Current file: /Users/au301842/FreesearchR/R//redcap.R
########
######## ########
#### Current file: /Users/au301842/FreesearchR/R//regression_model.R #### Current file: /Users/au301842/FreesearchR/R//regression_model.R
######## ########
@ -9317,10 +9357,10 @@ ui_elements <- list(
condition = "input.source=='env'", condition = "input.source=='env'",
import_globalenv_ui(id = "env", title = NULL) import_globalenv_ui(id = "env", title = NULL)
), ),
shiny::conditionalPanel( # shiny::conditionalPanel(
condition = "input.source=='redcap'", # condition = "input.source=='redcap'",
DT::DTOutput(outputId = "redcap_prev") # DT::DTOutput(outputId = "redcap_prev")
), # ),
shiny::conditionalPanel( shiny::conditionalPanel(
condition = "output.data_loaded == true", condition = "output.data_loaded == true",
shiny::br(), shiny::br(),
@ -9329,13 +9369,8 @@ ui_elements <- list(
shiny::fluidRow( shiny::fluidRow(
shiny::column( shiny::column(
width = 6, width = 6,
shiny::p("Filter by completeness threshold:"),
shiny::br(), shiny::br(),
shiny::p("Filter by completeness threshold and manual selection:"),
shiny::br(),
shiny::br()
),
shiny::column(
width = 6,
shinyWidgets::noUiSliderInput( shinyWidgets::noUiSliderInput(
inputId = "complete_cutoff", inputId = "complete_cutoff",
label = NULL, label = NULL,
@ -9348,12 +9383,17 @@ ui_elements <- list(
color = datamods:::get_primary_color() color = datamods:::get_primary_color()
), ),
shiny::helpText("Exclude variables with completeness below the specified percentage."), shiny::helpText("Exclude variables with completeness below the specified percentage."),
shiny::br(), shiny::br()
),
shiny::column(
width = 6,
shiny::p("Specify manually:"),
shiny::br(), shiny::br(),
shiny::uiOutput(outputId = "import_var"), shiny::uiOutput(outputId = "import_var"),
shiny::br()
)
),
shiny::uiOutput(outputId = "data_info_import", inline = TRUE) shiny::uiOutput(outputId = "data_info_import", inline = TRUE)
)
)
), ),
shiny::br(), shiny::br(),
shiny::br(), shiny::br(),
@ -9830,6 +9870,9 @@ ui <- bslib::page_fixed(
#### Current file: /Users/au301842/FreesearchR/app/server.R #### Current file: /Users/au301842/FreesearchR/app/server.R
######## ########
library(shiny)
# library(shinyjs)
# library(methods)
library(readr) library(readr)
library(MASS) library(MASS)
library(stats) library(stats)
@ -9837,7 +9880,6 @@ library(gt)
# library(openxlsx2) # library(openxlsx2)
library(haven) library(haven)
library(readODS) library(readODS)
require(shiny)
library(bslib) library(bslib)
library(assertthat) library(assertthat)
library(dplyr) library(dplyr)
@ -9856,7 +9898,7 @@ library(shinyWidgets)
library(DT) library(DT)
library(data.table) library(data.table)
library(gtsummary) library(gtsummary)
library(shinyjs) library(bsicons)
data(starwars) data(starwars)
data(mtcars) data(mtcars)
@ -9864,8 +9906,8 @@ data(trial)
load_data <- function() { load_data <- function() {
Sys.sleep(1) Sys.sleep(1)
hide("loading_page") shinyjs::hide("loading_page")
show("main_content") shinyjs::show("main_content")
} }
@ -9946,14 +9988,14 @@ server <- function(input, output, session) {
}) })
## This is used to ensure the reactive data is retrieved ## This is used to ensure the reactive data is retrieved
output$redcap_prev <- DT::renderDT( # output$redcap_prev <- DT::renderDT(
{ # {
DT::datatable(head(from_redcap$data(), 5), # DT::datatable(head(from_redcap$data(), 5),
caption = "First 5 observations" # caption = "First 5 observations"
) # )
}, # },
server = TRUE # server = TRUE
) # )
from_env <- datamods::import_globalenv_server( from_env <- datamods::import_globalenv_server(
id = "env", id = "env",