From 9452c7a1a1464e797ae6674e16f93de2291bbeea Mon Sep 17 00:00:00 2001 From: Brian Palmer Date: Tue, 15 Aug 2023 22:07:15 -0700 Subject: [PATCH] cleaner search panel + readme update with version bump --- R/ArchiveAndDeleteSamples.R | 1 + R/SearchSamples.R | 5 +- README.md | 10 +- .../server_helpers/AppSearchDelArchSamples.R | 521 +++++++----------- 4 files changed, 211 insertions(+), 326 deletions(-) diff --git a/R/ArchiveAndDeleteSamples.R b/R/ArchiveAndDeleteSamples.R index 2056428d..f77cfa66 100644 --- a/R/ArchiveAndDeleteSamples.R +++ b/R/ArchiveAndDeleteSamples.R @@ -28,6 +28,7 @@ ArchiveAndDeleteSamples <- function(operation, data, comment, status, verification = TRUE){ + print(data) database <- Sys.getenv("SDB_PATH") conn <- RSQLite::dbConnect(RSQLite::SQLite(), database) RSQLite::dbBegin(conn) diff --git a/R/SearchSamples.R b/R/SearchSamples.R index 6ac6ec8f..c6ad59eb 100644 --- a/R/SearchSamples.R +++ b/R/SearchSamples.R @@ -22,7 +22,9 @@ #' @export -SearchSamples <- function(sample_storage_type, filters = NULL, format = NULL, database = Sys.getenv("SDB_PATH"), config_yml = Sys.getenv("SDB_CONFIG"), include_internal_sample_id = FALSE) { +SearchSamples <- function(sample_storage_type, filters = NULL, format = "na", database = Sys.getenv("SDB_PATH"), config_yml = Sys.getenv("SDB_CONFIG"), include_internal_sample_id = FALSE) { + + message("searching...") db.results <- NULL tryCatch({ container_tables <- list( @@ -256,6 +258,7 @@ SearchSamples <- function(sample_storage_type, filters = NULL, format = NULL, da dbmap$state <- "State" dbmap$status <- "Status" + if (include_internal_sample_id) { ## Do date collection here because lubridate and purrr::map (used by dplyr sql backend) is not cooperating diff --git a/README.md b/README.md index 9257ac7d..de3574dc 100644 --- a/README.md +++ b/README.md @@ -31,7 +31,7 @@ A docker image for sampleDB can be pulled from [DockerHub](https://hub.docker.co To pull from DockerHub, run the command below: ```bash -docker pull eppicenter/sampledb:v2.0.0 +docker pull eppicenter/sampledb:v2.1.0 ``` ##### Option 2: Build the image @@ -39,7 +39,7 @@ docker pull eppicenter/sampledb:v2.0.0 You can build the image instead of pulling from DockerHub. To do so, run the following command: ```bash -docker build -t eppicenter/sampledb:v2.0.0 . +docker build -t eppicenter/sampledb:v2.1.0 . ``` #### 3. Create your container @@ -47,7 +47,7 @@ docker build -t eppicenter/sampledb:v2.0.0 . This is the final step. The host `localhost` and port `8080` will be used to access the application within the container, and all volumes needed to run the container are passed in on the command line. Notice that the sampleDB database volume is also include in the list of volumes. ```bash -docker run -d -p 8080:3838 -v /srv/shinyapps/:/srv/shiny-server -v /srv/shinylog/:/var/log/shiny-server -v sampledb_database:/usr/local/share/sampleDB --restart unless-stopped --name sampleDB eppicenter/sampledb:v2.0.0 +docker run -d -p 8080:3838 -v /srv/shinyapps/:/srv/shiny-server -v /srv/shinylog/:/var/log/shiny-server -v sampledb_database:/usr/local/share/sampleDB --restart unless-stopped --name sampleDB eppicenter/sampledb:v2.1.0 ``` #### 4. Access sampleDB @@ -79,7 +79,7 @@ To install sampleDB at the site level, you can run the command below using an R ```R remotes::install_github( "https://github.com/EPPIcenter/sampleDB-rpackage", - ref = "v2.0.0", + ref = "v2.1.0", lib = .libPaths()[1] ) ``` @@ -93,7 +93,7 @@ For a local install, the below command is sufficient within a regular RStudio or ```R remotes::install_github( "https://github.com/EPPIcenter/sampleDB-rpackage", - ref = "v2.0.0" + ref = "v2.1.0" ) ``` diff --git a/inst/sampleDB/server_helpers/AppSearchDelArchSamples.R b/inst/sampleDB/server_helpers/AppSearchDelArchSamples.R index 23746f5b..ac0a0e76 100644 --- a/inst/sampleDB/server_helpers/AppSearchDelArchSamples.R +++ b/inst/sampleDB/server_helpers/AppSearchDelArchSamples.R @@ -3,8 +3,15 @@ library(RSQLite) library(DBI) library(stringr) -SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent){ +SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent) { + ## Set defaults + # updateSelectInput(session, "DelArchSearchByState", selected = "Active") + # updateSelectInput(session, "DelArchSearchByStatus", selected = "In Use") + +# Reactive to store retrieved database data + all_data <- reactiveVal(NULL) + # get DelArchSearch ui elements rv <- reactiveValues(user_file = NULL, error = NULL, search_table = NULL, filters = NULL, dbmap = NULL, operation = NULL, filtered_sample_container_ids = NULL) @@ -44,111 +51,66 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent rv$error <- NULL }) - observeEvent(input$DelArchSearchBySampleType, { - message("Reloading DelArchSearch table...") - - dbmap <- list() - format <- "na" # this could be modified - - # if (input$DelArchSearchBySampleType == "all") { - # dbmap$sample_type <- "Sample Storage Type" - # } - - ## Micronix - if (input$DelArchSearchBySampleType == 1 && format == "na") { - dbmap$barcode <- "Barcode" - dbmap$position <- "Position" - } + # Initial data retrieval using default values + # observe({ + # initial_data <- SearchSamples(input$DelArchSearchBySampleType, filters = list(state = "Active", status = "In Use")) + + # # Update the reactiveVal with the initial data + # all_data(initial_data) + # }) - ## Cryovial - else if (input$DelArchSearchBySampleType == 2) { - dbmap$barcode <- "Barcode" - dbmap$position <- "Position" + filtered_data <- reactive({ + + # Build the filters + filters <- list( + manifest = input$DelArchSearchByManifest, + short_code = input$DelArchSearchByStudy, + study_subject = input$DelArchSearchBySubjectUID, + specimen_type = input$DelArchSearchBySpecimenType, + collection_date = list( + date.from = input$DelArchdateRange[1], + date.to = input$DelArchdateRange[2] + ), + location = list( + name = input$DelArchSearchByLocation, + level_I = input$DelArchSearchByLevelI, + level_II = input$DelArchSearchByLevelII + ), + state = input$DelArchSearchByState, + status = input$DelArchSearchByStatus + ) - ## DBS - } else if (input$DelArchSearchBySampleType == 3) { - dbmap$position <- "Position" - } else { - dbmap$barcode <- "Barcode" - dbmap$position <- "Position" - } + # Remove empty or NULL values + filters <- purrr::map(filters, ~purrr::discard(.x, function(x) is.null(x) | "" %in% x | length(x) == 0)) + filters <- purrr::discard(filters, ~is.null(.x) | length(.x) == 0) - if (input$DelArchSearchBySampleType == 3) { - dbmap$`0.05` <- "0.05" - dbmap$`0.1` <- "0.1" - dbmap$`1` <- "1" - dbmap$`10` <- "10" - dbmap$`100` <- "100" - dbmap$`1k` <- "1k" - dbmap$`10k` <- "10k" - dbmap$strain <- "Strain" - } + # Obtain the search results + results <- SearchSamples(input$DelArchSearchBySampleType, filters = filters, include_internal_sample_id = TRUE) - dbmap$short_code <- "Study Code" - dbmap$study_subject <- "Study Subject" - dbmap$specimen_type <- "Specimen Type" - dbmap$collection_date <- "Collection Date" - - dbmap$name <- "Location" - if (input$DelArchSearchBySampleType == 1) { - dbmap$name <- "Freezer Name" - dbmap$level_I <- "Shelf Name" - dbmap$level_II <- "Basket Name" - dbmap$manifest <- "Plate Name" - dbmap$manifest_barcode <- "Plate Barcode" - } else if (input$DelArchSearchBySampleType == 2) { - dbmap$name <- "Freezer Name" - dbmap$level_I <- "Rack Number" - dbmap$level_II <- "Rack Position" - dbmap$manifest <- "Box Name" - dbmap$manifest_barcode <- "Box Barcode" - } else if (input$DelArchSearchBySampleType == 3) { - dbmap$name <- "Freezer Name" - dbmap$level_I <- "Rack Number" - dbmap$level_II <- "Rack Position" - dbmap$manifest <- "Container Label" - dbmap$manifest_barcode <- "Paper Barcode" + # Prepare data for reactable + if (!is.null(results)) { + results } else { - # Defaults - dbmap$name <- "Location" - dbmap$level_I <- "Level I" - dbmap$level_II <- "Level II" - dbmap$manifest <- "Manifest Name" - dbmap$manifest_barcode <- "Manifest Barcode" + tibble::tibble() } + }) %>% debounce(500) # 500ms delay - dbmap$comment <- "Comment" - dbmap$status <- "Status" - - rv$dbmap <- dbmap - filters <- purrr::discard(rv$filters[!names(rv$filters) %in% c("location", "collection_date")], function(x) is.null(x) | "" %in% x | length(x) == 0) - rv$search_table <- SearchSamples(input$DelArchSearchBySampleType, filters = filters, include_internal_sample_id = TRUE) - - .ResetDelArchInputs(session, input, rv$search_table) - }) observe({ output$DelArchSearchResultsTable <- renderReactable({ - rt = NULL - search_table = NULL - if (!is.null(rv$search_table)) { - search_table = rv$search_table %>% select(names(rv$dbmap)) - colnames(search_table) <- unname(rv$dbmap) - } else { - search_table = as.data.frame(matrix(ncol=length(rv$dbmap), nrow=0)) - colnames(search_table) <- unname(rv$dbmap) - } - - rt <- reactable( + # Get filtered data from our reactive + search_table <- filtered_data() %>% select(-c(`Sample ID`)) + + reactable( search_table, defaultColDef = colDef(minWidth = 95, html = TRUE, sortable = TRUE, resizable = FALSE, na = "-", align = "center"), searchable = TRUE, selection = "multiple", onClick = "select", columns = list( - .selection = colDef( - headerStyle = list(pointerEvents = "none") - ) + .selection = colDef( + headerStyle = list(pointerEvents = "none") + ) ), striped = TRUE, showPageSizeOptions = TRUE, @@ -162,53 +124,12 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent rowSelectedStyle = list(backgroundColor = '#aafaff', boxShadow = 'inset 2px 0 0 0 #ffa62d') ) ) - - return(rt) }) - - rv$filters <- list( - manifest = input$DelArchSearchByManifest, - short_code = input$DelArchSearchByStudy, - study_subject = input$DelArchSearchBySubjectUID, - specimen_type = input$DelArchSearchBySpecimenType, - collection_date = list( - date.from = input$DelArchdateRange[1], - date.to = input$DelArchdateRange[2] - ), - location = list( - name = input$DelArchSearchByLocation, - level_I = input$DelArchSearchByLevelI, - level_II = input$DelArchSearchByLevelII - ), - state = input$DelArchSearchByState, - status = input$DelArchSearchByStatus - ) - }) - - observe({ - filters <- purrr::discard(rv$filters[!names(rv$filters) %in% c("location", "collection_date")], function(x) is.null(x) | "" %in% x | length(x) == 0) - filters$location <- purrr::discard(rv$filters$location, function(x) is.null(x) | "" %in% x | length(x) == 0) - filters$location <- if (length(filters$location) > 0) filters$location - - filters$collection_date <- purrr::discard(rv$filters$collection_date, function(x) is.null(x) | "" %in% x | length(x) == 0) - filters$collection_date <- if (length(filters$collection_date) > 0) filters$collection_date - - rv$search_table <- SearchSamples(input$DelArchSearchBySampleType, filters = filters, include_internal_sample_id = TRUE) - }) - observe({ - - filtered=NULL - if (!is.null(rv$search_table)) { - filtered = rv$search_table %>% select(names(rv$dbmap)) - colnames(filtered) <- unname(rv$dbmap) - } else { - filtered = as.data.frame(matrix(ncol=length(rv$dbmap), nrow=0)) - colnames(filtered) <- unname(rv$dbmap) - } - - updateReactable("DelArchSearchResultsTable", data = filtered) + # Use the filtered data to update selections + observeEvent(input$DelArchSearchBySampleType, { + UpdateSelections(session, input, TRUE) }) ### DelArchSearch by file @@ -283,38 +204,11 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent observeEvent(input$DelArchSearchReset, ignoreInit = TRUE, { - message("Reset") updateRadioButtons(session, selected = "individual", "SubjectUIDDelArchSearchType", label = NULL, choices = list("Single Study Subject" = "individual", "Multiple Study Subjects" = "multiple")) updateDateRangeInput(session, "DelArchdateRange", start = NA, end = NA) %>% suppressWarnings() - .ResetDelArchInputs(session, input, rv$search_table) - - ## these should be freed explicitly - rv$filters <- list( - manifest = NULL, - short_code = NULL, - study_subject = NULL, - specimen_type = NULL, - collection_date = list( - date.from = NA, - date.to = NA - ), - location = list( - name = input$DelArchSearchByLocation, - level_I = input$DelArchSearchByLevelI, - level_II = input$DelArchSearchByLevelII - ), - state = Global$DefaultStateDelArchSearchTerm, - status = Global$DefaultStatusDelArchSearchTerm - ) - - # DelArchSearch file - rv$filters$state <- "Active" - rv$filters$status <- "In Use" - - rv$user_file <- NULL - rv$filtered_sample_container_ids = NULL + UpdateSelections(session, input, FALSE) }) ### Smart Dropdowns @@ -404,62 +298,89 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent paste('data-', Sys.Date(), '.csv', sep='') }, content = function(con) { - write.csv(rv$search_table, con, row.names = FALSE, quote = FALSE) + write.csv(filtered_data(), con, row.names = FALSE, quote = FALSE) } ) }) - observeEvent(dbUpdateEvent(), { + observeEvent(dbUpdateEvent(), ignoreInit = TRUE, { + con <- DBI::dbConnect(RSQLite::SQLite(), Sys.getenv("SDB_PATH")) - manifest <- switch( + manifest_name <- switch( input$DelArchSearchBySampleType, "1" = "micronix_plate", "2" = "cryovial_box", - "3" = "dbs_paper" + "3" = "dbs_paper", + NULL ) - manifests = c() - if (is.null(manifest)) { - manifests = c(manifests, unique(tbl(con, "micronix_plate") %>% pull(name))) - manifests = c(manifests, unique(tbl(con, "cryovial_box") %>% pull(name))) - manifests = c(manifests, unique(tbl(con, "dbs_paper") %>% pull(name))) + # Fetch manifests based on the manifest_name or get all if manifest_name is NULL + manifests <- if (is.null(manifest_name)) { + unique(c( + tbl(con, "micronix_plate") %>% pull(name), + tbl(con, "cryovial_box") %>% pull(name), + tbl(con, "dbs_paper") %>% pull(name) + )) } else { - manifests = unique(tbl(con, manifest) %>% pull(name)) + unique(tbl(con, manifest_name) %>% pull(name)) } - short_codes = unique(tbl(con, "study") %>% pull(short_code)) - study_subjects = unique(tbl(con, "study_subject") %>% pull(name)) - specimen_types = unique(tbl(con, "specimen_type") %>% pull(name)) - locations = unique(tbl(con, "location") %>% pull(name)) + # Fetch other data from database in a single set of calls + data_lists <- list( + short_codes = tbl(con, "study") %>% pull(short_code), + study_subjects = tbl(con, "study_subject") %>% pull(name), + specimen_types = tbl(con, "specimen_type") %>% pull(name), + locations = tbl(con, "location") %>% pull(name) + ) + # Close the database connection + dbDisconnect(con) + + # Update the select inputs updateSelectizeInput( - session, - "DelArchSearchByManifest", + session, "DelArchSearchByManifest", label = switch( - input$DelArchSearchBySampleType, - "1" = "Plate Name", - "2" = "Box Name", - "3" = "Paper Name", - "all" = "All Containers" + input$DelArchSearchBySampleType, + "1" = "Plate Name", + "2" = "Box Name", + "3" = "Paper Name", + "all" = "All Containers" ), - selected = FALSE, choices = manifests, + selected = ifelse(input$DelArchSearchByManifest %in% manifests, input$DelArchSearchByManifest, ""), server = TRUE ) - updateSelectizeInput(session, "DelArchSearchByStudy", "Study", choices = short_codes, selected = input$DelArchSearchByStudy, server = TRUE) - updateSelectizeInput(session, "DelArchSearchBySubjectUID", "Study Subject", selected = input$DelArchSearchBySubjectUID, choices = study_subjects, server = TRUE) - updateSelectizeInput(session, "DelArchSearchBySpecimenType", "Specimen Type", selected = input$DelArchSearchBySpecimenType, choices = specimen_types, server = TRUE) - updateSelectizeInput(session, "DelArchSearchByLocation", "Storage Location", selected = input$DelArchSearchByLocation, choices = locations, server = TRUE) + # Use a mapping to streamline the updateSelectizeInput calls + input_mapping <- list( + DelArchSearchByStudy = list(name = "Study", choices = data_lists$short_codes), + DelArchSearchBySubjectUID = list(name = "Study Subject", choices = data_lists$study_subjects), + DelArchSearchBySpecimenType = list(name = "Specimen Type", choices = data_lists$specimen_types), + DelArchSearchByLocation = list(name = "Storage Location", choices = data_lists$locations) + ) - dbDisconnect(con) - }) + for (input_id in names(input_mapping)) { + current_input_value <- input[[input_id]] + valid_choices <- input_mapping[[input_id]]$choices + + selected_value <- "" + if(!is.null(current_input_value) && current_input_value %in% valid_choices) { + selected_value <- current_input_value + } + updateSelectizeInput( + session, input_id, + input_mapping[[input_id]]$name, + choices = valid_choices, + selected = selected_value, + server = TRUE + ) + } + }) - ## the code above is basically copy and pasted from the search panel ###### Delarch specific functionality @@ -467,15 +388,11 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent observeEvent(input$ArchiveAction, ignoreInit = TRUE, { - user.filtered.rows = rv$search_table + user.filtered.rows = filtered_data() user.selected.rows = user.filtered.rows[selected(), ] - rt.select = names(rv$dbmap[names(rv$dbmap) %in% colnames(user.selected.rows)]) - user.selected.rows.select = user.selected.rows %>% select(all_of(rt.select)) - colnames(user.selected.rows.select) <- unname(rv$dbmap) - rt <- reactable( - user.selected.rows.select, + user.selected.rows, defaultColDef = colDef( minWidth = 95, html = TRUE, @@ -496,12 +413,14 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent size = "l", tags$em("Please review the following fields and your selected samples below.", style = "color: grey;font-size: 18px;"), hr(), - fluidRow( column(width = 6, selectizeInput("DelArchStatus", tags$strong("Status:"), choices = c("", RSQLite::dbGetQuery(con, "SELECT * FROM view_archive_statuses") %>% pull(name)), width = '75%')), - column(width = 6, tags$p("Please enter a status for the samples you selected for", tags$strong("archival"), ". This is a", tags$strong("required"), "field, and is used to indicate why the sample is no longer", tags$em("In Use"), ".")) + fluidRow( + column(width = 6, selectizeInput("DelArchStatus", tags$strong("Status:"), choices = c("", RSQLite::dbGetQuery(con, "SELECT * FROM view_archive_statuses") %>% pull(name)), width = '75%')), + column(width = 6, tags$p("Please enter a status for the samples you selected for", tags$strong("archival"), ". This is a", tags$strong("required"), "field, and is used to indicate why the sample is no longer", tags$em("In Use"), ".")) ), hr(), - fluidRow( column(width = 6, textInput(label = tags$strong("Comment:"), inputId = "DelArchComment", width = '75%')), - column(width = 6, tags$p("You may", tags$em("optionally"), "add a comment to further annotate why this sample is archived")) + fluidRow( + column(width = 6, textInput(label = tags$strong("Comment:"), inputId = "DelArchComment", width = '75%')), + column(width = 6, tags$p("You may", tags$em("optionally"), "add a comment to further annotate why this sample is archived")) ), tags$hr(), tags$p("Please review your selected samples below before submitting. You may cancel by selecting", tags$em("Dismiss"), "below or by clicking outside of the dialog box."), @@ -532,13 +451,13 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent }) observeEvent(input$Archive, ignoreInit = TRUE, { - message(sprintf("DelArch action: %s", "archive")) shinyjs::disable("Archive") showNotification("Working...", id = "ArchDelNotification", type = "message", action = NULL, duration = 5, closeButton = FALSE) - user.filtered.rows = rv$search_table + user.filtered.rows = filtered_data() user.selected.rows = user.filtered.rows[selected(), ] + user.selected.rows$storage_container_id <- user.selected.rows$`Sample ID` ArchiveAndDeleteSamples( operation = "archive", @@ -548,38 +467,29 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent verification = FALSE ) - database <- file.path(Sys.getenv("SDB_PATH")) - - updated_values <- rv$search_table %>% - select(storage_container_id) %>% - filter(storage_container_id %in% user.selected.rows$storage_container_id) %>% - inner_join(CheckTable(database = database, table = "storage_container"), by = c("storage_container_id" = "id")) %>% - inner_join(CheckTable(database = database, table = "state") %>% dplyr::rename(state = name), by = c("state_id" = "id")) %>% - inner_join(CheckTable(database = database, table = "status") %>% dplyr::rename(status = name), by = c("status_id" = "id")) - - rv$search_table <- rv$search_table %>% - mutate( - # State = as.factor(replace(as.character(State), `Sample ID` %in% updated_values$`Sample ID`, updated_values$State)), - position = as.factor(replace(as.character(position), storage_container_id %in% updated_values$storage_container_id, rep(NA, length(updated_values$storage_container_id)))), - status = as.factor(replace(as.character(status), storage_container_id %in% updated_values$storage_container_id, updated_values$status)), - comment = as.factor(replace(as.character(comment), storage_container_id %in% updated_values$storage_container_id, updated_values$comment)) - ) - removeNotification(id = "ArchDelNotification") removeModal() + + # Get the filtered data + updated_data <- user.filtered.rows + + # Remove the selected rows from the filtered data + updated_data <- updated_data[!updated_data$`Sample ID` %in% user.selected.rows$`Sample ID`,] + + # Update the reactable table + updateReactable( + outputId = "DelArchSearchResultsTable", + data = updated_data + ) }) observeEvent(input$DeleteAction, ignoreInit = TRUE, { - user.filtered.rows = rv$search_table + user.filtered.rows = filtered_data() user.selected.rows = user.filtered.rows[selected(), ] - rt.select = names(rv$dbmap[names(rv$dbmap) %in% colnames(user.selected.rows)]) - user.selected.rows.select = user.selected.rows %>% select(all_of(rt.select)) - colnames(user.selected.rows.select) <- unname(rv$dbmap) - rt <- reactable( - user.selected.rows.select, + user.selected.rows, defaultColDef = colDef( minWidth = 95, html = TRUE, @@ -613,8 +523,9 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent shinyjs::disable("Delete") showNotification("Working...", id = "ArchDelNotification", type = "message", action = NULL, duration = 5, closeButton = FALSE) - user.selected.rows = rv$search_table - user.selected.rows = user.selected.rows[selected(), ] + user.filtered.rows = filtered_data() + user.selected.rows = user.filtered.rows[selected(), ] + user.selected.rows$storage_container_id <- user.selected.rows$`Sample ID` ArchiveAndDeleteSamples( operation = "delete", @@ -624,18 +535,21 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent verification = FALSE ) - user.filtered.rows = rv$search_table - user.selected.rows = user.filtered.rows[selected(), ] - - rv$search_table <- rv$search_table[!rv$search_table$storage_container_id %in% user.selected.rows$storage_container_id, ] - if (nrow(rv$search_table) == 0) { - rv$search_table <- NULL - } - removeNotification(id = "ArchDelNotification") removeModal() - }) + # Get the filtered data + updated_data <- user.filtered.rows + + # Remove the selected rows from the filtered data + updated_data <- updated_data[!updated_data$`Sample ID` %in% user.selected.rows$`Sample ID`,] + + # Update the reactable table + updateReactable( + outputId = "DelArchSearchResultsTable", + data = updated_data + ) + }) observe({ output$DelArchDownloadSearchData <- downloadHandler( @@ -643,100 +557,67 @@ SearchDelArchSamples <- function(session, input, database, output, dbUpdateEvent paste('data-', Sys.Date(), '.csv', sep='') }, content = function(con) { - user.filtered.rows = rv$search_table + user.filtered.rows = filtered_data() user.selected.rows <- if (length(selected() > 0)) user.filtered.rows[selected(), ] else user.filtered.rows - - rt.select = names(rv$dbmap[names(rv$dbmap) %in% colnames(user.selected.rows)]) - user.selected.rows.select = user.selected.rows %>% select(all_of(rt.select)) - colnames(user.selected.rows.select) <- unname(rv$dbmap) - - write.csv( - user.selected.rows.select, - con, row.names = FALSE, quote = FALSE - ) + write.csv(user.selected.rows, con, row.names = FALSE, quote = FALSE) } ) }) - } - -.ResetDelArchInputs <- function(session, input, search_table) { - # if (input$SearchBySampleType == "all") { - # df = search_table %>% select(sample_type, manifest) %>% distinct() - # manifests = split(df$manifest, df$sample_type) - - # df = search_table %>% select(sample_type, short_code) %>% distinct() - # short_codes = split(df$short_code, df$sample_type) - - # df = search_table %>% select(sample_type, study_subject) %>% distinct() - # study_subjects = split(df$study_subject, df$sample_type) - - # df = search_table %>% select(sample_type, specimen_type) %>% distinct() - # specimen_types = split(df$specimen_type, df$sample_type) - - # df = search_table %>% select(sample_type, name) %>% distinct() - # locations = split(df$name, df$sample_type) - - # } - - # note there's a weird race condition that needs to be worked out first - # if (TRUE) { - # manifests = unique(search_table$manifest) - # short_codes = unique(search_table$short_code) - # study_subjects = unique(search_table$study_subject) - # specimen_types = unique(search_table$specimen_type) - # locations = unique(search_table$name) - # } - +UpdateSelections <- function(session, input, keepCurrentSelection = FALSE) { + con <- DBI::dbConnect(RSQLite::SQLite(), Sys.getenv("SDB_PATH")) - - manifest <- switch( - input$DelArchSearchBySampleType, - "1" = "micronix_plate", - "2" = "cryovial_box", - "3" = "dbs_paper" + + manifest_types <- list( + "1" = list(name = "micronix_plate", label = "Plate Name"), + "2" = list(name = "cryovial_box", label = "Box Name"), + "3" = list(name = "dbs_paper", label = "Paper Name") ) - - manifests = c() - if (is.null(manifest)) { - manifests = c(manifests, unique(tbl(con, "micronix_plate") %>% pull(name))) - manifests = c(manifests, unique(tbl(con, "cryovial_box") %>% pull(name))) - manifests = c(manifests, unique(tbl(con, "dbs_paper") %>% pull(name))) + + manifests <- if (is.null(manifest_types[[input$DelArchSearchBySampleType]])) { + c(unique(tbl(con, "micronix_plate") %>% pull(name)), + unique(tbl(con, "cryovial_box") %>% pull(name)), + unique(tbl(con, "dbs_paper") %>% pull(name))) } else { - manifests = unique(tbl(con, manifest) %>% pull(name)) + unique(tbl(con, manifest_types[[input$DelArchSearchBySampleType]]$name) %>% pull(name)) } - - short_codes = unique(tbl(con, "study") %>% pull(short_code)) - study_subjects = unique(tbl(con, "study_subject") %>% pull(name)) - specimen_types = unique(tbl(con, "specimen_type") %>% pull(name)) - locations = unique(tbl(con, "location") %>% pull(name)) - - updateSelectizeInput( - session, - "DelArchSearchByManifest", - label = switch( - input$DelArchSearchBySampleType, - "1" = "Plate Name", - "2" = "Box Name", - "3" = "Paper Name", - "all" = "All Containers" - ), - selected = FALSE, - choices = manifests, - server = TRUE + + choices_list <- list( + DelArchSearchByManifest = manifests, + DelArchSearchByStudy = unique(tbl(con, "study") %>% pull(short_code)), + DelArchSearchBySubjectUID = unique(tbl(con, "study_subject") %>% pull(name)), + DelArchSearchBySpecimenType = unique(tbl(con, "specimen_type") %>% pull(name)), + DelArchSearchByLocation = unique(tbl(con, "location") %>% pull(name)) ) - - updateSelectizeInput(session, "DelArchSearchByStudy", "Study", choices = short_codes, selected = FALSE, server = TRUE) - updateSelectizeInput(session, "DelArchSearchBySubjectUID", "Study Subject", choices = study_subjects, selected = FALSE, server = TRUE) - updateSelectizeInput(session, "DelArchSearchBySpecimenType", "Specimen Type", choices = specimen_types, selected = FALSE, server = TRUE) - updateSelectizeInput(session, "DelArchSearchByLocation", "Storage Location", choices = locations, selected = FALSE, server = TRUE) - updateSelectizeInput(session, "DelArchSearchByState", "State", choices = DBI::dbReadTable(con, "state")$name, selected = "Active") - updateSelectizeInput(session, "DelArchSearchByStatus", "Status", choices = c("In Use"), selected = "In Use") - - dbDisconnect(con) - + + labels_list <- list( + DelArchSearchByManifest = manifest_types[[input$DelArchSearchBySampleType]]$label %||% "All Containers", + DelArchSearchByStudy = "Study", + DelArchSearchBySubjectUID = "Study Subject", + DelArchSearchBySpecimenType = "Specimen Type", + DelArchSearchByLocation = "Storage Location" + ) + + sapply(names(choices_list), function(input_name) { + # Adjust the selected argument based on keepCurrentSelection parameter + current_selected <- if (keepCurrentSelection) input[[input_name]] else FALSE + + updateSelectizeInput( + session, + input_name, + label = labels_list[[input_name]], + choices = choices_list[[input_name]], + selected = current_selected, + server = TRUE + ) + }) + + DBI::dbDisconnect(con) + shinyjs::reset("DelArchSearchByBarcode") shinyjs::reset("DelArchSearchBySubjectUIDFile") -} + updateSelectInput(session, "DelArchSearchByState", selected = "Active") + updateSelectInput(session, "DelArchSearchByStatus", selected = "In Use") +}