diff --git a/.Rbuildignore b/.Rbuildignore
index dcae32c1..bf1de74f 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -1,3 +1,5 @@
^\.pre-commit-config\.yaml$
^renv$
^renv\.lock$
+^.venv
+^schematic$
\ No newline at end of file
diff --git a/.github/workflows/docker_build.yml b/.github/workflows/docker_build.yml
index dbd369cd..ee3eb6e7 100644
--- a/.github/workflows/docker_build.yml
+++ b/.github/workflows/docker_build.yml
@@ -54,4 +54,16 @@ jobs:
build-args: |
DCA_VERSION=${{ env.DCA_VERSION }}
-
+ - name: Lowercase image name for trivy
+ id: string
+ uses: ASzc/change-string-case-action@v6
+ with:
+ string: ${{ env.IMAGE_PATH }}
+
+ - name: Run Trivy vulnerability scanner
+ uses: aquasecurity/trivy-action@master
+ with:
+ image-ref: '${{ steps.string.outputs.lowercase }}:${{ steps.meta.outputs.version }}'
+ format: 'table'
+ ignore-unfixed: true
+ severity: 'CRITICAL,HIGH'
diff --git a/R/schematic_rest_api.R b/R/schematic_rest_api.R
index 22c5715c..caf8c051 100644
--- a/R/schematic_rest_api.R
+++ b/R/schematic_rest_api.R
@@ -14,33 +14,29 @@ check_success <- function(x){
#' @param url URI of API endpoint
#' @param access_token Synapse PAT
#' @param asset_view ID of view listing all project data assets
-#' @param dataset_id the parent ID of the manifest
+#' @param manifest_id the parent ID of the manifest
#' @param as_json if True return the manifest in JSON format
#' @returns a csv of the manifest
#' @export
-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(
- asset_view = asset_view,
- dataset_id = dataset_id,
+manifest_download <- function(url = "http://localhost:3001/v1/manifest/download", access_token, manifest_id, as_json=TRUE, new_manifest_name=NULL) {
+
+ req <- httr2::request(url) |>
+ httr2::req_retry(
+ max_tries = 3,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503, 403)
+ ) |>
+ httr2::req_error(is_error = \(r) FALSE)
+ resp <- req |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", access_token)) |>
+ httr2::req_url_query(
+ manifest_id = manifest_id,
as_json = as_json,
new_manifest_name = new_manifest_name
- )
- )
-
- check_success(request)
- response <- httr::content(request, type = "application/json")
-
- # Output can have many NULL values which get dropped or cause errors. Set them to NA
- nullToNA <- function(x) {
- x[sapply(x, is.null)] <- NA
- return(x)
- }
- df <- do.call(rbind, lapply(response, rbind))
- nullToNA(df)
-
+ ) |>
+ httr2::req_perform()
+ resp |> httr2::resp_body_string() |>
+ (function(d) gsub('NaN', '"NA"', x = d))() |>
+ jsonlite::fromJSON()
}
#' schematic rest api to generate manifest
@@ -132,6 +128,7 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate",
project_scope = NULL,
access_token,
asset_view = NULL,
+ json_str = NULL,
data_model_labels = "class_label") {
flattenbody <- function(x) {
@@ -153,35 +150,68 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate",
}, names(x), x, USE.NAMES = FALSE, SIMPLIFY = FALSE))
}
- req <- httr::POST(url,
- httr::add_headers(Authorization = sprintf("Bearer %s", access_token)),
- query=flattenbody(list(
- schema_url=schema_url,
- data_type=data_type,
- restrict_rules=restrict_rules,
- project_scope = project_scope,
- asset_view = asset_view,
- data_model_labels = data_model_labels)),
- body=list(file_name=httr::upload_file(file_name))
- )
+ if (all(is.null(json_str), is.null(file_name))) {
+ stop("Must provide either a file to upload or a json")
+ }
- # Format server error in a way validationResult can handle
- if (httr::http_status(req)$category == "Server error") {
- return(
- list(
- list(
- "errors" = list(
- Row = NA, Column = NA, Value = NA,
- Error = sprintf("Cannot validate manifest: %s",
- httr::http_status(req)$message)
- )
- )
- )
- )
+ if (is.null(json_str)) {
+ reqs <- httr2::request(url) |>
+ httr2::req_retry(
+ max_tries = 3,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503, 504, 403)
+ ) |>
+ httr2::req_throttle(1/2) |>
+ httr2::req_error(is_error = \(reqs) FALSE)
+ resp <- reqs |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", access_token)) |>
+ httr2::req_url_query(
+ schema_url=schema_url,
+ data_type=data_type,
+ restrict_rules=restrict_rules,
+ project_scope = project_scope,
+ data_model_labels = data_model_labels,
+ asset_view = asset_view
+ ) |>
+ httr2::req_body_multipart(file_name=curl::form_file(file_name)) |>
+ httr2::req_perform()
+ } else {
+ req <- httr2::request(url) |>
+ httr2::req_throttle(1)
+ resp <- req |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", access_token)) |>
+ httr2::req_url_query(
+ schema_url=schema_url,
+ data_type=data_type,
+ restrict_rules=restrict_rules,
+ project_scope = project_scope,
+ asset_view = asset_view,
+ data_model_labels = data_model_labels,
+ json_str = json_str
+ ) |>
+ #httr2::req_retry(
+ # max_tries = 3,
+ # is_transient = \(resp) httr2::resp_status(resp) %in% c(429, 500, 503, 504)
+ #) |>
+ #httr2::req_error(is_error = \(resp) FALSE) |>
+ httr2::req_perform()
}
- check_success(req)
- annotation_status <- httr::content(req)
- annotation_status
+
+ # Format server error in a way validationResult can handle
+ # if (httr2::resp_is_error(resp)) {
+ # return(
+ # list(
+ # list(
+ # "errors" = list(
+ # Row = NA, Column = NA, Value = NA,
+ # Error = sprintf("Cannot validate manifest: %s",
+ # httr2::resp_status_desc(resp)
+ # )
+ # )
+ # )
+ # )
+ # )
+ # }
+ httr2::resp_body_json(resp)
}
@@ -261,23 +291,28 @@ model_component_requirements <- function(url="http://localhost:3001/v1/model/com
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,
- data_model_labels = data_model_labels
- ))
-
- check_success(req)
- cont <- httr::content(req)
-
- if (inherits(cont, "xml_document")){
- err_msg <- xml2::xml_text(xml2::xml_child(cont, "head/title"))
- stop(sprintf("%s", err_msg))
+ reqs <- httr2::request(url) |>
+ httr2::req_retry(
+ max_tries = 5,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503)
+ ) |>
+ httr2::req_error(is_error = \(r) FALSE)
+ resp <- reqs |>
+ httr2::req_url_query(
+ schema_url = schema_url,
+ source_component = source_component,
+ data_model_labels = data_model_labels,
+ as_graph = as_graph
+ ) |>
+ #httr2::req_retry(max_tries = 3) |>
+ httr2::req_perform()
+ if (httr2::resp_is_error(resp)) {
+ warning(sprintf("model/component-requirement failed for %s. returning empty list. %s",
+ source_component, httr2::resp_body_json(resp)$title))
+ return(list())
}
-
- cont
+ resp |>
+ httr2::resp_body_json()
}
@@ -302,7 +337,7 @@ storage_project_datasets <- function(url="http://localhost:3001/v1/storage/proje
asset_view=asset_view,
project_id=project_id)
)
-
+
check_success(req)
httr::content(req)
}
@@ -376,7 +411,7 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta
if (return_type=="json") {
return(list2DF(fromJSON(httr::content(req))))
} else {
- csv <- readr::read_csv(httr::content(req))
+ csv <- readr::read_csv(httr::content(req), show_col_types = FALSE)
return(csv)
}
diff --git a/R/synapse_rest_api.R b/R/synapse_rest_api.R
index 54da3cdb..ea390b94 100644
--- a/R/synapse_rest_api.R
+++ b/R/synapse_rest_api.R
@@ -54,21 +54,19 @@ synapse_is_certified <- function(url="https://repo-prod.prod.sagebase.org/repo/v
#' @param auth Synapse PAT
#'
#' @export
-synapse_get <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity/",
+synapse_get <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity",
id, auth) {
if (is.null(id)) stop("id cannot be NULL")
- req_url <- file.path(url, id)
- req <- httr::GET(req_url,
- httr::add_headers(Authorization=paste0("Bearer ", auth)))
-
- # Send error if unsuccessful query
- status <- httr::http_status(req)
- if (status$category != "Success") stop(status$message)
-
- cont <- httr::content(req)
- dplyr::bind_rows(cont)
-
+ req <- httr2::request(file.path(url, id))
+ resp <- req |>
+ httr2::req_retry(
+ max_tries = 5,
+ is_transient = \(resp) httr2::resp_status(resp) %in% c(429, 500, 503, 403)
+ ) |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", auth)) |>
+ httr2::req_perform()
+ resp |> httr2::resp_body_json()
}
@@ -216,9 +214,16 @@ synapse_table_query <- function(id, auth, query, partMask=0x7F) {
#' @param auth Synapse token
synapse_table_get <- function(id, async_token, auth) {
url <- file.path("https://repo-prod.prod.sagebase.org/repo/v1/entity", id,"table/query/async/get", async_token)
- req <- httr::GET(url = url,
- httr::add_headers(Authorization=paste0("Bearer ", auth)))
- httr::content(req)
+ request <- httr2::request(url)
+ response <- request |>
+ httr2::req_retry(
+ max_tries = 5,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503, 202, 403)
+ ) |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", auth)) |>
+ httr2::req_perform()
+ httr2::resp_body_json(response)
+
}
#' @title Get column names from a Synapse table
@@ -245,7 +250,6 @@ synapse_storage_projects <- function(id, auth, select_cols = c("id", "name", "pa
select_cols_format <- paste(select_cols, collapse = ", ")
query <- sprintf("select distinct %s from %s", select_cols_format, id)
request <- synapse_table_query(id, auth, query, partMask = 0x1)
- Sys.sleep(1)
response <- synapse_table_get(id, request$token, auth)
setNames(
@@ -278,6 +282,34 @@ synapse_download_file_handle <- function(dataFileHandleId, id, auth, filepath=NU
download_url <- httr::content(request)
destfile <- ifelse(is.null(filepath), tempfile(), filepath)
download.file(download_url, destfile)
- if (is.null(filepath)) readr::read_csv(destfile)
+ if (is.null(filepath)) readr::read_csv(destfile, show_col_types = FALSE)
}
+
+#' @title Download the storage manifest records from an asset view table
+synapse_get_manifests_in_asset_view <- function(id, auth) {
+ request <- synapse_table_query(
+ id = id,
+ auth = auth,
+ query = paste("select * from",
+ id,
+ "where name like 'synapse|_storage|_manifest|_%' escape '|'"),
+ partMask = 0x11)
+ response <- synapse_table_get(
+ id = id,
+ async_token = request$token,
+ auth = auth)
+ # Format the query results by reshaping the results list and getting column
+ # names. partMask 0x11 gets queryResults and column names
+ setNames(
+ tibble::as_tibble(
+ t(
+ vapply(
+ response$queryResult$queryResults$rows, function(x) {
+ null_ind <- which(sapply(x$values, is.null))
+ x$values[null_ind] <- NA
+ unlist(x$values)
+ },
+ character(length(response$columnModels))))),
+ vapply(response$columnModels, function(x) x$name,character(1L)))
+}
diff --git a/R/template_config.R b/R/template_config.R
index f421bd8c..17dfba65 100644
--- a/R/template_config.R
+++ b/R/template_config.R
@@ -22,12 +22,22 @@ get_display_names <- function(qlist) {
}
#' @export
-create_template_config <- function(data_model, include_schemas = NULL, exclude_schemas = NULL) {
+create_template_config <- function(
+ data_model,
+ include_schemas = NULL,
+ exclude_schemas = NULL,
+ data_model_labels = "class_label") {
+
if (!is.null(include_schemas) && !is.null(exclude_schemas)) stop("include_schemas and exclude_schemas cannot both have values")
- edges <- graph_by_edge_type(schema_url = data_model)
+ edges <- graph_by_edge_type(schema_url = data_model, data_model_labels = data_model_labels)
schema_names <- format_edge_type(edges)
nl <- setNames(as.list(schema_names$schema_name), rep("node_list", length(schema_names$schema_name)))
- dnames <- get_display_names(c(schema_url = data_model, nl)) |> httr::content()
+ dnames <- get_display_names(
+ c(schema_url = data_model,
+ nl,
+ data_model_labels=data_model_labels)
+ ) |>
+ httr::content()
config <- data.frame(display_name = unlist(dnames), schema_name = unlist(nl)) |>
dplyr::left_join(schema_names, by = "schema_name") |>
dplyr::mutate(type = ifelse(file_based, "file", "record")) |>
@@ -44,8 +54,13 @@ create_template_config <- function(data_model, include_schemas = NULL, exclude_s
}
#' @export
-create_dca_template_config <- function(data_model, include_schemas = NULL, exclude_schemas = NULL) {
- df <- create_template_config(data_model, include_schemas, exclude_schemas)
+create_dca_template_config <- function(
+ data_model,
+ include_schemas = NULL,
+ exclude_schemas = NULL,
+ data_model_labels = "class_label") {
+
+ df <- create_template_config(data_model, include_schemas, exclude_schemas, data_model_labels)
schematic_version <- httr::GET("https://schematic-dev.api.sagebionetworks.org/v1/version") |>
httr::content()
list(
@@ -57,7 +72,13 @@ create_dca_template_config <- function(data_model, include_schemas = NULL, exclu
#' @export
#' @description Create a DCA-specific template generation function
-write_dca_template_config <- function(data_model, file, include_schemas = NULL, exclude_schemas = NULL) {
- df <- create_dca_template_config(data_model, include_schemas, exclude_schemas)
+write_dca_template_config <- function(
+ data_model,
+ file,
+ include_schemas = NULL,
+ exclude_schemas = NULL,
+ data_model_labels = "class_label") {
+
+ df <- create_dca_template_config(data_model, include_schemas, exclude_schemas, data_model_labels)
jsonlite::write_json(df, file, pretty = TRUE, auto_unbox = TRUE)
}
diff --git a/functions/dashboardFuns.R b/functions/dashboardFuns.R
index 0aeca5dd..bc168cd2 100644
--- a/functions/dashboardFuns.R
+++ b/functions/dashboardFuns.R
@@ -11,12 +11,12 @@ get_dataset_metadata <- function(syn.store, datasets, ncores = 1, schematic_api=
# get data for all manifests within the specified datasets
file_view <- switch(schematic_api,
reticulate = syn.store$storageFileviewTable,
- rest = get_asset_view_table(url = file.path(api_uri, "v1/storage/assets/tables"),
- input_token = access_token,
- asset_view=fileview)
- ) %>%
- filter(grepl("synapse_storage_manifest_", name) & parentId %in% datasets)
-
+ rest = synapse_get_manifests_in_asset_view(
+ id = fileview,
+ auth = access_token
+ )
+ )
+ file_view <- filter(file_view, grepl("synapse_storage_manifest_", name) & parentId %in% datasets)
# datasets don't have a manifest
ds_no_manifest <- datasets[which(!datasets %in% file_view$parentId)]
@@ -39,43 +39,49 @@ get_dataset_metadata <- function(syn.store, datasets, ncores = 1, schematic_api=
)
cols <- setNames(rep("", length(cols)), cols)
metadata <- bind_rows(cols)[0, ]
-
- lapply(file_view$parentId, function(dataset) {
+ metadata_list <- parallel::mclapply(unique(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) {
- if (schematic_api == "reticulate"){
- info <- syn$get(id)
- manifest_info <<- append(manifest_info, info)
- user <- syn$getUserProfile(info["properties"]["modifiedBy"])["userName"]
- modified_user <<- append(modified_user, user)
- } else if (schematic_api == "rest"){
- info <- synapse_get(id = id, auth = access_token)
- manifest <- manifest_download(
- url = file.path(api_uri, "v1/manifest/download"),
- input_token = access_token,
- asset_view = fileview,
- dataset_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 <- synapse_user_profile(auth=access_token)[["userName"]]
- modified_user <<- append(modified_user, user)
- }
+ manifests <- parallel::mclapply(manifest_ids, function(id) {
+ if (schematic_api == "reticulate"){
+ info <- syn$get(id)
+ manifest_info <<- append(manifest_info, info)
+ user <- syn$getUserProfile(info["properties"]["modifiedBy"])["userName"]
+ modified_user <<- append(modified_user, user)
+ } else if (schematic_api == "rest"){
+ info <- synapse_get(id = id, auth = access_token)
+ manifest <- manifest_download(
+ url = file.path(api_uri, "v1/manifest/download"),
+ access_token = access_token,
+ manifest_id = info$id,
+ as_json = TRUE
+ )
+ manifest_tempfile <- tempfile(
+ pattern = paste0(id, Sys.getpid()), fileext = ".csv"
+ )
+ readr::write_csv(manifest, manifest_tempfile)
+ # refactor this not to write files but save in a object
+ info$Path <- manifest_tempfile
+ list(
+ manifest_df = manifest,
+ manifest_info = info,
+ modified_user = info$modifiedBy
+ )
}
- }
- })
+ }, mc.cores = ncores)
+ manifests
+ }, mc.cores = ncores)
+
+ manifest_dfs <- lapply(seq_along(metadata_list), function(x) metadata_list[[x]][[1]]$manifest_df)
+ manifest_info <- lapply(seq_along(metadata_list), function(x) metadata_list[[x]][[1]]$manifest_info)
+ modified_user <- lapply(seq_along(metadata_list), function(x) metadata_list[[x]][[1]]$modified_user)
+ manifest_info <- bind_rows(manifest_info)
+ manifest_info <- unique(manifest_info)
+ manifest_info <- split(manifest_info, manifest_info$id)
+
if (length(manifest_info) > 0) {
metadata <- parallel::mclapply(seq_along(manifest_info), function(i) {
if (schematic_api == "reticulate"){
@@ -100,28 +106,29 @@ get_dataset_metadata <- function(syn.store, datasets, ncores = 1, schematic_api=
} else if (schematic_api == "rest"){
info <- manifest_info[[i]]
# extract manifest essential information for dashboard
- manifest_path <- info["Path"]
+ 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]]
+ manifest_df <- readr::read_csv(manifest_path, show_col_types = FALSE)
+ #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"],
+ SynapseID = info$id,
Component = manifest_component,
- CreatedOn = as.Date(info["createdOn"]),
- ModifiedOn = as.Date(info["modifiedOn"]),
+ CreatedOn = info$createdOn,
+ ModifiedOn = info$modifiedOn,
ModifiedUser = paste0("@", modified_user[[i]]),
Path = manifest_path,
- Folder = names(datasets)[which(datasets == info["parentId"])],
- FolderSynId = info["parentId"],
- manifest = manifest_df
+ Folder = names(datasets)[which(datasets == info$parentId)],
+ FolderSynId = info$parentId,
+ manifest = list(manifest_df)
)
}
- }, mc.cores = ncores) %>% bind_rows()
+ }, mc.cores = ncores)
+ metadata <- bind_rows(metadata)
}
# add empty dataset ids even if there are no manifests
@@ -142,13 +149,13 @@ get_dataset_metadata <- function(syn.store, datasets, ncores = 1, schematic_api=
#' @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, schematic_api, schema_url) {
+validate_metadata <- function(metadata, project.scope, schematic_api, schema_url,
+ access_token) {
stopifnot(is.list(project.scope))
if (nrow(metadata) == 0) {
return(metadata)
}
-
- lapply(1:nrow(metadata), function(i) {
+ m2 <- parallel::mclapply(1:nrow(metadata), function(i) {
manifest <- metadata[i, ]
if (is.na(manifest$Component)) {
data.frame(
@@ -165,32 +172,54 @@ validate_metadata <- function(metadata, project.scope, schematic_api, schema_url
WarnMsg = "'Component' is missing"
)
} else {
- validation_res <- switch(schematic_api,
- reticulate = manifest_validate_py(
- manifestPath = manifest$Path,
- rootNode = manifest$Component,
- restrict_rules = TRUE, # set true to disable great expectation
- project_scope = project.scope
- ),
- rest = manifest_validate(url=file.path(api_uri, "v1/model/validate"),
- data_type=manifest$Component,
- schema_url = schema_url,
- json_str = jsonlite::toJSON(manifest$manifest))
- )
- # clean validation res from schematicpy
- clean_res <- validationResult(validation_res, manifest$Component, dashboard = TRUE)
-
- data.frame(
- Result = clean_res$result,
- # change wrong schema to out-of-date type
- ErrorType = if_else(clean_res$error_type == "Wrong Schema", "Out of Date", clean_res$error_type),
- errorMsg = if_else(is.null(clean_res$error_msg[1]), "Valid", paste(clean_res$error_msg[1], collapse="; ")),
- WarnMsg = if_else(is.null(clean_res$warning_msg[1]), "Valid", paste(clean_res$warning_msg[1], collapse = "; "))
+ validation_res <-
+ switch(schematic_api,
+ reticulate = manifest_validate_py(
+ manifestPath = manifest$Path,
+ rootNode = manifest$Component,
+ restrict_rules = TRUE, # set true to disable great expectation
+ project_scope = project.scope
+ ),
+ rest = manifest_validate(url=file.path("https://schematic-dev.api.sagebionetworks.org/v1/model/validate"),
+ data_type=manifest$Component,
+ schema_url = schema_url,
+ access_token = access_token,
+ file_name = manifest$Path)
)
+ # clean validation res from schematicpy
+ if (!length(validation_res) == 2) {
+ validation_res <- list(list(
+ "errors" = list(
+ Row = NA, Column = NA, Value = NA,
+ Error = "Cannot validate manifest"
+ )))
+ }
+ clean_res <- validationResult(validation_res, manifest$Component, dashboard = TRUE)
+ clean_res[which(sapply(clean_res, is.null))] <- NA
+ if (grepl("Cannot validate manifest", clean_res$error_msg[[1]])) {
+ clean_res <- bind_cols(clean_res)
+ }
+ data.frame(
+ Result = clean_res$result,
+ # change wrong schema to out-of-date type
+ ErrorType = if_else(clean_res$error_type == "Wrong Schema", "Out of Date", clean_res$error_type),
+ errorMsg = if_else(is.na(clean_res$error_msg[1]), "Valid", paste(clean_res$error_msg[1], collapse="; ")),
+ WarnMsg = if_else(is.na(clean_res$warning_msg[1]), "Valid", paste(clean_res$warning_msg[1], collapse = "; "))
+ )
+ #} else {
+ # data.frame(
+ # Result = "Fail",
+ # # change wrong schema to out-of-date type
+ # ErrorType = "Unknown Error",
+ # errorMsg = "Server Error",
+ # WarnMsg = " "
+ # )
+ #}
+
}
- }) %>%
- bind_rows() %>%
- cbind(metadata, .) # expand metadata with validation results
+ }, mc.cores = 1)
+ m2 <- bind_rows(m2)
+ cbind(metadata, m2) # expand metadata with validation results
}
#' create a list of requirements for selected data type
@@ -211,10 +240,9 @@ get_schema_nodes <- function(schema, schematic_api, url, schema_url) {
return(list())
}
)
-
if (length(requirement) == 0) {
# return data type itself without name
- return(as.character(schema))
+ return(schema=as.character(schema))
} else {
# return a list of requirements of the data type
return(list2Vector(requirement))
@@ -231,8 +259,8 @@ get_metadata_nodes <- function(metadata, ncores = 1, schematic_api,
if (nrow(metadata) == 0) {
return(data.frame(from = NA, to = NA, folder = NA, folderSynId = NA, nMiss = NA))
} else {
- parallel::mclapply(1:nrow(metadata), function(i) {
- manifest <- metadata[i, ]
+ mn <- parallel::mclapply(1:nrow(metadata), function(n) {
+ manifest <- metadata[n, ]
# get all required data types
nodes <- tryCatch(
switch(schematic_api,
@@ -247,8 +275,8 @@ get_metadata_nodes <- function(metadata, ncores = 1, schematic_api,
warning("'get_metadata_nodes' failed: ", sQuote(manifest$Component), ":\n", e$message)
return(list())
}
- ) %>% list2Vector()
-
+ )
+ nodes <- list2Vector(nodes)
source <- as.character(nodes)
target <- names(nodes)
@@ -263,7 +291,8 @@ get_metadata_nodes <- function(metadata, ncores = 1, schematic_api,
folder_id = c(manifest$FolderSynId),
n_miss = c(n_miss)
)
- }, mc.cores = ncores) %>% bind_rows()
+ }, mc.cores = ncores)
+ mn <- bind_rows(mn)
}
}
diff --git a/functions/dcWaiter.R b/functions/dcWaiter.R
index be5c537f..7b6c1c8f 100644
--- a/functions/dcWaiter.R
+++ b/functions/dcWaiter.R
@@ -32,7 +32,7 @@ dcWaiter <- function(stage = c("show", "update", "hide"),
if (stage == "show") {
waiter_show_on_load(
html = tagList(
- img(src = "img/Logo_Sage_Logomark.png"),
+ img(src = "img/sage_logo_mark_only.png"),
h4("Logging into Data Curator App")
),
color = col2rgba("#2a668d", 255*0.9)
@@ -40,7 +40,7 @@ dcWaiter <- function(stage = c("show", "update", "hide"),
} else if (!isCertified) {
# when user is not certified synapse user
waiter_update(html = tagList(
- img(src = "img/Logo_Sage_Logomark.png", height = "120px"),
+ img(src = "img/sage_logo_mark_only.png", height = "120px"),
h3("Looks like you're not a synapse certified user!"),
span(
"Please follow the ",
@@ -54,7 +54,7 @@ dcWaiter <- function(stage = c("show", "update", "hide"),
} else if (!isPermission) {
# when user is not certified synapse user
waiter_update(html = tagList(
- img(src = "img/Logo_Sage_Logomark.png", height = "120px"),
+ img(src = "img/sage_logo_mark_only.png", height = "120px"),
h3("Fileview/Project Access Denied!"),
span("You may not have sufficient permissions for curation.
Please contact your team and project administrators.")
@@ -62,7 +62,7 @@ dcWaiter <- function(stage = c("show", "update", "hide"),
} else {
# success loading page; userName needed to provide
waiter_update(html = tagList(
- img(src = "img/Logo_Sage_Logomark.png", height = "120px"),
+ img(src = "img/sage_logo_mark_only.png", height = "120px"),
h3(sprintf("Welcome, %s!", userName))
))
Sys.sleep(sleep)
diff --git a/functions/schematic_rest_api.R b/functions/schematic_rest_api.R
index 5755341a..1e1546c2 100644
--- a/functions/schematic_rest_api.R
+++ b/functions/schematic_rest_api.R
@@ -14,33 +14,29 @@ check_success <- function(x){
#' @param url URI of API endpoint
#' @param access_token Synapse PAT
#' @param asset_view ID of view listing all project data assets
-#' @param dataset_id the parent ID of the manifest
+#' @param manifest_id the parent ID of the manifest
#' @param as_json if True return the manifest in JSON format
#' @returns a csv of the manifest
#' @export
-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(
- asset_view = asset_view,
- dataset_id = dataset_id,
+manifest_download <- function(url = "http://localhost:3001/v1/manifest/download", access_token, manifest_id, as_json=TRUE, new_manifest_name=NULL) {
+
+ req <- httr2::request(url) |>
+ httr2::req_retry(
+ max_tries = 3,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503, 403)
+ ) |>
+ httr2::req_error(is_error = \(r) FALSE)
+ resp <- req |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", access_token)) |>
+ httr2::req_url_query(
+ manifest_id = manifest_id,
as_json = as_json,
new_manifest_name = new_manifest_name
- )
- )
-
- check_success(request)
- response <- httr::content(request, type = "application/json")
-
- # Output can have many NULL values which get dropped or cause errors. Set them to NA
- nullToNA <- function(x) {
- x[sapply(x, is.null)] <- NA
- return(x)
- }
- df <- do.call(rbind, lapply(response, rbind))
- nullToNA(df)
-
+ ) |>
+ httr2::req_perform()
+ resp |> httr2::resp_body_string() |>
+ (function(d) gsub('NaN', '"NA"', x = d))() |>
+ jsonlite::fromJSON()
}
#' schematic rest api to generate manifest
@@ -132,6 +128,7 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate",
project_scope = NULL,
access_token,
asset_view = NULL,
+ json_str = NULL,
data_model_labels = "class_label") {
flattenbody <- function(x) {
@@ -153,35 +150,68 @@ manifest_validate <- function(url="http://localhost:3001/v1/model/validate",
}, names(x), x, USE.NAMES = FALSE, SIMPLIFY = FALSE))
}
- req <- httr::POST(url,
- httr::add_headers(Authorization = sprintf("Bearer %s", access_token)),
- query=flattenbody(list(
- schema_url=schema_url,
- data_type=data_type,
- restrict_rules=restrict_rules,
- project_scope = project_scope,
- asset_view = asset_view,
- data_model_labels = data_model_labels)),
- body=list(file_name=httr::upload_file(file_name))
- )
+ if (all(is.null(json_str), is.null(file_name))) {
+ stop("Must provide either a file to upload or a json")
+ }
- # Format server error in a way validationResult can handle
- if (httr::http_status(req)$category == "Server error") {
- return(
- list(
- list(
- "errors" = list(
- Row = NA, Column = NA, Value = NA,
- Error = sprintf("Cannot validate manifest: %s",
- httr::http_status(req)$message)
- )
- )
- )
- )
+ if (is.null(json_str)) {
+ reqs <- httr2::request(url) |>
+ httr2::req_retry(
+ max_tries = 3,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503, 504, 403)
+ ) |>
+ httr2::req_throttle(1/2) |>
+ httr2::req_error(is_error = \(reqs) FALSE)
+ resp <- reqs |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", access_token)) |>
+ httr2::req_url_query(
+ schema_url=schema_url,
+ data_type=data_type,
+ restrict_rules=restrict_rules,
+ project_scope = project_scope,
+ data_model_labels = data_model_labels,
+ asset_view = asset_view
+ ) |>
+ httr2::req_body_multipart(file_name=curl::form_file(file_name)) |>
+ httr2::req_perform()
+ } else {
+ req <- httr2::request(url) |>
+ httr2::req_throttle(1)
+ resp <- req |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", access_token)) |>
+ httr2::req_url_query(
+ schema_url=schema_url,
+ data_type=data_type,
+ restrict_rules=restrict_rules,
+ project_scope = project_scope,
+ asset_view = asset_view,
+ data_model_labels = data_model_labels,
+ json_str = json_str
+ ) |>
+ #httr2::req_retry(
+ # max_tries = 3,
+ # is_transient = \(resp) httr2::resp_status(resp) %in% c(429, 500, 503, 504)
+ #) |>
+ #httr2::req_error(is_error = \(resp) FALSE) |>
+ httr2::req_perform()
}
- check_success(req)
- annotation_status <- httr::content(req)
- annotation_status
+
+ # Format server error in a way validationResult can handle
+ # if (httr2::resp_is_error(resp)) {
+ # return(
+ # list(
+ # list(
+ # "errors" = list(
+ # Row = NA, Column = NA, Value = NA,
+ # Error = sprintf("Cannot validate manifest: %s",
+ # httr2::resp_status_desc(resp)
+ # )
+ # )
+ # )
+ # )
+ # )
+ # }
+ httr2::resp_body_json(resp)
}
@@ -249,23 +279,28 @@ model_component_requirements <- function(url="http://localhost:3001/v1/model/com
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,
- data_model_labels = data_model_labels
- ))
-
- check_success(req)
- cont <- httr::content(req)
-
- if (inherits(cont, "xml_document")){
- err_msg <- xml2::xml_text(xml2::xml_child(cont, "head/title"))
- stop(sprintf("%s", err_msg))
+ reqs <- httr2::request(url) |>
+ httr2::req_retry(
+ max_tries = 5,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503)
+ ) |>
+ httr2::req_error(is_error = \(r) FALSE)
+ resp <- reqs |>
+ httr2::req_url_query(
+ schema_url = schema_url,
+ source_component = source_component,
+ data_model_labels = data_model_labels,
+ as_graph = as_graph
+ ) |>
+ #httr2::req_retry(max_tries = 3) |>
+ httr2::req_perform()
+ if (httr2::resp_is_error(resp)) {
+ warning(sprintf("model/component-requirement failed for %s. returning empty list. %s",
+ source_component, httr2::resp_body_json(resp)$title))
+ return(list())
}
-
- cont
+ resp |>
+ httr2::resp_body_json()
}
@@ -290,7 +325,7 @@ storage_project_datasets <- function(url="http://localhost:3001/v1/storage/proje
asset_view=asset_view,
project_id=project_id)
)
-
+
check_success(req)
httr::content(req)
}
@@ -364,7 +399,7 @@ get_asset_view_table <- function(url="http://localhost:3001/v1/storage/assets/ta
if (return_type=="json") {
return(list2DF(fromJSON(httr::content(req))))
} else {
- csv <- readr::read_csv(httr::content(req))
+ csv <- readr::read_csv(httr::content(req), show_col_types = FALSE)
return(csv)
}
diff --git a/functions/synapse_rest_api.R b/functions/synapse_rest_api.R
index 09b6773f..ea390b94 100644
--- a/functions/synapse_rest_api.R
+++ b/functions/synapse_rest_api.R
@@ -54,21 +54,19 @@ synapse_is_certified <- function(url="https://repo-prod.prod.sagebase.org/repo/v
#' @param auth Synapse PAT
#'
#' @export
-synapse_get <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity/",
+synapse_get <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity",
id, auth) {
if (is.null(id)) stop("id cannot be NULL")
- req_url <- file.path(url, id)
- req <- httr::GET(req_url,
- httr::add_headers(Authorization=paste0("Bearer ", auth)))
-
- # Send error if unsuccessful query
- status <- httr::http_status(req)
- if (status$category != "Success") stop(status$message)
-
- cont <- httr::content(req)
- dplyr::bind_rows(cont)
-
+ req <- httr2::request(file.path(url, id))
+ resp <- req |>
+ httr2::req_retry(
+ max_tries = 5,
+ is_transient = \(resp) httr2::resp_status(resp) %in% c(429, 500, 503, 403)
+ ) |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", auth)) |>
+ httr2::req_perform()
+ resp |> httr2::resp_body_json()
}
@@ -99,3 +97,219 @@ synapse_access <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/en
}
+#' @title Get children of a synapse entity
+#' https://rest-docs.synapse.org/rest/POST/entity/children.html
+#' @param url Synapse api endpoint
+#' @param auth Synapse token
+#' @param parentId Synapse ID of parent folder
+#' @param nextPageToken Synapse next page token
+#' @param includeTypes Types to return
+#' @param sortBy Variable to sort by
+#' @param sortDirection sort direction
+#' @param includeTotalChildCount boolean include count of children
+#' @param includeSumFileSizes boolean include sum of file sizes
+synapse_entity_children <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity/children",
+ auth, parentId=NULL, nextPageToken=NULL, includeTypes="project", sortBy="NAME",
+ sortDirection="ASC", includeTotalChildCount=FALSE, includeSumFileSizes=FALSE) {
+
+ output <- list()
+ req <- httr::POST(url,
+ httr::add_headers(Authorization=paste0("Bearer ", auth)),
+ body =
+ list(parentId=parentId,
+ nextPageToken=nextPageToken,
+ includeTypes=includeTypes,
+ sortBy=sortBy,
+ sortDirection=sortDirection,
+ includeTotalChildCount=includeTotalChildCount,
+ includeSumFileSizes=includeSumFileSizes),
+ encode="json")
+
+ resp <- httr::content(req)
+ output <- resp$page
+
+ while (!is.null(resp$nextPageToken)) {
+ req <- httr::POST(url,
+ httr::add_headers(Authorization=paste0("Bearer ", auth)),
+ body =
+ list(parentId=parentId,
+ nextPageToken=resp$nextPageToken,
+ includeTypes=includeTypes,
+ sortBy=sortBy,
+ sortDirection=sortDirection,
+ includeTotalChildCount=includeTotalChildCount,
+ includeSumFileSizes=includeSumFileSizes),
+ encode="json")
+ resp <- httr::content(req)
+ output <- c(output, resp$page)
+ }
+ bind_rows(output)
+
+}
+
+#' @title Get projects a user has access to
+#'
+#' @param url Synapse api endpoint
+#' @param auth Synapse token
+#' @param nextPageToken Synapse next page token
+synapse_projects_user <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/projects/user", auth, nextPageToken=NULL) {
+ principalId <- synapse_user_profile(auth = auth)[["ownerId"]]
+ hreq <- httr::GET(url = file.path(url, principalId),
+ query = list(nextPageToken=nextPageToken))
+ output <- list()
+ resp <- httr::content(hreq)
+ output <- resp$results
+ while (!is.null(resp$nextPageToken)) {
+ hreq <- httr::GET(url = file.path(url, principalId),
+ query = list(nextPageToken=resp$nextPageToken))
+ resp <- httr::content(hreq)
+ output <- c(output, resp$results)
+ }
+ dplyr::bind_rows(output)
+}
+
+#' @title Get projects within scope of Synapse project
+#'
+#' @param url Synapse api endpoint
+#' @param id Synapse ID
+#' @param auth Synapse token
+synapse_get_project_scope <- function(url = "https://repo-prod.prod.sagebase.org/repo/v1/entity/",
+ id, auth) {
+ if (is.null(id)) stop("id cannot be NULL")
+ req_url <- file.path(url, id)
+ req <- httr::GET(req_url,
+ httr::add_headers(Authorization=paste0("Bearer ", auth)))
+
+ # Send error if unsuccessful query
+ status <- httr::http_status(req)
+ if (status$category != "Success") stop(status$message)
+
+ cont <- httr::content(req)
+ unlist(cont$scopeIds)
+}
+
+#' @param title Query a Synapse Table
+#' https://rest-docs.synapse.org/rest/GET/entity/id/table/query/async/get/asyncToken.html
+#' @param id Synapse table ID
+#' @param auth Synapse token
+#' @param query An sql query
+#' @param partMask The part of the Synapse response to get. Defaults to everything.
+synapse_table_query <- function(id, auth, query, partMask=0x7F) {
+ url <- file.path("https://repo-prod.prod.sagebase.org/repo/v1/entity",id, "table/query/async/start")
+ req <- httr::POST(url = url,
+ httr::add_headers(Authorization=paste0("Bearer ", auth)),
+ body = list(
+ query = list(sql=query),
+ partMask = partMask
+ ),
+ encode = "json"
+ )
+ httr::content(req)
+}
+
+#' @param title Get results of synapse_table_query
+#' https://rest-docs.synapse.org/rest/GET/entity/id/table/query/async/get/asyncToken.html
+#' @param id Synapse table ID
+#' @param async_token Token from synapse_table_query
+#' @param auth Synapse token
+synapse_table_get <- function(id, async_token, auth) {
+ url <- file.path("https://repo-prod.prod.sagebase.org/repo/v1/entity", id,"table/query/async/get", async_token)
+ request <- httr2::request(url)
+ response <- request |>
+ httr2::req_retry(
+ max_tries = 5,
+ is_transient = \(r) httr2::resp_status(r) %in% c(429, 500, 503, 202, 403)
+ ) |>
+ httr2::req_headers(Authorization = sprintf("Bearer %s", auth)) |>
+ httr2::req_perform()
+ httr2::resp_body_json(response)
+
+}
+
+#' @title Get column names from a Synapse table
+#' https://rest-docs.synapse.org/rest/GET/entity/id/table/query/async/get/asyncToken.html
+#' Uses a table query to get the column names from a Synapse table
+#' @param id Synapse ID of table
+#' @param auth Synapse token
+get_synapse_table_names <- function(id, auth) {
+ query <- sprintf("select id from %s limit 1", id)
+ request <- synapse_table_query(id, auth, query, partMask = 0x10)
+ Sys.sleep(1)
+ response <- synapse_table_get(id, request$token, auth)
+ vapply(response$columnModels, function(x) x$name, character(1L))
+}
+
+#' @title Get storage projects within a Synapse table
+#' https://rest-docs.synapse.org/rest/GET/entity/id/table/query/async/get/asyncToken.html
+#' @param id Synapse ID of table
+#' @param auth Synapse token
+#' @param select_cols Columns to get from table
+synapse_storage_projects <- function(id, auth, select_cols = c("id", "name", "parentId", "projectId", "type", "columnType")) {
+ table_cols <- get_synapse_table_names(id, auth)
+ select_cols <- intersect(select_cols, table_cols)
+ select_cols_format <- paste(select_cols, collapse = ", ")
+ query <- sprintf("select distinct %s from %s", select_cols_format, id)
+ request <- synapse_table_query(id, auth, query, partMask = 0x1)
+ response <- synapse_table_get(id, request$token, auth)
+
+ setNames(
+ tibble::as_tibble(
+ t(
+ vapply(
+ response$queryResult$queryResults$rows, function(x) {
+ unlist(x$values)
+ },
+ character(length(select_cols))))),
+ select_cols)
+}
+
+#' @title Download a synapse file from its URL
+#' https://rest-docs.synapse.org/rest/GET/file/id.html
+#' @param dataFileHandleId The dataFileHandleId from an entity
+#' @param id The synapse ID of the file to download
+#' @param auth Synapse token
+#' @param filepath Optional path to download data. If NULL, return a data frame.
+synapse_download_file_handle <- function(dataFileHandleId, id, auth, filepath=NULL) {
+ url <- sprintf("https://repo-prod.prod.sagebase.org/file/v1/file/%s", dataFileHandleId)
+ request <- httr::GET(url = url,
+ httr::add_headers( Authorization=paste0("Bearer ", auth)),
+ query = list(
+ redirect = FALSE,
+ fileAssociateId = id,
+ fileAssociateType = "FileEntity"
+ )
+ )
+ download_url <- httr::content(request)
+ destfile <- ifelse(is.null(filepath), tempfile(), filepath)
+ download.file(download_url, destfile)
+ if (is.null(filepath)) readr::read_csv(destfile, show_col_types = FALSE)
+
+}
+
+#' @title Download the storage manifest records from an asset view table
+synapse_get_manifests_in_asset_view <- function(id, auth) {
+ request <- synapse_table_query(
+ id = id,
+ auth = auth,
+ query = paste("select * from",
+ id,
+ "where name like 'synapse|_storage|_manifest|_%' escape '|'"),
+ partMask = 0x11)
+ response <- synapse_table_get(
+ id = id,
+ async_token = request$token,
+ auth = auth)
+ # Format the query results by reshaping the results list and getting column
+ # names. partMask 0x11 gets queryResults and column names
+ setNames(
+ tibble::as_tibble(
+ t(
+ vapply(
+ response$queryResult$queryResults$rows, function(x) {
+ null_ind <- which(sapply(x$values, is.null))
+ x$values[null_ind] <- NA
+ unlist(x$values)
+ },
+ character(length(response$columnModels))))),
+ vapply(response$columnModels, function(x) x$name,character(1L)))
+}
diff --git a/global.R b/global.R
index 846a01cb..2e17e23d 100644
--- a/global.R
+++ b/global.R
@@ -27,11 +27,15 @@ suppressPackageStartupMessages({
})
# Set up futures/promises for asynchronous calls
-ncores <- availableCores()
+ncores <- availableCores() - 1
message(sprintf("Available cores: %s", ncores))
plan(multicore, workers = ncores)
-options(shiny.maxRequestSize=32*1024^2)
+options(
+ shiny.maxRequestSize=32*1024^2,
+ rlang_backtrace_on_error = "branch",
+ error = rlang::entrace
+)
# import R files
source_files <- list.files(c("functions", "modules"), pattern = "*\\.R$", recursive = TRUE, full.names = TRUE)
diff --git a/modules/dashboard/dashboard.R b/modules/dashboard/dashboard.R
index b59f9184..387715ee 100644
--- a/modules/dashboard/dashboard.R
+++ b/modules/dashboard/dashboard.R
@@ -77,15 +77,15 @@ dashboard <- function(id, syn.store, project.scope, schema, schema.display.name,
hide("toggle-btn-container")
shinydashboardPlus::updateBox("box", action = "restore")
})
- # retrieving data progress for dashboard should not be executed until dashboard visiable
+ # retrieving data progress for dashboard should not be executed until dashboard visible
# get all uploaded manifests once the project/folder changed
observeEvent(c(project.scope(), input$box$visible), {
req(input$box$visible)
# initiate partial loading screen for generating plot
dcWaiter(
- "show",
- id = ns("tab-container"), url = "www/img/logo.svg", custom_spinner = TRUE,
- msg = "Loading, please wait...", style = "color: #000;", color = transparent(0.95)
+ "show",
+ id = ns("tab-container"), url = "www/img/logo.svg", custom_spinner = TRUE,
+ msg = "Loading, please wait..."
)
# disable selection to prevent changes until all uploaded manifests are queried
@@ -94,10 +94,10 @@ dashboard <- function(id, syn.store, project.scope, schema, schema.display.name,
# get all datasets from selected project
folder_list <- switch(schematic_api,
- "rest" = storage_project_datasets(url=file.path(api_uri, "v1/storage/project/datasets"),
+ "rest" = storage_project_datasets(url=file.path("https://schematic-dev.api.sagebionetworks.org/v1/storage/project/datasets"),
asset_view = fileview,
project_id=folder,
- input_token=access_token),
+ access_token=access_token),
"reticulate" = storage_projects_datasets_py(syn.store, project.scope())
)
folder_list <- list2Vector(folder_list)
@@ -113,7 +113,8 @@ dashboard <- function(id, syn.store, project.scope, schema, schema.display.name,
)
metadata <- validate_metadata(metadata, project.scope = list(project.scope()),
- schematic_api = schematic_api, schema_url=schema_url)
+ schematic_api = schematic_api, schema_url=schema_url,
+ access_token=access_token)
# update reactive value
uploaded_manifests(metadata)
})
@@ -122,7 +123,7 @@ dashboard <- function(id, syn.store, project.scope, schema, schema.display.name,
selected_datatype_requirement <- eventReactive(c(schema(), input$box$visible), {
req(input$box$visible)
get_schema_nodes(schema(), schematic_api = schematic_api,
- url=file.path(api_uri, "v1/model/component-requirements"),
+ url=file.path("https://schematic-dev.api.sagebionetworks.org/v1/model/component-requirements"),
schema_url = schema_url)
})
@@ -133,7 +134,7 @@ dashboard <- function(id, syn.store, project.scope, schema, schema.display.name,
# remove rows with invalid component name
metadata <- uploaded_manifests() %>% filter(!is.na(Component), Component != "Unknown")
get_metadata_nodes(metadata, ncores = ncores, schematic_api=schematic_api,
- schema_url = schema_url, url = file.path(api_uri, "v1/model/component-requirements"))
+ schema_url = schema_url, url = file.path("https://schematic-dev.api.sagebionetworks.org/v1/model/component-requirements"))
})
# render info/plots for selected datatype
diff --git a/renv.lock b/renv.lock
index 465387e6..0ea6f44b 100644
--- a/renv.lock
+++ b/renv.lock
@@ -555,6 +555,11 @@
],
"Hash": "f6844033201269bec3ca0097bc6c97b3"
},
+ "httr2": {
+ "Package": "httr2",
+ "Version": "1.0.0",
+ "Source": "Repository"
+ },
"igraph": {
"Package": "igraph",
"Version": "1.4.1",
@@ -942,14 +947,8 @@
},
"rlang": {
"Package": "rlang",
- "Version": "1.0.6",
- "Source": "Repository",
- "Repository": "CRAN",
- "Requirements": [
- "R",
- "utils"
- ],
- "Hash": "4ed1f8336c8d52c3e750adcdc57228a7"
+ "Version": "1.1.3",
+ "Source": "Repository"
},
"rmarkdown": {
"Package": "rmarkdown",
diff --git a/server.R b/server.R
index 59cc9f5e..d28a88f3 100644
--- a/server.R
+++ b/server.R
@@ -112,7 +112,7 @@ shinyServer(function(input, output, session) {
shinyjs::hide("box_preview")
shinyjs::hide("box_validate")
shinyjs::hide("box_submit")
-
+
# initial loading page
observeEvent(input$cookie, {
# login and update session
@@ -218,7 +218,7 @@ shinyServer(function(input, output, session) {
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"
+ "https://raw.githubusercontent.com/Sage-Bionetworks/data_curator_config/prod/demo/sage_logo_mark_only.png"
)
logo_link <- ifelse(!is.na(dcc_config_react()$dcc$logo_link),
@@ -313,16 +313,20 @@ shinyServer(function(input, output, session) {
)
})
})
-
- 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)")
+ session$sendCustomMessage(
+ "compliance_dashboard",
+ dcc_config_react()$dca$use_compliance_dashboard
+ )
+
+ dcWaiter("hide")
}
})
@@ -371,36 +375,34 @@ shinyServer(function(input, output, session) {
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()
+ # get synID of selected project
+ .project_id <- selected$project()
- .asset_view <- selected$master_asset_view()
+ .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"))
- )
+ 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"))
+ )
- folder_list <- list2Vector(folder_list_raw)
- folder_list[sort(names(folder_list))]
- },
- silent = TRUE
- )
- }) %...>% data_list$folders()
- })
+ folder_list <- list2Vector(folder_list_raw)
+ folder_list[sort(names(folder_list))]
+ },
+ silent = TRUE
+ )
+ }) %...>% data_list$folders()
})
observeEvent(data_list$folders(), ignoreInit = TRUE, {
@@ -457,14 +459,6 @@ shinyServer(function(input, output, session) {
dcWaiter("hide")
})
- observeEvent(input$dropdown_template, {
- shinyjs::enable("btn_template")
- shinyjs::enable("btn_template_select")
- updateSelectInput(session, "header_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())
@@ -480,7 +474,7 @@ shinyServer(function(input, output, session) {
sapply(clean_tags[1:2], FUN = hide)
- if (selected$schema_type() %in% c("record", "file")) {
+ # 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
# get file list in selected folder
@@ -510,7 +504,7 @@ shinyServer(function(input, output, session) {
# update files list in the folder
data_list$files(list2Vector(file_list))
}
- }
+ # }
})
observeEvent(input$dropdown_folder, {
@@ -524,34 +518,6 @@ shinyServer(function(input, output, session) {
})
observeEvent(data_list$files(), ignoreInit = TRUE, {
- warn_text <- NULL
- if (length(data_list$folders()) == 0) {
- # add warning if there is no folder in the selected project
- warn_text <- paste0(
- "please create a folder in the ",
- strong(sQuote(input$dropdown_project)),
- " prior to submitting templates."
- )
- }
- if (is.null(data_list$files())) {
- # display warning message if folder is empty and data type is file-based
- warn_text <- paste0(
- strong(sQuote(input$dropdown_folder)), " folder is empty,
- please upload your data before generating manifest.",
- "
", strong(sQuote(input$dropdown_template)),
- " requires data files to be uploaded prior to generating and submitting templates.",
- "
", "Filling in a template before uploading your data,
- may result in errors and delays in your data submission later."
- )
- }
-
- # if there is warning from above checks
- 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")
})
@@ -577,6 +543,8 @@ shinyServer(function(input, output, session) {
# update selected schema template name
observeEvent(input$dropdown_template,
{
+ req(input$tabs %in% "tab_template_select")
+ warn_text <- reactiveVal(NULL)
shinyjs::enable("btn_template_select")
# update reactive selected values for schema
selected$schema(data_list$template()[input$dropdown_template])
@@ -592,26 +560,63 @@ shinyServer(function(input, output, session) {
# clean all tags related with selected template
sapply(clean_tags, FUN = hide)
+
+ if (length(data_list$folders()) == 0) {
+ # add warning if there is no folder in the selected project
+ warn_text(paste0(
+ "please create a folder in the ",
+ strong(sQuote(input$dropdown_project)),
+ " prior to submitting templates."
+ ))
+ }
+ if (all(is.na(data_list$files())) & selected$schema_type() == "file") {
+ # display warning message if folder is empty and data type is file-based
+ warn_text(paste0(
+ strong(sQuote(input$dropdown_folder)), " folder is empty,
+ please upload your data before generating manifest.",
+ "
", strong(sQuote(input$dropdown_template)),
+ " requires data files to be uploaded prior to generating and submitting templates.",
+ "
", "Filling in a template before uploading your data,
+ may result in errors and delays in your data submission later."
+ ))
+ }
+
+ # if there is warning from above checks
+ 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")
+ # nx_report_warning(
+ # title = "No data uploaded in folder",
+ # HTML(warn_text())
+ # )
+ }
+
+ shinyjs::enable("btn_template")
+ shinyjs::enable("btn_template_select")
+ updateSelectInput(session, "header_dropdown_template",
+ choices = input$dropdown_template
+ )
},
ignoreInit = TRUE
)
######## Dashboard ########
- # dashboard(
- # id = "dashboard",
- # syn.store = syn_store,
- # project.scope = selected$project,
- # schema = selected$schema,
- # schema.display.name = reactive(input$dropdown_datatype),
- # disable.ids = c("box_pick_project", "box_pick_manifest"),
- # ncores = ncores,
- # access_token = access_token,
- # fileview = selected$master_asset_view(),
- # folder = selected$project(),
- # schematic_api = dca_schematic_api,
- # schema_url = data_model()
- # )
-
+ dashboard(
+ id = "dashboard",
+ syn.store = syn_store,
+ project.scope = selected$project,
+ schema = selected$schema,
+ schema.display.name = selected$schema,
+ disable.ids = c("box_pick_project", "box_pick_manifest"),
+ ncores = ncores,
+ access_token = access_token,
+ fileview = selected$master_asset_view(),
+ folder = selected$project(),
+ schematic_api = dca_schematic_api,
+ schema_url = data_model()
+ )
+
manifest_url <- reactiveVal(NULL)
######## Template Google Sheet Link ########
@@ -734,7 +739,18 @@ shinyServer(function(input, output, session) {
# generate link
output$text_template <- renderUI(
- tags$a(id = "template_link", href = manifest_data(), list(icon("hand-point-right"), manifest_data()), target = "_blank")
+ tags$a(
+ id = "template_link",
+ href = manifest_data(),
+ list(
+ icon("hand-point-right"),
+ sprintf("%s metadata for %s - %s",
+ selected$schema(),
+ names(selected$project()),
+ names(selected$folder())
+ )
+ ),
+ target = "_blank")
)
if (dca_schematic_api == "offline") {
diff --git a/ui.R b/ui.R
index a9488286..83cfefe2 100644
--- a/ui.R
+++ b/ui.R
@@ -119,7 +119,11 @@ ui <- shinydashboardPlus::dashboardPage(
tags$head(
tags$style(sass(sass_file("www/scss/main.scss"))),
singleton(includeScript("www/js/readCookie.js")),
- tags$script(htmlwidgets::JS("setTimeout(function(){history.pushState({}, 'Data Curator', window.location.pathname);},2000);"))
+ tags$script(htmlwidgets::JS("setTimeout(function(){history.pushState({}, 'Data Curator', window.location.pathname);},2000);"),
+ "Shiny.addCustomMessageHandler('compliance_dashboard', function(x) {
+ Shiny.setInputValue('compliance_dashboard', x);
+ });
+ ")
),
uiOutput("sass"),
# load dependencies
@@ -164,8 +168,8 @@ ui <- shinydashboardPlus::dashboardPage(
actionButton("btn_project", "Next",
class = "btn-primary-color"
)
- ),
- ),
+ )
+ )
),
tabItem(
tabName = "tab_folder",
@@ -199,6 +203,11 @@ ui <- shinydashboardPlus::dashboardPage(
label = NULL,
choices = "Generating..."
),
+ hidden(div(
+ id = "div_template_warn",
+ height = "100%",
+ htmlOutput("text_template_warn")
+ )),
actionButton("btn_template_select", "Download template",
class = "btn-primary-color"
),
@@ -206,7 +215,8 @@ ui <- shinydashboardPlus::dashboardPage(
"Skip to validation",
class = "btn-primary-color"
)
- )
+ ),
+ conditionalPanel("input.compliance_dashboard", dashboardUI("dashboard"))
),
),
tabItem(
diff --git a/www/img/ADKnowledgePortal.png b/www/img/ADKnowledgePortal.png
deleted file mode 100644
index 9baf7ef9..00000000
Binary files a/www/img/ADKnowledgePortal.png and /dev/null differ
diff --git a/www/img/HTAN_text_logo.png b/www/img/HTAN_text_logo.png
deleted file mode 100644
index a32ecbb9..00000000
Binary files a/www/img/HTAN_text_logo.png and /dev/null differ
diff --git a/www/img/INCLUDE DCC Logo-01.png b/www/img/INCLUDE DCC Logo-01.png
deleted file mode 100644
index 3f19beed..00000000
Binary files a/www/img/INCLUDE DCC Logo-01.png and /dev/null differ
diff --git a/www/img/Logo_Sage_Logomark.png b/www/img/Logo_Sage_Logomark.png
deleted file mode 100644
index 722ee5c4..00000000
Binary files a/www/img/Logo_Sage_Logomark.png and /dev/null differ
diff --git a/www/img/loading.gif b/www/img/loading.gif
deleted file mode 100644
index 3d5adabe..00000000
Binary files a/www/img/loading.gif and /dev/null differ
diff --git a/www/img/logo.svg b/www/img/logo.svg
deleted file mode 100644
index b1752cb5..00000000
--- a/www/img/logo.svg
+++ /dev/null
@@ -1,16 +0,0 @@
-
-
\ No newline at end of file
diff --git a/www/img/sage-loader.svg b/www/img/sage-loader.svg
new file mode 100644
index 00000000..5c34fe71
--- /dev/null
+++ b/www/img/sage-loader.svg
@@ -0,0 +1,15 @@
+
\ No newline at end of file
diff --git a/www/img/sage_logo_mark_only.png b/www/img/sage_logo_mark_only.png
new file mode 100644
index 00000000..127ffadd
Binary files /dev/null and b/www/img/sage_logo_mark_only.png differ
diff --git a/www/img/synapse_logo.png b/www/img/synapse_logo.png
deleted file mode 100644
index e3659920..00000000
Binary files a/www/img/synapse_logo.png and /dev/null differ
diff --git a/www/img/synapse_logo_blk.png b/www/img/synapse_logo_blk.png
deleted file mode 100644
index 84e1347f..00000000
Binary files a/www/img/synapse_logo_blk.png and /dev/null differ