From 9a82a0f3aeb40ba600ce60a1e73664c8ef8fa113 Mon Sep 17 00:00:00 2001 From: afwillia Date: Tue, 27 Feb 2024 10:12:18 -0800 Subject: [PATCH 1/8] Remove use_schema_label from model/submit. Add table_column_names and annotation_keys. --- R/schematic_rest_api.R | 20 +++- functions/dashboardFuns-api.R | 186 +++++++++++++++++++++++++++++++++ functions/schematic_rest_api.R | 87 +++++++++++---- 3 files changed, 267 insertions(+), 26 deletions(-) create mode 100644 functions/dashboardFuns-api.R diff --git a/R/schematic_rest_api.R b/R/schematic_rest_api.R index 794c1afa..88325840 100644 --- a/R/schematic_rest_api.R +++ b/R/schematic_rest_api.R @@ -180,10 +180,19 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", #' @returns TRUE if successful upload or validate errors if not. #' @export model_submit <- function(url="http://localhost:3001/v1/model/submit", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #notlint - data_type, dataset_id, restrict_rules=FALSE, access_token, json_str=NULL, asset_view, - use_schema_label=TRUE, manifest_record_type="table_and_file", file_name, - table_manipulation="replace", hide_blanks=FALSE) { + schema_url + data_type, + dataset_id, + restrict_rules=FALSE, + access_token, + json_str=NULL, + asset_view, + manifest_record_type="table_and_file", + file_name, + table_manipulation="replace", + hide_blanks=FALSE, + table_column_names="class_label", + annotation_keys="class_label") { req <- httr::POST(url, httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( @@ -193,9 +202,10 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", restrict_rules=restrict_rules, json_str=json_str, asset_view=asset_view, - use_schema_label=use_schema_label, manifest_record_type=manifest_record_type, table_manipulation=table_manipulation, + table_column_names=table_column_names, + annotation_keys=annotation_keys, hide_blanks=hide_blanks), body=list(file_name=httr::upload_file(file_name)) #body=list(file_name=file_name) diff --git a/functions/dashboardFuns-api.R b/functions/dashboardFuns-api.R new file mode 100644 index 00000000..db26c7ae --- /dev/null +++ b/functions/dashboardFuns-api.R @@ -0,0 +1,186 @@ +#' get all uploaded manifests based on provided folder list +#' +#' @param syn.store synapse storage object +#' @param datasets a list of folder syn Ids, named by folder names +#' @param ncores number of cpu to run parallelization +#' @return data frame that contains manifest essential information for dashboard +get_dataset_metadata <- function(syn.store, datasets, ncores = 1, access_token, fileview) { + # TODO: if the component could be retrieve directly from storage object: + # remove codes to download all manifests + # get data for all manifests within the specified datasets + #file_view <- syn.store$storageFileviewTable %>% + # either use branch that returns JSON or wait until it's available in devel + file_view <- get_asset_view_table(url = file.path(api_uri, "v1/storage/assets/tables"), access_token = access_token, + asset_view = fileview) + file_view <- file_view %>% + filter(name == "synapse_storage_manifest.csv" & parentId %in% datasets) + + manifest_info <- list() + modified_user <- list() + manifest_dfs <- list() + # return empty data frame if no manifest or no component in the manifest + metadata <- data.frame() + + lapply(file_view$parentId, function(dataset) { + # get manifest's synapse id(s) in each dataset folder + manifest_ids <- file_view$id[file_view$parentId == dataset] + + if (length(manifest_ids) > 0) { + # in case, multiple manifests exist in the same dataset + for (id in manifest_ids) { + #info <- syn$get(id) + info <- datacurator::synapse_get(id = id, auth = access_token) + manifest <- manifest_download( + url = file.path(api_uri, "v1/manifest/download"), + asset_view = fileview, + manifest_id = info$parentId, + as_json = TRUE + ) + + # refactor this not to write files but save in a object + #tmp_man <- tempfile() + info$Path <- NA_character_ + #write_csv(manifest, tmp_man) + manifest_dfs[[id]] <<- manifest + manifest_info <<- append(manifest_info, list(unlist(info))) + #user <- syn$getUserProfile(info["properties"]["modifiedBy"])["userName"] + user <- datacurator::synapse_user_profile(auth = access_token)[["userName"]] + modified_user <<- append(modified_user, user) + } + # manifest_info <- lapply(manifest_ids, function(x) datacurator::synapse_get(id = x, auth = access_token)) + # manifest_info <- bind_rows(manifest_info) + } + }) + + if (length(manifest_info) > 0) { + metadata <- parallel::mclapply(seq_along(manifest_info), function(i) { + info <- manifest_info[[i]] + # extract manifest essential information for dashboard + manifest_path <- info["Path"] + # See above - don't read from file, read from object + #manifest_df <- data.table::fread(manifest_path) + manifest_df <- manifest_dfs[[i]] + # keep all manifests used for validation, even if it has invalid component value + # if manifest doesn't have "Component" column, or empty, return NA for component + manifest_component <- ifelse("Component" %in% colnames(manifest_df) & nrow(manifest_df) > 0, + manifest_df$Component[1], NA_character_ + ) + metadata <- tibble( + SynapseID = info["id"], + Component = manifest_component, + CreatedOn = as.Date(info["createdOn"]), + ModifiedOn = as.Date(info["modifiedOn"]), + ModifiedUser = paste0("@", modified_user[[i]]), + Path = manifest_path, + Folder = names(datasets)[which(datasets == info["parentId"])], + FolderSynId = info["parentId"], + manifest = list(manifest_df) + ) + }, mc.cores = ncores) %>% bind_rows() + } + + return(metadata) +} + + +#' validate all manifests in the metadata of a dataset +#' +#' @param metadata output from \code{get_dataset_metadata}. +#' @param project.scope list of project ids used for cross-manifest validation +#' @return data frame contains required data types for tree plot +validate_metadata <- function(metadata, project.scope, access_token) { + stopifnot(is.list(project.scope)) + if (nrow(metadata) == 0) { + return(metadata) + } + lapply(seq_len(nrow(metadata)), function(i) { + manifest <- metadata[i, ] + # validate manifest, if no error, output is list() + # for invalid components, it will return NULL and relay as 'Out of Date', e.g.: + # "LungCancerTier3", "BreastCancerTier3", "ScRNA-seqAssay", "MolecularTest", "NaN", "" ... + validation_res <- manifest_validate(url = file.path(api_uri, "v1/model/validate"), + data_type = manifest$Component, + schema_url = Sys.getenv("DCA_MODEL_INPUT_DOWNLOAD_URL"), + json_str = jsonlite::toJSON(manifest$manifest), + access_token=access_token, + ) + #csv_file = manifest$Path) + # Wait until you can pass a JSON to manifest_validate + # clean validation res from schematicpy + clean_res <- validationResult(validation_res, manifest$Component, dashboard = TRUE) + data.frame( + Result = clean_res$result, + ErrorType = clean_res$error_type, + WarnMsg = if_else(length(clean_res$warning_msg) == 0, "Valid", paste(clean_res$warning_msg, collapse = "; ")) + ) + }) %>% + bind_rows() %>% + cbind(metadata, .) # expand metadata with validation results +} + +#' create a list of requirements for selected data type +#' +#' @param schema data type of selected data type or template. +#' @return list of requirements for \code{schema} or string of \code{schema} if no requirements found +get_schema_nodes <- function(schema, url = file.path(api_uri, "v1/model/component-requirements"), schema_url) { + requirement <- tryCatch( + model_component_requirements( + url = url, + schema_url = schema_url, + source_component = schema, + as_graph = TRUE + ), + error = function(err) list() + ) + + if (length(requirement) == 0) { + # return data type itself without name + return(as.character(schema)) + } else { + # return a list of requirements of the data type + return(list2Vector(requirement)) + } +} + + +#' create data frame of data type requirements for all manifests +#' +#' @param metadata output from \code{get_dataset_metadata}. +#' @return data frame of nodes contains source and target used for tree plot +get_metadata_nodes <- function(metadata, ncores = 1, schema_url = Sys.getenv("DCA_MODEL_INPUT_DOWNLOAD_URL"), url = file.path(api_uri, "v1/model/component-requirements")) { + if (nrow(metadata) == 0) { + return(data.frame(from = NA, to = NA, folder = NA, folderSynId = NA, nMiss = NA)) + } else { + metadata <- drop_na(metadata, "Component") + parallel::mclapply(seq_len(nrow(metadata)), function(i) { + manifest <- metadata[i, ] + # get all required data types + # nodes <- tryCatch( + # metadata_model$get_component_requirements(manifest$Component, as_graph = TRUE), + # error = function(err) list() + # ) %>% list2Vector() + nodes <- tryCatch(model_component_requirements( + url, + schema_url, + source_component = manifest$Component, + as_graph = TRUE + ), error = function(err) list()) %>% list2Vector() + + source <- as.character(nodes) + target <- names(nodes) + + # count how many requirements are missing in each dataset + n_miss <- sum(!union(target, source) %in% metadata$Component) + + # create data frame for tree plot + data.frame( + from = c(paste0("f:", manifest$Folder), source), + to = c(manifest$Component, target), + folder = c(manifest$Folder), + folder_id = c(manifest$FolderSynId), + n_miss = c(n_miss) + ) + }, mc.cores = ncores) %>% + bind_rows() + } +} diff --git a/functions/schematic_rest_api.R b/functions/schematic_rest_api.R index c2db54ad..88325840 100644 --- a/functions/schematic_rest_api.R +++ b/functions/schematic_rest_api.R @@ -21,8 +21,8 @@ check_success <- function(x){ manifest_download <- function(url = "http://localhost:3001/v1/manifest/download", access_token, asset_view, dataset_id, as_json=TRUE, new_manifest_name=NULL) { request <- httr::GET( url = url, + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query = list( - access_token = access_token, asset_view = asset_view, dataset_id = dataset_id, as_json = as_json, @@ -61,6 +61,7 @@ manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", strict_validation = FALSE) { req <- httr::GET(url, + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query = list( schema_url=schema_url, title=title, @@ -69,7 +70,6 @@ manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", dataset_id=dataset_id, asset_view=asset_view, output_format=output_format, - access_token = access_token, strict_validation = strict_validation )) @@ -115,12 +115,36 @@ manifest_populate <- function(url="http://localhost:3001/v1/manifest/populate", #' @export manifest_validate <- function(url="http://localhost:3001/v1/model/validate", schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #nolint - data_type, file_name, restrict_rules=FALSE) { + data_type, file_name, restrict_rules=FALSE, project_scope = NULL, + access_token, asset_view = NULL) { + + flattenbody <- function(x) { + # A form/query can only have one value per name, so take + # any values that contain vectors length >1 and + # split them up + # list(x=1:2, y="a") becomes list(x=1, x=2, y="a") + if (all(lengths(x)<=1)) return(x); + do.call("c", mapply(function(name, val) { + if (length(val)==1 || any(c("form_file", "form_data") %in% class(val))) { + x <- list(val) + names(x) <- name + x + } else { + x <- as.list(val) + names(x) <- rep(name, length(val)) + x + } + }, names(x), x, USE.NAMES = FALSE, SIMPLIFY = FALSE)) + } + req <- httr::POST(url, - query=list( + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), + query=flattenbody(list( schema_url=schema_url, data_type=data_type, - restrict_rules=restrict_rules), + restrict_rules=restrict_rules, + project_scope = project_scope, + asset_view = asset_view)), body=list(file_name=httr::upload_file(file_name)) ) @@ -156,23 +180,32 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", #' @returns TRUE if successful upload or validate errors if not. #' @export model_submit <- function(url="http://localhost:3001/v1/model/submit", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #notlint - data_type, dataset_id, restrict_rules=FALSE, access_token, json_str=NULL, asset_view, - use_schema_label=TRUE, manifest_record_type="table_and_file", file_name, - table_manipulation="replace", hide_blanks=FALSE) { + schema_url + data_type, + dataset_id, + restrict_rules=FALSE, + access_token, + json_str=NULL, + asset_view, + manifest_record_type="table_and_file", + file_name, + table_manipulation="replace", + hide_blanks=FALSE, + table_column_names="class_label", + annotation_keys="class_label") { req <- httr::POST(url, - #add_headers(Authorization=paste0("Bearer ", pat)), + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( schema_url=schema_url, data_type=data_type, dataset_id=dataset_id, - access_token=access_token, restrict_rules=restrict_rules, json_str=json_str, asset_view=asset_view, - use_schema_label=use_schema_label, manifest_record_type=manifest_record_type, table_manipulation=table_manipulation, + table_column_names=table_column_names, + annotation_keys=annotation_keys, hide_blanks=hide_blanks), body=list(file_name=httr::upload_file(file_name)) #body=list(file_name=file_name) @@ -230,11 +263,10 @@ storage_project_datasets <- function(url="http://localhost:3001/v1/storage/proje access_token) { req <- httr::GET(url, - #add_headers(Authorization=paste0("Bearer ", pat)), + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( asset_view=asset_view, - project_id=project_id, - access_token=access_token) + project_id=project_id) ) check_success(req) @@ -254,9 +286,9 @@ storage_projects <- function(url="http://localhost:3001/v1/storage/projects", access_token) { req <- httr::GET(url, + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query = list( - asset_view=asset_view, - access_token=access_token + asset_view=asset_view )) check_success(req) @@ -280,13 +312,12 @@ storage_dataset_files <- function(url="http://localhost:3001/v1/storage/dataset/ full_path=FALSE, access_token) { req <- httr::GET(url, - #add_headers(Authorization=paste0("Bearer ", pat)), + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( asset_view=asset_view, dataset_id=dataset_id, file_names=file_names, - full_path=full_path, - access_token=access_token)) + full_path=full_path)) check_success(req) httr::content(req) @@ -302,9 +333,9 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta access_token, asset_view, return_type="json") { req <- httr::GET(url, + httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( asset_view=asset_view, - access_token=access_token, return_type=return_type)) check_success(req) @@ -317,3 +348,17 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta } +#' @param url URL of schematic API endpoint +#' @param schema_url URL of data model +#' @param relationship Argument to schematic graph_by_edge_type +#' @export +#' @importFrom httr GET content +graph_by_edge_type <- function(url = "https://schematic-dev.api.sagebionetworks.org/v1/schemas/get/graph_by_edge_type", + schema_url, relationship = "requiresDependency") { + req <- httr::GET(url = url, + query = list( + schema_url = schema_url, + relationship = relationship + )) + httr::content(req) +} From 790429318233358940be840cd1c98615a6b620b7 Mon Sep 17 00:00:00 2001 From: afwillia Date: Tue, 27 Feb 2024 10:17:07 -0800 Subject: [PATCH 2/8] Remove use_schema_label from submit. Add table_column_names and annotation_keys. --- server.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/server.R b/server.R index 21177f24..6ef4cbc9 100644 --- a/server.R +++ b/server.R @@ -917,7 +917,8 @@ shinyServer(function(input, output, session) { .data_model <- data_model() .schema <- selected$schema() .asset_view <- selected$master_asset_view() - .submit_use_schema_labels <- dcc_config_react()$schematic$model_submit$use_schema_labels + .table_column_names <- dcc_config_react()$schematic$model_submit$table_column_names + .annotation_keys <- dcc_config_react()$schematic$model_submit$annotation_keys .table_manipulation <- dcc_config_react()$schematic$model_submit$table_manipulation .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules @@ -940,7 +941,8 @@ shinyServer(function(input, output, session) { restrict_rules = .restrict_rules, file_name = tmp_file_path, asset_view = .asset_view, - use_schema_label=.submit_use_schema_labels, + table_column_names = .table_column_names, + annotation_keys = .annotation_keys, manifest_record_type=.submit_manifest_record_type, table_manipulation=.table_manipulation, hide_blanks=.hide_blanks), @@ -962,7 +964,8 @@ shinyServer(function(input, output, session) { .data_model <- data_model() .schema <- selected$schema() .asset_view <- selected$master_asset_view() - .submit_use_schema_labels <- dcc_config_react()$schematic$model_submit$use_schema_labels + .table_column_names <- dcc_config_react()$schematic$model_submit$table_column_names + .annotation_keys <- dcc_config_react()$schematic$model_submit$annotation_keys .table_manipulation <- dcc_config_react()$schematic$model_submit$table_manipulation .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules @@ -984,7 +987,8 @@ shinyServer(function(input, output, session) { restrict_rules = .restrict_rules, file_name = tmp_file_path, asset_view = .asset_view, - use_schema_label=.submit_use_schema_labels, + table_column_names = .table_column_names, + annotation_keys = .annotation_keys, manifest_record_type=.submit_manifest_record_type, table_manipulation=.table_manipulation, hide_blanks=.hide_blanks), From 9fa733f5b082cadb9b9daf192a4ba95a93a9aa60 Mon Sep 17 00:00:00 2001 From: afwillia Date: Tue, 27 Feb 2024 10:21:54 -0800 Subject: [PATCH 3/8] add comma after schema_url in formals --- R/schematic_rest_api.R | 2 +- functions/schematic_rest_api.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/schematic_rest_api.R b/R/schematic_rest_api.R index 88325840..d905c0a1 100644 --- a/R/schematic_rest_api.R +++ b/R/schematic_rest_api.R @@ -180,7 +180,7 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", #' @returns TRUE if successful upload or validate errors if not. #' @export model_submit <- function(url="http://localhost:3001/v1/model/submit", - schema_url + schema_url, data_type, dataset_id, restrict_rules=FALSE, diff --git a/functions/schematic_rest_api.R b/functions/schematic_rest_api.R index 88325840..d905c0a1 100644 --- a/functions/schematic_rest_api.R +++ b/functions/schematic_rest_api.R @@ -180,7 +180,7 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", #' @returns TRUE if successful upload or validate errors if not. #' @export model_submit <- function(url="http://localhost:3001/v1/model/submit", - schema_url + schema_url, data_type, dataset_id, restrict_rules=FALSE, From e093d46c957834e734a4162f00bca6bbb9afffd6 Mon Sep 17 00:00:00 2001 From: afwillia Date: Tue, 27 Feb 2024 10:52:00 -0800 Subject: [PATCH 4/8] add data_model_labels to submit --- R/schematic_rest_api.R | 3 ++- functions/schematic_rest_api.R | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/R/schematic_rest_api.R b/R/schematic_rest_api.R index d905c0a1..22cee5ef 100644 --- a/R/schematic_rest_api.R +++ b/R/schematic_rest_api.R @@ -192,7 +192,8 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", table_manipulation="replace", hide_blanks=FALSE, table_column_names="class_label", - annotation_keys="class_label") { + annotation_keys="class_label", + data_model_labels="class_label") { req <- httr::POST(url, httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( diff --git a/functions/schematic_rest_api.R b/functions/schematic_rest_api.R index d905c0a1..22cee5ef 100644 --- a/functions/schematic_rest_api.R +++ b/functions/schematic_rest_api.R @@ -192,7 +192,8 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", table_manipulation="replace", hide_blanks=FALSE, table_column_names="class_label", - annotation_keys="class_label") { + annotation_keys="class_label", + data_model_labels="class_label") { req <- httr::POST(url, httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), query=list( From 850a642d5f8fdc668c0486fc81bcbb6d83a5f1fa Mon Sep 17 00:00:00 2001 From: afwillia Date: Tue, 27 Feb 2024 10:52:34 -0800 Subject: [PATCH 5/8] Add data_model_labels submiti --- server.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/server.R b/server.R index 6ef4cbc9..2e3c9168 100644 --- a/server.R +++ b/server.R @@ -919,6 +919,7 @@ shinyServer(function(input, output, session) { .asset_view <- selected$master_asset_view() .table_column_names <- dcc_config_react()$schematic$model_submit$table_column_names .annotation_keys <- dcc_config_react()$schematic$model_submit$annotation_keys + .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels .table_manipulation <- dcc_config_react()$schematic$model_submit$table_manipulation .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules @@ -945,6 +946,7 @@ shinyServer(function(input, output, session) { annotation_keys = .annotation_keys, manifest_record_type=.submit_manifest_record_type, table_manipulation=.table_manipulation, + data_model_labels = .data_model_labels, hide_blanks=.hide_blanks), "synXXXX - No data uploaded" ) @@ -966,6 +968,7 @@ shinyServer(function(input, output, session) { .asset_view <- selected$master_asset_view() .table_column_names <- dcc_config_react()$schematic$model_submit$table_column_names .annotation_keys <- dcc_config_react()$schematic$model_submit$annotation_keys + .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels .table_manipulation <- dcc_config_react()$schematic$model_submit$table_manipulation .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules @@ -991,6 +994,7 @@ shinyServer(function(input, output, session) { annotation_keys = .annotation_keys, manifest_record_type=.submit_manifest_record_type, table_manipulation=.table_manipulation, + data_model_labels = .data_model_labels, hide_blanks=.hide_blanks), "synXXXX - No data uploaded" ) From bbef876d56a29609c7b6f1566997cfcddfa7ab4e Mon Sep 17 00:00:00 2001 From: afwillia Date: Tue, 27 Feb 2024 11:07:16 -0800 Subject: [PATCH 6/8] Add data_model_labels to the rest of schematic endpoints --- R/schematic_rest_api.R | 59 +++++++++++++++++++++++----------- functions/schematic_rest_api.R | 59 +++++++++++++++++++++++----------- 2 files changed, 82 insertions(+), 36 deletions(-) diff --git a/R/schematic_rest_api.R b/R/schematic_rest_api.R index 22cee5ef..a3da09ac 100644 --- a/R/schematic_rest_api.R +++ b/R/schematic_rest_api.R @@ -54,11 +54,16 @@ manifest_download <- function(url = "http://localhost:3001/v1/manifest/download" #' @returns a URL to a google sheet #' @export manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #nolint - title, data_type, - use_annotations="false", dataset_id=NULL, - asset_view, output_format, access_token = NULL, - strict_validation = FALSE) { + schema_url, + title, + data_type, + use_annotations="false", + dataset_id=NULL, + asset_view, + output_format, + access_token = NULL, + strict_validation = FALSE, + data_model_labels = "class_label") { req <- httr::GET(url, httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), @@ -70,7 +75,8 @@ manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", dataset_id=dataset_id, asset_view=asset_view, output_format=output_format, - strict_validation = strict_validation + strict_validation = strict_validation, + data_model_labels = data_model_labels )) check_success(req) @@ -87,15 +93,20 @@ manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", #' @param csv_file Filepath of csv to validate #' @export manifest_populate <- function(url="http://localhost:3001/v1/manifest/populate", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #notlint - data_type, title, return_excel=FALSE, csv_file) { + schema_url, + data_type, + title, + return_excel=FALSE, + data_model_labels = "class_label", + csv_file) { req <- httr::POST(url, query=list( schema_url=schema_url, data_type=data_type, title=title, - return_excel=return_excel), + return_excel=return_excel, + data_model_labels=data_model_labels), body=list(csv_file=httr::upload_file(csv_file, type = "text/csv")) ) check_success(req) @@ -114,9 +125,14 @@ manifest_populate <- function(url="http://localhost:3001/v1/manifest/populate", #' @returns An empty list() if sucessfully validated. Or a list of errors. #' @export manifest_validate <- function(url="http://localhost:3001/v1/model/validate", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #nolint - data_type, file_name, restrict_rules=FALSE, project_scope = NULL, - access_token, asset_view = NULL) { + schema_url, + data_type, + file_name, + restrict_rules=FALSE, + project_scope = NULL, + access_token, + asset_view = NULL, + data_model_labels = "class_label") { flattenbody <- function(x) { # A form/query can only have one value per name, so take @@ -144,7 +160,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", data_type=data_type, restrict_rules=restrict_rules, project_scope = project_scope, - asset_view = asset_view)), + asset_view = asset_view, + data_model_labels = data_model_labels)), body=list(file_name=httr::upload_file(file_name)) ) @@ -226,14 +243,17 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", #' @returns A list of required components associated with the source component. #' @export model_component_requirements <- function(url="http://localhost:3001/v1/model/component-requirements", - schema_url, source_component, - as_graph = FALSE) { + schema_url, + source_component, + as_graph = FALSE, + data_model_labels = "class_label") { req <- httr::GET(url, query = list( schema_url = schema_url, source_component = source_component, - as_graph = as_graph + as_graph = as_graph, + data_model_labels = data_model_labels )) check_success(req) @@ -355,11 +375,14 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta #' @export #' @importFrom httr GET content graph_by_edge_type <- function(url = "https://schematic-dev.api.sagebionetworks.org/v1/schemas/get/graph_by_edge_type", - schema_url, relationship = "requiresDependency") { + schema_url, + relationship = "requiresDependency", + data_model_labels = "class_label") { req <- httr::GET(url = url, query = list( schema_url = schema_url, - relationship = relationship + relationship = relationship, + data_model_labels = data_model_labels )) httr::content(req) } diff --git a/functions/schematic_rest_api.R b/functions/schematic_rest_api.R index 22cee5ef..a3da09ac 100644 --- a/functions/schematic_rest_api.R +++ b/functions/schematic_rest_api.R @@ -54,11 +54,16 @@ manifest_download <- function(url = "http://localhost:3001/v1/manifest/download" #' @returns a URL to a google sheet #' @export manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #nolint - title, data_type, - use_annotations="false", dataset_id=NULL, - asset_view, output_format, access_token = NULL, - strict_validation = FALSE) { + schema_url, + title, + data_type, + use_annotations="false", + dataset_id=NULL, + asset_view, + output_format, + access_token = NULL, + strict_validation = FALSE, + data_model_labels = "class_label") { req <- httr::GET(url, httr::add_headers(Authorization = sprintf("Bearer %s", access_token)), @@ -70,7 +75,8 @@ manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", dataset_id=dataset_id, asset_view=asset_view, output_format=output_format, - strict_validation = strict_validation + strict_validation = strict_validation, + data_model_labels = data_model_labels )) check_success(req) @@ -87,15 +93,20 @@ manifest_generate <- function(url="http://localhost:3001/v1/manifest/generate", #' @param csv_file Filepath of csv to validate #' @export manifest_populate <- function(url="http://localhost:3001/v1/manifest/populate", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #notlint - data_type, title, return_excel=FALSE, csv_file) { + schema_url, + data_type, + title, + return_excel=FALSE, + data_model_labels = "class_label", + csv_file) { req <- httr::POST(url, query=list( schema_url=schema_url, data_type=data_type, title=title, - return_excel=return_excel), + return_excel=return_excel, + data_model_labels=data_model_labels), body=list(csv_file=httr::upload_file(csv_file, type = "text/csv")) ) check_success(req) @@ -114,9 +125,14 @@ manifest_populate <- function(url="http://localhost:3001/v1/manifest/populate", #' @returns An empty list() if sucessfully validated. Or a list of errors. #' @export manifest_validate <- function(url="http://localhost:3001/v1/model/validate", - schema_url="https://raw.githubusercontent.com/ncihtan/data-models/main/HTAN.model.jsonld", #nolint - data_type, file_name, restrict_rules=FALSE, project_scope = NULL, - access_token, asset_view = NULL) { + schema_url, + data_type, + file_name, + restrict_rules=FALSE, + project_scope = NULL, + access_token, + asset_view = NULL, + data_model_labels = "class_label") { flattenbody <- function(x) { # A form/query can only have one value per name, so take @@ -144,7 +160,8 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate", data_type=data_type, restrict_rules=restrict_rules, project_scope = project_scope, - asset_view = asset_view)), + asset_view = asset_view, + data_model_labels = data_model_labels)), body=list(file_name=httr::upload_file(file_name)) ) @@ -226,14 +243,17 @@ model_submit <- function(url="http://localhost:3001/v1/model/submit", #' @returns A list of required components associated with the source component. #' @export model_component_requirements <- function(url="http://localhost:3001/v1/model/component-requirements", - schema_url, source_component, - as_graph = FALSE) { + schema_url, + source_component, + as_graph = FALSE, + data_model_labels = "class_label") { req <- httr::GET(url, query = list( schema_url = schema_url, source_component = source_component, - as_graph = as_graph + as_graph = as_graph, + data_model_labels = data_model_labels )) check_success(req) @@ -355,11 +375,14 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta #' @export #' @importFrom httr GET content graph_by_edge_type <- function(url = "https://schematic-dev.api.sagebionetworks.org/v1/schemas/get/graph_by_edge_type", - schema_url, relationship = "requiresDependency") { + schema_url, + relationship = "requiresDependency", + data_model_labels = "class_label") { req <- httr::GET(url = url, query = list( schema_url = schema_url, - relationship = relationship + relationship = relationship, + data_model_labels = data_model_labels )) httr::content(req) } From be4d08621ab8f1bd8c873755231d43e62e557bc2 Mon Sep 17 00:00:00 2001 From: afwillia Date: Wed, 28 Feb 2024 10:04:19 -0800 Subject: [PATCH 7/8] Remove dashboardFuns-api.R from this PR --- functions/dashboardFuns-api.R | 186 ---------------------------------- 1 file changed, 186 deletions(-) delete mode 100644 functions/dashboardFuns-api.R diff --git a/functions/dashboardFuns-api.R b/functions/dashboardFuns-api.R deleted file mode 100644 index db26c7ae..00000000 --- a/functions/dashboardFuns-api.R +++ /dev/null @@ -1,186 +0,0 @@ -#' get all uploaded manifests based on provided folder list -#' -#' @param syn.store synapse storage object -#' @param datasets a list of folder syn Ids, named by folder names -#' @param ncores number of cpu to run parallelization -#' @return data frame that contains manifest essential information for dashboard -get_dataset_metadata <- function(syn.store, datasets, ncores = 1, access_token, fileview) { - # TODO: if the component could be retrieve directly from storage object: - # remove codes to download all manifests - # get data for all manifests within the specified datasets - #file_view <- syn.store$storageFileviewTable %>% - # either use branch that returns JSON or wait until it's available in devel - file_view <- get_asset_view_table(url = file.path(api_uri, "v1/storage/assets/tables"), access_token = access_token, - asset_view = fileview) - file_view <- file_view %>% - filter(name == "synapse_storage_manifest.csv" & parentId %in% datasets) - - manifest_info <- list() - modified_user <- list() - manifest_dfs <- list() - # return empty data frame if no manifest or no component in the manifest - metadata <- data.frame() - - lapply(file_view$parentId, function(dataset) { - # get manifest's synapse id(s) in each dataset folder - manifest_ids <- file_view$id[file_view$parentId == dataset] - - if (length(manifest_ids) > 0) { - # in case, multiple manifests exist in the same dataset - for (id in manifest_ids) { - #info <- syn$get(id) - info <- datacurator::synapse_get(id = id, auth = access_token) - manifest <- manifest_download( - url = file.path(api_uri, "v1/manifest/download"), - asset_view = fileview, - manifest_id = info$parentId, - as_json = TRUE - ) - - # refactor this not to write files but save in a object - #tmp_man <- tempfile() - info$Path <- NA_character_ - #write_csv(manifest, tmp_man) - manifest_dfs[[id]] <<- manifest - manifest_info <<- append(manifest_info, list(unlist(info))) - #user <- syn$getUserProfile(info["properties"]["modifiedBy"])["userName"] - user <- datacurator::synapse_user_profile(auth = access_token)[["userName"]] - modified_user <<- append(modified_user, user) - } - # manifest_info <- lapply(manifest_ids, function(x) datacurator::synapse_get(id = x, auth = access_token)) - # manifest_info <- bind_rows(manifest_info) - } - }) - - if (length(manifest_info) > 0) { - metadata <- parallel::mclapply(seq_along(manifest_info), function(i) { - info <- manifest_info[[i]] - # extract manifest essential information for dashboard - manifest_path <- info["Path"] - # See above - don't read from file, read from object - #manifest_df <- data.table::fread(manifest_path) - manifest_df <- manifest_dfs[[i]] - # keep all manifests used for validation, even if it has invalid component value - # if manifest doesn't have "Component" column, or empty, return NA for component - manifest_component <- ifelse("Component" %in% colnames(manifest_df) & nrow(manifest_df) > 0, - manifest_df$Component[1], NA_character_ - ) - metadata <- tibble( - SynapseID = info["id"], - Component = manifest_component, - CreatedOn = as.Date(info["createdOn"]), - ModifiedOn = as.Date(info["modifiedOn"]), - ModifiedUser = paste0("@", modified_user[[i]]), - Path = manifest_path, - Folder = names(datasets)[which(datasets == info["parentId"])], - FolderSynId = info["parentId"], - manifest = list(manifest_df) - ) - }, mc.cores = ncores) %>% bind_rows() - } - - return(metadata) -} - - -#' validate all manifests in the metadata of a dataset -#' -#' @param metadata output from \code{get_dataset_metadata}. -#' @param project.scope list of project ids used for cross-manifest validation -#' @return data frame contains required data types for tree plot -validate_metadata <- function(metadata, project.scope, access_token) { - stopifnot(is.list(project.scope)) - if (nrow(metadata) == 0) { - return(metadata) - } - lapply(seq_len(nrow(metadata)), function(i) { - manifest <- metadata[i, ] - # validate manifest, if no error, output is list() - # for invalid components, it will return NULL and relay as 'Out of Date', e.g.: - # "LungCancerTier3", "BreastCancerTier3", "ScRNA-seqAssay", "MolecularTest", "NaN", "" ... - validation_res <- manifest_validate(url = file.path(api_uri, "v1/model/validate"), - data_type = manifest$Component, - schema_url = Sys.getenv("DCA_MODEL_INPUT_DOWNLOAD_URL"), - json_str = jsonlite::toJSON(manifest$manifest), - access_token=access_token, - ) - #csv_file = manifest$Path) - # Wait until you can pass a JSON to manifest_validate - # clean validation res from schematicpy - clean_res <- validationResult(validation_res, manifest$Component, dashboard = TRUE) - data.frame( - Result = clean_res$result, - ErrorType = clean_res$error_type, - WarnMsg = if_else(length(clean_res$warning_msg) == 0, "Valid", paste(clean_res$warning_msg, collapse = "; ")) - ) - }) %>% - bind_rows() %>% - cbind(metadata, .) # expand metadata with validation results -} - -#' create a list of requirements for selected data type -#' -#' @param schema data type of selected data type or template. -#' @return list of requirements for \code{schema} or string of \code{schema} if no requirements found -get_schema_nodes <- function(schema, url = file.path(api_uri, "v1/model/component-requirements"), schema_url) { - requirement <- tryCatch( - model_component_requirements( - url = url, - schema_url = schema_url, - source_component = schema, - as_graph = TRUE - ), - error = function(err) list() - ) - - if (length(requirement) == 0) { - # return data type itself without name - return(as.character(schema)) - } else { - # return a list of requirements of the data type - return(list2Vector(requirement)) - } -} - - -#' create data frame of data type requirements for all manifests -#' -#' @param metadata output from \code{get_dataset_metadata}. -#' @return data frame of nodes contains source and target used for tree plot -get_metadata_nodes <- function(metadata, ncores = 1, schema_url = Sys.getenv("DCA_MODEL_INPUT_DOWNLOAD_URL"), url = file.path(api_uri, "v1/model/component-requirements")) { - if (nrow(metadata) == 0) { - return(data.frame(from = NA, to = NA, folder = NA, folderSynId = NA, nMiss = NA)) - } else { - metadata <- drop_na(metadata, "Component") - parallel::mclapply(seq_len(nrow(metadata)), function(i) { - manifest <- metadata[i, ] - # get all required data types - # nodes <- tryCatch( - # metadata_model$get_component_requirements(manifest$Component, as_graph = TRUE), - # error = function(err) list() - # ) %>% list2Vector() - nodes <- tryCatch(model_component_requirements( - url, - schema_url, - source_component = manifest$Component, - as_graph = TRUE - ), error = function(err) list()) %>% list2Vector() - - source <- as.character(nodes) - target <- names(nodes) - - # count how many requirements are missing in each dataset - n_miss <- sum(!union(target, source) %in% metadata$Component) - - # create data frame for tree plot - data.frame( - from = c(paste0("f:", manifest$Folder), source), - to = c(manifest$Component, target), - folder = c(manifest$Folder), - folder_id = c(manifest$FolderSynId), - n_miss = c(n_miss) - ) - }, mc.cores = ncores) %>% - bind_rows() - } -} From a2789ab53cee48952b51f03c621b54955eb96838 Mon Sep 17 00:00:00 2001 From: afwillia Date: Wed, 28 Feb 2024 14:46:27 -0800 Subject: [PATCH 8/8] lint server.R --- .pre-commit-config.yaml | 30 -- DESCRIPTION | 2 +- server.R | 1018 +++++++++++++++++++++------------------ 3 files changed, 546 insertions(+), 504 deletions(-) diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 6b6ea5ea..f30c7cdf 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -10,36 +10,6 @@ repos: # codemeta must be above use-tidy-description when both are used # - id: codemeta-description-updated - id: use-tidy-description - - id: spell-check - exclude: > - (?x)^( - .*\.[rR]| - .*\.feather| - .*\.jpeg| - .*\.pdf| - .*\.png| - .*\.py| - .*\.RData| - .*\.rds| - .*\.Rds| - .*\.Rproj| - .*\.sh| - (.*/|)\.gitignore| - (.*/|)\.gitlab-ci\.yml| - (.*/|)\.lintr| - (.*/|)\.pre-commit-.*| - (.*/|)\.Rbuildignore| - (.*/|)\.Renviron| - (.*/|)\.Rprofile| - (.*/|)\.travis\.yml| - (.*/|)appveyor\.yml| - (.*/|)NAMESPACE| - (.*/|)renv/settings\.dcf| - (.*/|)renv\.lock| - (.*/|)WORDLIST| - \.github/workflows/.*| - data/.*| - )$ - id: lintr - id: readme-rmd-rendered - id: parsable-R diff --git a/DESCRIPTION b/DESCRIPTION index e4c778ef..5f867f03 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,6 +7,6 @@ License: file LICENSE Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.3 -Imports: httr, dplyr, jsonlite +Imports: httr, dplyr, jsonlite, shinyjs, yaml, promises, readr Suggests: covr diff --git a/server.R b/server.R index 2e3c9168..c8b4faa5 100644 --- a/server.R +++ b/server.R @@ -8,51 +8,53 @@ shinyServer(function(input, output, session) { options(shiny.reactlog = TRUE) params <- parseQueryString(isolate(session$clientData$url_search)) if (!has_auth_code(params) & dca_schematic_api != "offline") { - return() + return() } - + redirect_url <- paste0( api$access, "?", "redirect_uri=", app_url, "&grant_type=", "authorization_code", "&code=", params$code ) - + if (dca_schematic_api != "offline") { # get the access_token and userinfo token req <- POST(redirect_url, encode = "form", body = "", authenticate(app$key, app$secret, type = "basic" ), config = list()) - + # Stop the code if anything other than 2XX status code is returned stop_for_status(req, task = "get an access token") token_response <- content(req, type = NULL) access_token <- token_response$access_token - + session$userData$access_token <- access_token } else { dcWaiter("show", "Cannot connect to Synapse. Running in offline mode.") } - + ######## session global variables ######## # read config in config <- reactiveVal() config_schema <- reactiveVal() - + # mapping from display name to schema name template_namedList <- reactiveVal() - - all_asset_views <- setNames(tenants_config$synapse_asset_view, - tenants_config$name) - asset_views <- reactiveVal(c("mock dca fileview"="syn33715412")) - + + all_asset_views <- setNames( + tenants_config$synapse_asset_view, + tenants_config$name + ) + asset_views <- reactiveVal(c("mock dca fileview" = "syn33715412")) + dcc_config_react <- reactiveVal() tenant_config_react <- reactiveVal() - + manifest_data <- reactiveVal() validation_res <- reactiveVal() manifest_id <- reactiveVal() - + primary_col <- reactiveVal() - + data_list <- list( projects = reactiveVal(NA), folders = reactiveVal(NULL), template = reactiveVal(NULL), @@ -67,146 +69,163 @@ shinyServer(function(input, output, session) { master_asset_view_label = reactiveVal(NULL), project_scope = reactiveVal(NULL) ) - + isUpdateFolder <- reactiveVal(FALSE) - - data_model = reactiveVal(NULL) - - if (dca_schematic_api == "offline") template_config_files <- setNames("www/template_config/config_offline.json", - "synXXXXXX") - + + data_model <- reactiveVal(NULL) + + if (dca_schematic_api == "offline") { + template_config_files <- setNames( + "www/template_config/config_offline.json", + "synXXXXXX" + ) + } + # data available to the user syn_store <- NULL # gets list of projects they have access to - - asset_views <- reactiveVal(c("mock dca fileview (syn33715412)"="syn33715412")) - + + asset_views <- reactiveVal(c("mock dca fileview (syn33715412)" = "syn33715412")) + # All of tabName from the tabs in ui.R - tabs_list <- c("tab_asset_view", + tabs_list <- c( + "tab_asset_view", "tab_project", "tab_template_select", "tab_folder", "tab_template", - "tab_upload") + "tab_upload" + ) clean_tags <- c( "div_template", "div_template_warn", "div_validate", NS("tbl_validate", "table"), "btn_val_gsheet", "btn_submit" ) - + # add box effects boxEffect(zoom = FALSE, float = TRUE) - + ######## Initiate Login Process ######## # synapse cookies session$sendCustomMessage(type = "readCookie", message = list()) - + shinyjs::useShinyjs() shinyjs::hide(selector = ".sidebar-menu") shinyjs::hide("box_preview") shinyjs::hide("box_validate") shinyjs::hide("box_submit") - + # initial loading page observeEvent(input$cookie, { - - # login and update session - # - # The original code pulled the auth token from a cookie, but it - # should actually come from session$userData. The former is - # the Synapse login, only works when the Shiny app' is hosted - # in the synapse.org domain, and is unscoped. The latter will - # work in any domain and is scoped to the access required by the - # Shiny app' - # - - if (dca_schematic_api != "offline") { - access_token <- session$userData$access_token - has_access <- vapply(all_asset_views, function(x) { - synapse_access(id=x, access="DOWNLOAD", auth=access_token) - }, 1L) - asset_views(all_asset_views[has_access==1]) - - if (length(asset_views) == 0) stop("You do not have DOWNLOAD access to any supported Asset Views.") - updateSelectInput(session, "dropdown_asset_view", - choices = asset_views()) - - user_name <- synapse_user_profile(auth=access_token)$firstName - - is_certified <- synapse_is_certified(auth=access_token) - if (!is_certified) { - dcWaiter("update", landing = TRUE, isCertified = FALSE) + # login and update session + # + # The original code pulled the auth token from a cookie, but it + # should actually come from session$userData. The former is + # the Synapse login, only works when the Shiny app' is hosted + # in the synapse.org domain, and is unscoped. The latter will + # work in any domain and is scoped to the access required by the + # Shiny app' + # + + if (dca_schematic_api != "offline") { + access_token <- session$userData$access_token + has_access <- vapply(all_asset_views, function(x) { + synapse_access(id = x, access = "DOWNLOAD", auth = access_token) + }, 1L) + asset_views(all_asset_views[has_access == 1]) + + if (length(asset_views) == 0) stop("You do not have DOWNLOAD access to any supported Asset Views.") + updateSelectInput(session, "dropdown_asset_view", + choices = asset_views() + ) + + user_name <- synapse_user_profile(auth = access_token)$firstName + + is_certified <- synapse_is_certified(auth = access_token) + if (!is_certified) { + dcWaiter("update", landing = TRUE, isCertified = FALSE) + } else { + # update waiter loading screen once login successful + dcWaiter("update", landing = TRUE, userName = user_name) + } } else { - # update waiter loading screen once login successful - dcWaiter("update", landing = TRUE, userName = user_name) + updateSelectInput(session, "dropdown_asset_view", + choices = c("Offline mock data (synXXXXXX)" = "synXXXXXX") + ) + dcWaiter("hide") } - } else { - updateSelectInput(session, "dropdown_asset_view", - choices = c("Offline mock data (synXXXXXX)"="synXXXXXX")) - dcWaiter("hide") - } - - if (length(asset_views()) == 1L) { - click("btn_asset_view") - } - - ######## Arrow Button ######## - lapply(1:6, function(i) { - switchTabServer(id = paste0("switchTab", i), tabId = "tabs", tab = reactive(input$tabs)(), tabList = tabs_list, parent = session) - }) - + + if (length(asset_views()) == 1L) { + click("btn_asset_view") + } + + ######## Arrow Button ######## + lapply(1:6, function(i) { + switchTabServer(id = paste0("switchTab", i), tabId = "tabs", tab = reactive(input$tabs)(), tabList = tabs_list, parent = session) + }) }) - + # Goal of this observer is to retrieve a list of projects the users can access # within the selected asset view. observeEvent(input$btn_asset_view, { - dcWaiter("show", msg = paste0("Getting data. This may take a minute."), - color="#2a668d") + dcWaiter("show", + msg = paste0("Getting data. This may take a minute."), + color = "#2a668d" + ) shinyjs::disable("btn_asset_view") - + selected$master_asset_view(input$dropdown_asset_view) av_names <- names(asset_views()[asset_views() %in% selected$master_asset_view()]) selected$master_asset_view_label(av_names) - + tenant_config_react(tenants_config[tenants_config$synapse_asset_view == selected$master_asset_view(), ]) if (dca_schematic_api == "offline") tenant_config_react(tenants_config[tenants_config$name == "DCA Demo", ]) - + dcc_config_react(read_json( - file.path(config_dir, tenant_config_react()$config_location)) - ) - - model_ops <- reactive(setNames(dcc_config_react()$dcc$data_model_url, - dcc_config_react()$dcc$synapse_asset_view)) - + file.path(config_dir, tenant_config_react()$config_location) + )) + + model_ops <- reactive(setNames( + dcc_config_react()$dcc$data_model_url, + dcc_config_react()$dcc$synapse_asset_view + )) + data_model(model_ops()) - - template_config_files <- setNames(dcc_config_react()$dcc$template_menu_config_file, - dcc_config_react()$dcc$synapse_asset_view) - + + template_config_files <- setNames( + dcc_config_react()$dcc$template_menu_config_file, + dcc_config_react()$dcc$synapse_asset_view + ) + output$sass <- renderUI({ - tags$head(tags$style(css())) + tags$head(tags$style(css())) }) - - primary_col(col2rgba(dcc_config_react()$dca$primary_col, 255*0.9)) + + primary_col(col2rgba(dcc_config_react()$dca$primary_col, 255 * 0.9)) css <- reactive({ - # Don't change theme for default projects - sass(input = list(primary_col=dcc_config_react()$dca$primary_col, - htan_col=dcc_config_react()$dca$secondary_col, - sidebar_col=dcc_config_react()$dca$sidebar_col, - sass_file("www/scss/main.scss"))) + # Don't change theme for default projects + sass(input = list( + primary_col = dcc_config_react()$dca$primary_col, + htan_col = dcc_config_react()$dca$secondary_col, + sidebar_col = dcc_config_react()$dca$sidebar_col, + sass_file("www/scss/main.scss") + )) }) - + dcWaiter("hide") - dcWaiter("show", msg = paste0("Getting data. This may take a minute."), - color = primary_col()) - + dcWaiter("show", + msg = paste0("Getting data. This may take a minute."), + color = primary_col() + ) + logo_img <- ifelse(!is.na(dcc_config_react()$dcc$logo_location), - dcc_config_react()$dcc$logo_location, - "https://raw.githubusercontent.com/Sage-Bionetworks/data_curator_config/main/demo/Logo_Sage_Logomark.png") - + dcc_config_react()$dcc$logo_location, + "https://raw.githubusercontent.com/Sage-Bionetworks/data_curator_config/main/demo/Logo_Sage_Logomark.png" + ) + logo_link <- ifelse(!is.na(dcc_config_react()$dcc$logo_link), dcc_config_react()$dcc$logo_link, "https://synapse.org" ) - + output$logo <- renderUI({ tags$li( class = "dropdown", id = "logo", @@ -219,8 +238,8 @@ shinyServer(function(input, output, session) { ) ) ) - }) - + }) + if (dca_schematic_api == "reticulate") { # Update schematic_config and login schematic_config <- yaml::read_yaml("schematic_config.yml") @@ -231,98 +250,103 @@ shinyServer(function(input, output, session) { setup_synapse_driver() syn$login(authToken = access_token, rememberMe = FALSE) syn_store <<- synapse_driver(access_token = access_token) - + system( - "python3 .github/config_schema.py -c schematic_config.yml --service_repo 'Sage-Bionetworks/schematic' --overwrite" + "python3 .github/config_schema.py -c schematic_config.yml --service_repo 'Sage-Bionetworks/schematic' --overwrite" ) - } # Use the template dropdown config file from the appropriate branch of # data_curator_config conf_file <- reactiveVal(template_config_files[input$dropdown_asset_view]) config_df <- jsonlite::fromJSON(conf_file()) - + conf_template <- setNames(config_df[[1]]$schema_name, config_df[[1]]$display_name) config(config_df) config_schema(config_df) data_list$template(conf_template) - + if (dca_synapse_api == TRUE & dca_schematic_api != "offline") { - #This chunk gets projects using the synapse REST API - #Check for user access to project scopes within asset view - + # This chunk gets projects using the synapse REST API + # Check for user access to project scopes within asset view + .asset_view <- selected$master_asset_view() promises::future_promise({ - try({ - scopes <- synapse_get_project_scope(id = .asset_view, auth = access_token) - scope_access <- vapply(scopes, function(x) { - synapse_access(id=x, access="DOWNLOAD", auth=access_token) - }, 1L) - scopes <- scopes[scope_access==1] - projects <- bind_rows( - lapply(scopes, function(x) synapse_get(id=x, auth=access_token)) - ) %>% arrange(name) - setNames(projects$id, projects$name) - }, silent = FALSE) + try( + { + scopes <- synapse_get_project_scope(id = .asset_view, auth = access_token) + scope_access <- vapply(scopes, function(x) { + synapse_access(id = x, access = "DOWNLOAD", auth = access_token) + }, 1L) + scopes <- scopes[scope_access == 1] + projects <- bind_rows( + lapply(scopes, function(x) synapse_get(id = x, auth = access_token)) + ) %>% arrange(name) + setNames(projects$id, projects$name) + }, + silent = FALSE + ) }) %...>% data_list$projects() - } else { data_list_raw <- switch(dca_schematic_api, - reticulate = storage_projects_py(synapse_driver, access_token), - rest = storage_projects(url=file.path(api_uri, "v1/storage/projects"), - asset_view = selected$master_asset_view(), - access_token = access_token), - list(list("Offline Project A", "Offline Project")) + reticulate = storage_projects_py(synapse_driver, access_token), + rest = storage_projects( + url = file.path(api_uri, "v1/storage/projects"), + asset_view = selected$master_asset_view(), + access_token = access_token + ), + list(list("Offline Project A", "Offline Project")) ) data_list$projects(list2Vector(data_list_raw)) } }) - + observeEvent(data_list$projects(), ignoreInit = TRUE, { if (is.null(data_list$projects()) || length(data_list$projects()) == 0 || - inherits(data_list$projects(), "try-error")) { + inherits(data_list$projects(), "try-error")) { dcWaiter("update", landing = TRUE, isPermission = FALSE) } else { - # updates project dropdown lapply(c("dropdown_"), function(x) { - lapply(c(1, 3), function(i) { - updateSelectInput(session, paste0(x, dropdown_types[i]), - choices = sort(names(data_list[[i]]())) - ) - }) + lapply(c(1, 3), function(i) { + updateSelectInput(session, paste0(x, dropdown_types[i]), + choices = sort(names(data_list[[i]]())) + ) + }) }) - - updateTabsetPanel(session, "tabs", selected = "tab_project") - - shinyjs::show(selector = ".sidebar-menu") - shinyjs::hide(select = "li:nth-child(3)") - shinyjs::hide(select = "li:nth-child(4)") - shinyjs::hide(select = "li:nth-child(5)") - shinyjs::hide(select = "li:nth-child(6)") - - dcWaiter("hide") + + updateTabsetPanel(session, "tabs", selected = "tab_project") + + shinyjs::show(selector = ".sidebar-menu") + shinyjs::hide(select = "li:nth-child(3)") + shinyjs::hide(select = "li:nth-child(4)") + shinyjs::hide(select = "li:nth-child(5)") + shinyjs::hide(select = "li:nth-child(6)") + + dcWaiter("hide") } }) - + observeEvent(input$dropdown_asset_view, { shinyjs::enable("btn_asset_view") shinyjs::enable("btn_template_select") }) - + observeEvent(input$info_box, { has_dcc <- ifelse(is.na(dcc_config_react()$dcc$dcc_help_link) | - dcc_config_react()$dcc$dcc_help_link == "" | - is.null(dcc_config_react()$dcc$dcc_help_link), - FALSE, TRUE) + dcc_config_react()$dcc$dcc_help_link == "" | + is.null(dcc_config_react()$dcc$dcc_help_link), + FALSE, TRUE + ) has_portal <- ifelse(is.na(dcc_config_react()$dcc$portal_help_link) | - dcc_config_react()$dcc$portal_help_link == "" | - is.null(dcc_config_react()$dcc$portal_help_link), - FALSE, TRUE) + dcc_config_react()$dcc$portal_help_link == "" | + is.null(dcc_config_react()$dcc$portal_help_link), + FALSE, TRUE + ) has_dm <- ifelse(is.na(dcc_config_react()$dcc$data_model_info) | - dcc_config_react()$dcc$data_model_info == "" | - is.null(dcc_config_react()$dcc$data_model_info), - FALSE, TRUE) + dcc_config_react()$dcc$data_model_info == "" | + is.null(dcc_config_react()$dcc$data_model_info), + FALSE, TRUE + ) nx_report_info( title = sprintf("DCA for %s", dcc_config_react()$dcc$name), tags$ul( @@ -335,116 +359,127 @@ shinyServer(function(input, output, session) { ) ) }) - + # Goal of this observer is to get all of the folders within the selected # project. observeEvent(input$btn_project, { ######## Update Folder List ######## - dcWaiter("show", msg = paste0("Getting data"), - color = primary_col()) + dcWaiter("show", + msg = paste0("Getting data"), + color = primary_col() + ) shinyjs::disable("btn_project") selected$project(data_list$projects()[names(data_list$projects()) == input$dropdown_project]) - + observeEvent(input[["dropdown_project"]], { # get synID of selected project project_id <- selected$project() - + .asset_view <- selected$master_asset_view() - + promises::future_promise({ - try({ - folder_list_raw <- switch( - dca_schematic_api, - reticulate = storage_projects_datasets_py( - synapse_driver, - project_id), - rest = storage_project_datasets( - url=file.path(api_uri, "v1/storage/project/datasets"), - asset_view = .asset_view, - project_id=project_id, - access_token=access_token), - list(list("DatatypeA", "DatatypeA"), list("DatatypeB","DatatypeB")) + try( + { + folder_list_raw <- switch(dca_schematic_api, + reticulate = storage_projects_datasets_py( + synapse_driver, + project_id + ), + rest = storage_project_datasets( + url = file.path(api_uri, "v1/storage/project/datasets"), + asset_view = .asset_view, + project_id = project_id, + access_token = access_token + ), + list(list("DatatypeA", "DatatypeA"), list("DatatypeB", "DatatypeB")) + ) + + folder_list <- list2Vector(folder_list_raw) + folder_list[sort(names(folder_list))] + }, + silent = TRUE ) - - folder_list <- list2Vector(folder_list_raw) - folder_list[sort(names(folder_list))] - }, silent = TRUE) - }) %...>% data_list$folders() }) }) - + observeEvent(data_list$folders(), ignoreInit = TRUE, { updateTabsetPanel(session, "tabs", - selected = "tab_folder") + selected = "tab_folder" + ) shinyjs::show(select = "li:nth-child(3)") updateSelectInput(session, "header_dropdown_project", - choices = selected$project()) + choices = selected$project() + ) updateSelectInput(session, "dropdown_folder", choices = data_list$folders()) - + if (inherits(data_list$folders(), "try-error")) { - nx_report_error(title = "Error retrieving folders", - message = tagList( - p("Confirm that this project contains folders."), - p("Refresh the app to try again or contact the DCC for help."), - p("For debugging: ", data_list$folders()) - ) + nx_report_error( + title = "Error retrieving folders", + message = tagList( + p("Confirm that this project contains folders."), + p("Refresh the app to try again or contact the DCC for help."), + p("For debugging: ", data_list$folders()) + ) ) hide(selector = "#NXReportButton") # hide OK button so users can't continue } if (length(data_list$folders()) < 1) { - nx_report_error(title = "Error retrieving folders", - message = tagList( - p("Confirm you have appropriate access permissions."), - p("Refresh the app to try again or contact the DCC for help."), - p("For debugging: ", data_list$folders()) - ) + nx_report_error( + title = "Error retrieving folders", + message = tagList( + p("Confirm you have appropriate access permissions."), + p("Refresh the app to try again or contact the DCC for help."), + p("For debugging: ", data_list$folders()) + ) ) hide(selector = "#NXReportButton") # hide OK button so users can't continue } dcWaiter("hide") }) - + observeEvent(input$dropdown_project, { shinyjs::enable("btn_project") shinyjs::enable("btn_template_select") }) - + # Goal of this button is to updpate the template reactive object # with the template the user chooses observeEvent(input$btn_template_select, { - dcWaiter("show", msg = "Please wait", color = primary_col(), sleep=0) + dcWaiter("show", msg = "Please wait", color = primary_col(), sleep = 0) shinyjs::disable("btn_template_select") selected$schema(data_list$template()[input$dropdown_template]) shinyjs::show(select = "li:nth-child(5)") shinyjs::show(select = "li:nth-child(6)") updateTabsetPanel(session, "tabs", - selected = "tab_template") + selected = "tab_template" + ) dcWaiter("hide") }) - + observeEvent(input$dropdown_template, { shinyjs::enable("btn_template") shinyjs::enable("btn_template_select") updateSelectInput(session, "header_dropdown_template", - choices = input$dropdown_template) + choices = input$dropdown_template + ) }) - + # Goal of this button is to get the files within a folder the user selects observeEvent(input$btn_folder, { - dcWaiter("show", msg = paste0("Getting data"), color = primary_col()) shinyjs::disable("btn_folder") shinyjs::show(select = "li:nth-child(4)") - + updateTabsetPanel(session, "tabs", - selected = "tab_template_select") - + selected = "tab_template_select" + ) + # clean tags in generating-template tab sapply(clean_tags[1:2], FUN = hide) - - + + if (selected$schema_type() %in% c("record", "file")) { # check number of files if it's file-based template # This gets files using the synapse REST API @@ -452,37 +487,42 @@ shinyServer(function(input, output, session) { if (dca_synapse_api == TRUE & dca_schematic_api != "offline") { .folder <- selected$folder() promises::future_promise({ - files <- synapse_entity_children(auth = access_token, parentId=.folder, includeTypes = list("file")) - if (nrow(files) > 0) { files_vec <- setNames(files$id, files$name) - } else files_vec <- NA_character_ + files <- synapse_entity_children(auth = access_token, parentId = .folder, includeTypes = list("file")) + if (nrow(files) > 0) { + files_vec <- setNames(files$id, files$name) + } else { + files_vec <- NA_character_ + } files_vec }) %...>% data_list$files() - } else { - file_list <- switch(dca_schematic_api, reticulate = storage_dataset_files_py(selected$folder()), - rest = storage_dataset_files(url=file.path(api_uri, "v1/storage/dataset/files"), + rest = storage_dataset_files( + url = file.path(api_uri, "v1/storage/dataset/files"), asset_view = selected$master_asset_view(), dataset_id = selected$folder(), - access_token=access_token), - list(list("DatatypeA", "DatatypeA"), list("DatatypeB", "DatatypeB"))) - + access_token = access_token + ), + list(list("DatatypeA", "DatatypeA"), list("DatatypeB", "DatatypeB")) + ) + # update files list in the folder data_list$files(list2Vector(file_list)) } } }) - - observeEvent(input$dropdown_folder,{ + + observeEvent(input$dropdown_folder, { shinyjs::enable("btn_folder") shinyjs::enable("btn_template_select") selected_folder <- data_list$folders()[which(data_list$folders() == input$dropdown_folder)] selected$folder(selected_folder) updateSelectInput(session, "header_dropdown_folder", - choices = selected$folder()) + choices = selected$folder() + ) }) - + observeEvent(data_list$files(), ignoreInit = TRUE, { warn_text <- NULL if (length(data_list$folders()) == 0) { @@ -504,25 +544,25 @@ shinyServer(function(input, output, session) { may result in errors and delays in your data submission later." ) } - + # if there is warning from above checks - if (!is.null(warn_text)){ + if (!is.null(warn_text)) { # display warnings output$text_template_warn <- renderUI(tagList(br(), span(class = "warn_msg", HTML(warn_text)))) show("div_template_warn") } - + dcWaiter("hide") - }) - + observeEvent(input$btn_folder_have_template, { shinyjs::show(select = "li:nth-child(5)") shinyjs::show(select = "li:nth-child(6)") updateTabsetPanel(session, "tabs", - selected = "tab_upload") + selected = "tab_upload" + ) }) - + observeEvent(input$update_confirm, { req(input$update_confirm == TRUE) isUpdateFolder(TRUE) @@ -532,27 +572,30 @@ shinyServer(function(input, output, session) { ) }) }) - + ######## Update Template ######## # update selected schema template name - observeEvent(input$dropdown_template, { - shinyjs::enable("btn_template_select") - # update reactive selected values for schema - selected$schema(data_list$template()[input$dropdown_template]) - schema_type <- config_schema()[[1]]$type[which(config_schema()[[1]]$display_name == input$dropdown_template)] - selected$schema_type(schema_type) - - # set project scope for each template for cross-manifest validation. - # If project_scope is missing from dca_template_config.json then - # this value will be NULL and cross-manifest validation won't happen. - # validation will occur. - project_scope <- config_schema()[[1]]$project_scope[[which(config_schema()[[1]]$display_name == input$dropdown_template)]] - selected$project_scope(project_scope) - - # clean all tags related with selected template - sapply(clean_tags, FUN = hide) - }, ignoreInit = TRUE) - + observeEvent(input$dropdown_template, + { + shinyjs::enable("btn_template_select") + # update reactive selected values for schema + selected$schema(data_list$template()[input$dropdown_template]) + schema_type <- config_schema()[[1]]$type[which(config_schema()[[1]]$display_name == input$dropdown_template)] + selected$schema_type(schema_type) + + # set project scope for each template for cross-manifest validation. + # If project_scope is missing from dca_template_config.json then + # this value will be NULL and cross-manifest validation won't happen. + # validation will occur. + project_scope <- config_schema()[[1]]$project_scope[[which(config_schema()[[1]]$display_name == input$dropdown_template)]] + selected$project_scope(project_scope) + + # clean all tags related with selected template + sapply(clean_tags, FUN = hide) + }, + ignoreInit = TRUE + ) + ######## Dashboard ######## # dashboard( # id = "dashboard", @@ -568,40 +611,40 @@ shinyServer(function(input, output, session) { # schematic_api = dca_schematic_api, # schema_url = data_model() # ) - + manifest_url <- reactiveVal(NULL) - + ######## Template Google Sheet Link ######## # validate before generating template observeEvent(c(selected$folder(), selected$schema(), input$tabs), { - + }) - + observeEvent(input$tabs, { req(input$tabs %in% "tab_template") output$template_title <- renderText({ - sprintf("Go to %s template for %s folder", - selected$schema(), - names(selected$folder()) - ) + sprintf( + "Go to %s template for %s folder", + selected$schema(), + names(selected$folder()) + ) }) }) - + observeEvent(input$tabs, { req(input$tabs %in% c("tab_project", "tab_template_select", "tab_folder", "tab_template", "tab_upload")) shinyjs::addClass(id = "header_selection_dropdown", class = "dropdown open") }) - + observeEvent(input$tabs, { req(input$tabs == "tab_template_select") shinyjs::show("header_selection_dropdown") }) - + observeEvent(c(input$`switchTab4-Next`, input$tabs), { - req(input$tabs == "tab_template") dcWaiter("show", msg = "Getting template. This may take a minute.", color = dcc_config_react()$dca$primary_col) - + ### This doesn't work - try moving manifest_generate outside of downloadButton .schema <- selected$schema() .datasetId <- selected$folder() @@ -612,80 +655,90 @@ shinyServer(function(input, output, session) { "-", input$dropdown_template ) - .url <- ifelse(dca_schematic_api != "offline", - file.path(api_uri, "v1/manifest/generate"), - NA) + .url <- ifelse( + dca_schematic_api != "offline", + file.path(api_uri, "v1/manifest/generate"), + NA + ) .output_format <- dcc_config_react()$schematic$manifest_generate$output_format .use_annotations <- dcc_config_react()$schematic$manifest_generate$use_annotations - + .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels + promises::future_promise({ - try({ - switch(dca_schematic_api, - rest = manifest_generate( - url=.url, - schema_url = .schema_url, - title = .template, - data_type = .schema, - dataset_id = .datasetId, - asset_view = .asset_view, - use_annotations = .use_annotations, - output_format = .output_format, - access_token=access_token, - strict_validation = FALSE - ), + try( { - message("Downloading offline manifest") - tibble(a="b", c="d") - } + switch(dca_schematic_api, + rest = manifest_generate( + url = .url, + schema_url = .schema_url, + title = .template, + data_type = .schema, + dataset_id = .datasetId, + asset_view = .asset_view, + use_annotations = .use_annotations, + output_format = .output_format, + access_token = access_token, + strict_validation = FALSE, + data_model_labels = .data_model_labels + ), + { + message("Downloading offline manifest") + tibble(a = "b", c = "d") + } + ) + }, + silent = TRUE ) - }, silent = TRUE) }) %...>% manifest_data() - }) - + observeEvent(manifest_data(), { if (inherits(manifest_data(), "try-error")) { - nx_report_error("Failed to get manifest", - tagList( - p("There was a problem downloading the manifest."), - p("Try again or contact the DCC for help"), - p("For debugging: ", manifest_data()) - )) + nx_report_error( + "Failed to get manifest", + tagList( + p("There was a problem downloading the manifest."), + p("Try again or contact the DCC for help"), + p("For debugging: ", manifest_data()) + ) + ) hide(selector = "#NXReportButton") # hide OK button so users can't continue shinyjs::enable("btn_template_select") updateTabsetPanel(session, "tab_template_select") } else { if (dcc_config_react()$schematic$manifest_generate$output_format == "google_sheet") { shinyjs::show("div_template") - } else shinyjs::show("div_download_data") + } else { + shinyjs::show("div_download_data") + } } dcWaiter("hide") }) - + # Bookmarking this thread in case we can't use writeBin... # Use a db connection instead # https://community.rstudio.com/t/how-to-let-download-button-work-with-eventreactive/20937 - + # The giant anonymous content function lets users click through the app and # only download the manifest if they need to. Originally, this was in the # observeEvent above. output$downloadData <- downloadHandler( filename = function() sprintf("%s.xlsx", input$dropdown_template), - #filename = function() sprintf("%s.csv", input$dropdown_template), + # filename = function() sprintf("%s.csv", input$dropdown_template), content = function(file) { - dcWaiter("show", msg = "Downloading data", color = dcc_config_react()$dca$primary_col) - dcWaiter("hide", sleep = 0) - writeBin(manifest_data(), file) + dcWaiter("show", msg = "Downloading data", color = dcc_config_react()$dca$primary_col) + dcWaiter("hide", sleep = 0) + writeBin(manifest_data(), file) } ) - - # generate link + + # generate link output$text_template <- renderUI( tags$a(id = "template_link", href = manifest_data(), list(icon("hand-point-right"), manifest_data()), target = "_blank") ) - + if (dca_schematic_api == "offline") { - mock_offline_manifest <- tibble("column1"="mock offline data") + mock_offline_manifest <- tibble("column1" = "mock offline data") output$downloadData <- downloadHandler( filename = function() sprintf("%s.csv", input$dropdown_template), content = function(file) { @@ -693,16 +746,16 @@ shinyServer(function(input, output, session) { } ) } - + observeEvent(input$btn_template_confirm, { - req(input$btn_template_confirm == TRUE) - runjs("$('#template_link')[0].click();") + req(input$btn_template_confirm == TRUE) + runjs("$('#template_link')[0].click();") }) - + ######## Reads .csv File ######## # Check out module and don't use filepath. Keep file in memory inFile <- csvInfileServer("inputFile", colsAsCharacters = TRUE, keepBlank = TRUE, trimEmptyRows = TRUE) - + observeEvent(inFile$data(), { # After trimming blank rows and columns from data, write to the filepath # so it can be passed to the submit endpoint. @@ -714,16 +767,15 @@ shinyServer(function(input, output, session) { shinyjs::show("box_preview") shinyjs::show("box_validate") }) - + ######## Validation Section ####### observeEvent(input$btn_validate, { - dcWaiter("show", msg = "Validating manifest. This may take a minute.", color = primary_col()) - + # Reset validation_result in case user reuploads the same file. This makes # the validation_res observer trigger any time this button is pressed. - validation_res(NULL) - + validation_res(NULL) + # loading screen for validating metadata .datapath <- inFile$raw()$datapath .schema <- selected$schema() @@ -734,6 +786,7 @@ shinyServer(function(input, output, session) { .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules .project_scope <- selected$project_scope() .access_token <- access_token + .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels # asset view must be NULL to avoid cross-manifest validation. # doing this in a verbose way to avoid warning with ifelse .asset_view <- NULL @@ -745,92 +798,97 @@ shinyServer(function(input, output, session) { .datapath, .schema, TRUE, - .project), - rest = manifest_validate( - url=file.path(api_uri, "v1/model/validate"), - schema_url=.data_model, - data_type=.schema, - file_name=.datapath, - restrict_rules = .restrict_rules, - project_scope = .project_scope, - access_token = .access_token, - asset_view = .asset_view), - { - list(list( - "errors" = list( - Row = NA, Column = NA, Value = NA, - Error = "Mock error for offline mode." - ) - )) - } + .project + ), + rest = manifest_validate( + url = file.path(api_uri, "v1/model/validate"), + schema_url = .data_model, + data_type = .schema, + file_name = .datapath, + restrict_rules = .restrict_rules, + project_scope = .project_scope, + access_token = .access_token, + data_model_labels = .data_model_labels, + asset_view = .asset_view + ), + { + list(list( + "errors" = list( + Row = NA, Column = NA, Value = NA, + Error = "Mock error for offline mode." + ) + )) + } ) # validation messages validationResult(annotation_status, .dd_template, .infile_data) - }) %...>% validation_res() - }) - + observeEvent(validation_res(), { # if there is a file uploaded if (!is.null(validation_res()$result)) { - ValidationMsgServer("text_validate", validation_res()) - + # highlight invalue cells in preview table if (validation_res()$error_type == "Wrong Schema") { DTableServer("tbl_preview", data = inFile$data(), highlight = "full") } else { DTableServer( - "tbl_preview", - data = inFile$data(), - highlight = "partial", highlightValues = validation_res()$preview_highlight + "tbl_preview", + data = inFile$data(), + highlight = "partial", highlightValues = validation_res()$preview_highlight ) } - - if (validation_res()$result == "valid" | dca_schematic_api == "offline" && grepl("fixed", inFile$data()[1,1])) { + + if (validation_res()$result == "valid" | dca_schematic_api == "offline" && grepl("fixed", inFile$data()[1, 1])) { # show submit button output$submit <- renderUI(actionButton("btn_submit", "Submit data", class = "btn-primary-color")) dcWaiter("update", msg = paste0(validation_res()$error_type, " Found !!! "), spin = spin_inner_circles(), sleep = 2.5) shinyjs::show("box_submit") } else { - if (dca_schematic_api != "offline" & dcc_config_react()$schematic$manifest_generate$output_format == "google_sheet") { - #output$val_gsheet <- renderUI( - #actionButton("btn_val_gsheet", " Generate Google Sheet Link", icon = icon("table"), class = "btn-primary-color") - #) - } else if (dca_schematic_api == "offline") { + if (dca_schematic_api != "offline" & dcc_config_react()$schematic$manifest_generate$output_format == "google_sheet") { + # output$val_gsheet <- renderUI( + # actionButton("btn_val_gsheet", " Generate Google Sheet Link", icon = icon("table"), class = "btn-primary-color") + # ) + } else if (dca_schematic_api == "offline") { output$dl_manifest <- renderUI({ - downloadButton("downloadData_good", "Download Corrected Data") + downloadButton("downloadData_good", "Download Corrected Data") }) - } - dcWaiter("update", msg = paste0(validation_res()$error_type, " Found !!! "), spin = spin_pulsar(), sleep = 2.5) } + dcWaiter("update", msg = paste0(validation_res()$error_type, " Found !!! "), spin = spin_pulsar(), sleep = 2.5) + } } else { - dcWaiter("hide") + dcWaiter("hide") } - + show("div_validate") - }) - + # if user click gsheet_btn, generating gsheet observeEvent(input$btn_val_gsheet, { # loading screen for Google link generation dcWaiter("show", msg = "Generating link...", color = primary_col()) filled_manifest <- switch(dca_schematic_api, - reticulate = manifest_populate_py(paste0(config$community, " ", input$dropdown_template), + reticulate = manifest_populate_py( + paste0(config$community, " ", input$dropdown_template), inFile$raw()$datapath, - selected$schema()), - rest = manifest_populate(url=file.path(api_uri, "v1/manifest/populate"), + selected$schema() + ), + rest = manifest_populate( + url = file.path(api_uri, "v1/manifest/populate"), schema_url = data_model(), title = paste0(config$community, " ", input$dropdown_template), data_type = selected$schema(), return_excel = FALSE, - csv_file = inFile$raw()$datapath), - "offline-no-gsheet-url") - - + data_model_labels = .data_model_labels, + csv_file = inFile$raw()$datapath + ), + "offline-no-gsheet-url" + ) + + # rerender and change button to link if (dca_schematic_api != "offline") { output$val_gsheet <- renderUI({ @@ -839,39 +897,39 @@ shinyServer(function(input, output, session) { } dcWaiter("hide") }) - + # Offline version of downloading a failed manifest - mock_offline_manifest_2 <- tibble("column1"="fixed offline data") - output$downloadData_good <- downloadHandler( - filename = function() sprintf("%s.csv", input$dropdown_template), - content = function(file) { - write_csv(mock_offline_manifest_2, file) - } + mock_offline_manifest_2 <- tibble("column1" = "fixed offline data") + output$downloadData_good <- downloadHandler( + filename = function() sprintf("%s.csv", input$dropdown_template), + content = function(file) { + write_csv(mock_offline_manifest_2, file) + } ) - - + + ######## Submission Section ######## observeEvent(input$btn_submit, { # loading screen for submitting data dcWaiter("show", msg = "Submitting data. This may take a minute.", color = primary_col()) - - + + if (is.null(selected$folder())) { # add waiter if no folder selected dcWaiter("update", msg = paste0("Please select a folder to submit"), spin = spin_pulsar(), sleep = 0) } - + # abort submission if no folder selected req(selected$folder()) - + manifest_filename <- sprintf("%s_%s.csv", manifest_basename, tolower(selected$schema())) tmp_out_dir <- tempdir() tmp_file_path <- file.path(tmp_out_dir, manifest_filename) dir.create(tmp_out_dir, showWarnings = FALSE) - + # reads file csv again submit_data <- csvInfileServer("inputFile", colsAsCharacters = TRUE, keepBlank = TRUE, trimEmptyRows = TRUE)$data() - + # If a file-based component selected (define file-based components) note for future # the type to filter (eg file-based) on could probably also be a config choice display_names <- config_schema()$manifest_schemas$display_name[config_schema()$manifest_schemas$type == "file"] @@ -881,25 +939,28 @@ shinyServer(function(input, output, session) { if ("entityId" %in% colnames(submit_data)) { # Convert this to JSON instead and submit write.csv(submit_data, - file = tmp_file_path, - quote = TRUE, row.names = FALSE, na = "" + file = tmp_file_path, + quote = TRUE, row.names = FALSE, na = "" ) } else { # Get file list from synapse REST API if (dca_synapse_api == TRUE & dca_schematic_api != "offline") { - files <- synapse_entity_children(auth = access_token, parentId=selected$folder(), includeTypes = list("file")) + files <- synapse_entity_children(auth = access_token, parentId = selected$folder(), includeTypes = list("file")) data_list$files(setNames(files$id, files$name)) } else { file_list_raw <- switch(dca_schematic_api, reticulate = storage_dataset_files_py(selected$folder()), - rest = storage_dataset_files(url=file.path(api_uri, "v1/storage/dataset/files"), + rest = storage_dataset_files( + url = file.path(api_uri, "v1/storage/dataset/files"), asset_view = selected$master_asset_view(), dataset_id = selected$folder(), - access_token=access_token)) - + access_token = access_token + ) + ) + data_list$files(list2Vector(file_list_raw)) } - + # better filename checking is needed # TODO: crash if no file existing files_df <- stack(data_list$files()) @@ -908,11 +969,11 @@ shinyServer(function(input, output, session) { files_entity <- inner_join(submit_data, files_df, by = "Filename") # convert this to JSON instead and submit write.csv(files_entity, - file = tmp_file_path, + file = tmp_file_path, quote = TRUE, row.names = FALSE, na = "" ) } - + .folder <- selected$folder() .data_model <- data_model() .schema <- selected$schema() @@ -924,111 +985,122 @@ shinyServer(function(input, output, session) { .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules .hide_blanks <- dcc_config_react()$schematic$model_submit$hide_blanks - + # associates metadata with data and returns manifest id promises::future_promise({ - try({ - switch(dca_schematic_api, - reticulate = model_submit_py(schema_generator, - tmp_file_path, - .folder, - "table", - FALSE), - rest = model_submit(url=file.path(api_uri, "v1/model/submit"), - schema_url = .data_model, - data_type = NULL, # NULL to bypass validation - dataset_id = .folder, - access_token = access_token, - restrict_rules = .restrict_rules, - file_name = tmp_file_path, - asset_view = .asset_view, - table_column_names = .table_column_names, - annotation_keys = .annotation_keys, - manifest_record_type=.submit_manifest_record_type, - table_manipulation=.table_manipulation, - data_model_labels = .data_model_labels, - hide_blanks=.hide_blanks), - "synXXXX - No data uploaded" - ) - }, silent = TRUE) + try( + { + switch(dca_schematic_api, + reticulate = model_submit_py( + schema_generator, + tmp_file_path, + .folder, + "table", + FALSE + ), + rest = model_submit( + url = file.path(api_uri, "v1/model/submit"), + schema_url = .data_model, + data_type = NULL, # NULL to bypass validation + dataset_id = .folder, + access_token = access_token, + restrict_rules = .restrict_rules, + file_name = tmp_file_path, + asset_view = .asset_view, + table_column_names = .table_column_names, + annotation_keys = .annotation_keys, + manifest_record_type = .submit_manifest_record_type, + table_manipulation = .table_manipulation, + data_model_labels = .data_model_labels, + hide_blanks = .hide_blanks + ), + "synXXXX - No data uploaded" + ) + }, + silent = TRUE + ) }) %...>% manifest_id() - } else { - # if not file-based type template - # convert this to JSON and submit - write.csv(submit_data, - file = tmp_file_path, quote = TRUE, - row.names = FALSE, na = "" - ) - - # associates metadata with data and returns manifest id - .folder <- selected$folder() - .data_model <- data_model() - .schema <- selected$schema() - .asset_view <- selected$master_asset_view() - .table_column_names <- dcc_config_react()$schematic$model_submit$table_column_names - .annotation_keys <- dcc_config_react()$schematic$model_submit$annotation_keys - .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels - .table_manipulation <- dcc_config_react()$schematic$model_submit$table_manipulation - .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type - .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules - .hide_blanks <- dcc_config_react()$schematic$model_submit$hide_blanks - # associates metadata with data and returns manifest id - promises::future_promise({ - try({ - switch(dca_schematic_api, - reticulate = model_submit_py(schema_generator, - tmp_file_path, - .folder, - "table", - FALSE), - rest = model_submit(url=file.path(api_uri, "v1/model/submit"), - schema_url = .data_model, - data_type = NULL, # NULL to bypass validation - dataset_id = .folder, - access_token = access_token, - restrict_rules = .restrict_rules, - file_name = tmp_file_path, - asset_view = .asset_view, - table_column_names = .table_column_names, - annotation_keys = .annotation_keys, - manifest_record_type=.submit_manifest_record_type, - table_manipulation=.table_manipulation, - data_model_labels = .data_model_labels, - hide_blanks=.hide_blanks), - "synXXXX - No data uploaded" + # if not file-based type template + # convert this to JSON and submit + write.csv(submit_data, + file = tmp_file_path, quote = TRUE, + row.names = FALSE, na = "" + ) + + # associates metadata with data and returns manifest id + .folder <- selected$folder() + .data_model <- data_model() + .schema <- selected$schema() + .asset_view <- selected$master_asset_view() + .table_column_names <- dcc_config_react()$schematic$model_submit$table_column_names + .annotation_keys <- dcc_config_react()$schematic$model_submit$annotation_keys + .data_model_labels <- dcc_config_react()$schematic$global$data_model_labels + .table_manipulation <- dcc_config_react()$schematic$model_submit$table_manipulation + .submit_manifest_record_type <- dcc_config_react()$schematic$model_submit$manifest_record_type + .restrict_rules <- dcc_config_react()$schematic$model_validate$restrict_rules + .hide_blanks <- dcc_config_react()$schematic$model_submit$hide_blanks + # associates metadata with data and returns manifest id + promises::future_promise({ + try( + { + switch(dca_schematic_api, + reticulate = model_submit_py( + schema_generator, + tmp_file_path, + .folder, + "table", + FALSE + ), + rest = model_submit( + url = file.path(api_uri, "v1/model/submit"), + schema_url = .data_model, + data_type = NULL, # NULL to bypass validation + dataset_id = .folder, + access_token = access_token, + restrict_rules = .restrict_rules, + file_name = tmp_file_path, + asset_view = .asset_view, + table_column_names = .table_column_names, + annotation_keys = .annotation_keys, + manifest_record_type = .submit_manifest_record_type, + table_manipulation = .table_manipulation, + data_model_labels = .data_model_labels, + hide_blanks = .hide_blanks + ), + "synXXXX - No data uploaded" + ) + }, + silent = TRUE ) - }, silent = TRUE) - }) %...>% manifest_id() - + }) %...>% manifest_id() } - }) - + observeEvent(manifest_id(), { - req(!is.null(manifest_id())) - + if (inherits(manifest_id(), "try-error")) { dcWaiter("hide") - nx_report_error(title = "Error submitting manifest", - message = tagList( - p("Refresh the app to try again or contact the DCC for help."), - p("For debugging: ", manifest_id()) - ) + nx_report_error( + title = "Error submitting manifest", + message = tagList( + p("Refresh the app to try again or contact the DCC for help."), + p("For debugging: ", manifest_id()) + ) ) hide(selector = "#NXReportButton") # hide OK button so users can't continue } else { manifest_path <- tags$a(href = paste0("https://www.synapse.org/#!Synapse:", manifest_id()), manifest_id(), target = "_blank") - + # add log message message(paste0("Manifest :", sQuote(manifest_id()), " has been successfully uploaded")) - + # if no error if (startsWith(manifest_id(), "syn") == TRUE) { dcWaiter("hide") nx_report_success("Success!", HTML(paste0("Manifest submitted to: ", manifest_path))) - + # clean up old inputs/results sapply(clean_tags, FUN = hide) reset("inputFile-file")