Nothing
#' App server
#'
#' Create the server-side component of the dccvalidator Shiny app.
#'
#' @import shiny
#' @import shinydashboard
#' @param input Shiny input
#' @param output Shiny output
#' @param session Shiny session
#' @return none
#' @export
#' @examples
#' \dontrun{
#' shinyApp(ui = app_ui, server = app_server)
#' }
app_server <- function(input, output, session) {
syn <- synapse$Synapse()
## Initial titles for report boxes
callModule(results_boxes_server, "Validation Results", results = NULL)
session$sendCustomMessage(type = "readCookie", message = list())
## Show message if user is not logged in to synapse
unauthorized <- observeEvent(input$authorized, {
showModal(
modalDialog(
title = "Not logged in",
HTML("You must log in to <a target=\"_blank\" href=\"https://www.synapse.org/\">Synapse</a> to use this application. Please log in, and then refresh this page.") # nolint
)
)
})
observeEvent(input$cookie, {
is_logged_in <- FALSE
tryCatch({
syn$login(sessionToken = input$cookie)
is_logged_in <- TRUE
}, error = function(err) {
showModal(
modalDialog(
title = "Login error",
HTML("There was an error with the login process. Please refresh your Synapse session by logging out of and back in to <a target=\"_blank\" href=\"https://www.synapse.org/\">Synapse</a>. Then refresh this page to use the application."), # nolint
footer = NULL
)
)
})
req(is_logged_in)
## Check if user is in AMP-AD Consortium team (needed in order to create
## folder at the next step), and if they are a certified user.
user <- syn$getUserProfile()
membership <- check_team_membership(
teams = config::get("teams"),
user = user,
syn = syn
)
certified <- check_certified_user(user$ownerId, syn = syn)
report_unsatisfied_requirements(membership, certified, syn = syn)
## If user is a member of the team(s), create folder to save files and
## enable inputs
if (inherits(membership, "check_pass") &
inherits(certified, "check_pass")) {
created_folder <- try(
create_folder(
parent = config::get("parent"),
name = user$userName,
synapseclient = synapse,
syn = syn
)
)
study_name <- callModule(
get_study_server,
"study",
study_table_id = reactive(config::get("study_table")),
syn = syn
)
inputs_to_enable <- c(
"indiv_meta",
"biosp_meta",
"assay_meta",
"manifest",
"species",
"assay_name",
"validate_btn"
)
purrr::walk(inputs_to_enable, function(x) shinyjs::enable(x))
# Documentation server needs created_folder to run correctly
callModule(
upload_documents_server,
"documentation",
parent_folder = reactive(created_folder),
study_table_id = reactive(config::get("study_table")),
synapseclient = synapse,
syn = syn
)
}
## If drosophila species checked, reset fileInput
observeEvent(input$species, {
if (input$species == "drosophila") {
shinyjs::reset("indiv_meta")
files$indiv <- NULL
}
})
## Download annotation definitions
annots <- purrr::map_dfr(
config::get("annotations_table"),
get_synapse_annotations,
syn = syn
)
## Store files in separate variable to be able to reset inputs to NULL
files <- reactiveValues(
indiv = NULL,
manifest = NULL,
biosp = NULL,
assay = NULL
)
observeEvent(input$manifest, {
files$manifest <- input$manifest
})
observeEvent(input$indiv_meta, {
files$indiv <- input$indiv_meta
})
observeEvent(input$biosp_meta, {
files$biosp <- input$biosp_meta
})
observeEvent(input$assay_meta, {
files$assay <- input$assay_meta
})
## Load metadata files into session
manifest <- reactive({
if (is.null(files$manifest)) {
return(NULL)
}
readr::read_tsv(files$manifest$datapath)
})
indiv <- reactive({
if (is.null(files$indiv)) {
return(NULL)
}
readr::read_csv(files$indiv$datapath)
})
biosp <- reactive({
if (is.null(files$biosp)) {
return(NULL)
}
readr::read_csv(files$biosp$datapath)
})
assay <- reactive({
if (is.null(files$assay)) {
return(NULL)
}
readr::read_csv(files$assay$datapath)
})
species_name <- reactive({
input$species
})
assay_name <- reactive({
input$assay_name
})
observeEvent(input$instructions, {
showModal(
modalDialog(
title = "Instructions",
# nolint start
instructions(
annots_link = config::get("annotations_link"),
templates_link = config::get("templates_link")
),
# nolint end
easyClose = TRUE
)
)
})
## Show validation results on clicking "validate"
## Require that the study name is given; give error if not
observeEvent(input$"validate_btn", {
with_busy_indicator_server("validate_btn", {
if (!is_name_valid(study_name())) {
stop("Please check that study name is entered and only contains: letters, numbers, spaces, underscores, hyphens, periods, plus signs, and parentheses.") # nolint
}
## Require at least one file input
validate(
need(
any(
!is.null(indiv()),
!is.null(biosp()),
!is.null(assay()),
!is.null(manifest())
),
message = "Please upload some data to validate"
),
need(
is.null(manifest()) ||
tolower(tools::file_ext(input$manifest$name)) != "csv",
"Manifest file must be .tsv or .txt, not .csv"
)
)
## Upload only the files that have been given
if (!is.null(indiv())) {
save_to_synapse(
files$indiv,
parent = created_folder,
annotations = list(
study = study_name(),
metadataType = "individual",
species = species_name()
),
synapseclient = synapse,
syn = syn
)
}
if (!is.null(biosp())) {
save_to_synapse(
files$biosp,
parent = created_folder,
annotations = list(
study = study_name(),
metadataType = "biospecimen",
species = species_name()
),
synapseclient = synapse,
syn = syn
)
}
if (!is.null(assay())) {
save_to_synapse(
files$assay,
parent = created_folder,
annotations = list(
study = study_name(),
metadataType = "assay",
assay = assay_name(),
species = species_name()
),
synapseclient = synapse,
syn = syn
)
}
if (!is.null(manifest())) {
save_to_synapse(
files$manifest,
parent = created_folder,
annotations = list(
study = study_name(),
metadataType = "manifest"
),
synapseclient = synapse,
syn = syn
)
}
## Load in data to table for validation checks
## If file name is NULL, pass in NA.
all_data <- tibble::tibble(
"metadataType" = c(
"manifest",
"individual",
"biospecimen",
"assay"
),
"name" = c(
files$manifest$name %||% NA,
files$indiv$name %||% NA,
files$biosp$name %||% NA,
files$assay$name %||% NA
),
"species" = species_name(),
"assay" = assay_name(),
"file_data" = c(
list(manifest()),
list(indiv()),
list(biosp()),
list(assay())
)
)
res <- check_all(all_data, annots, syn)
callModule(results_boxes_server, "Validation Results", res)
})
})
## Counts of individuals, specimens, and files
output$nindividuals <- renderValueBox({
valueBox(
length(
unique(
c(
indiv()$individualID,
biosp()$individualID,
manifest()$individualID
)
)
),
"Individuals",
icon = icon("users")
)
})
output$nspecimens <- renderValueBox({
valueBox(
length(
unique(
c(biosp()$specimenID, assay()$specimenID, manifest()$specimenID)
)
),
"Specimens",
icon = icon("vial")
)
})
output$ndatafiles <- renderValueBox({
valueBox(
length(
unique(
manifest()$path
)
),
"Data files in manifest",
icon = icon("file")
)
})
observe({
## Reactive list of data
vals <- reactive({
validate(
need(
any(
!is.null(indiv()),
!is.null(biosp()),
!is.null(assay()),
!is.null(manifest())
),
message = "Please upload some data to view a summary"
)
)
list(
"Individual metadata" = indiv(),
"Biospecimen metadata" = biosp(),
"Assay metadata" = assay(),
"Manifest file" = manifest()
)
})
callModule(
file_summary_server,
"file_summary",
vals
)
})
})
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.