Merge pull request #584 from Sage-Bionetworks/develop

v24.1.2

Author: afwillia

DESCRIPTION

@@ -6,6 +6,7 @@ Authors: Rongrong Chai, Xengie Doan, Milen Nikolov, Sujay Patil, Robert Allaway,
 License: file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.1
+RoxygenNote: 7.2.3
+Imports: httr, dplyr, jsonlite
 Suggests: 
     covr

Dockerfile

@@ -13,10 +13,6 @@ RUN apt-get install -y libxml2 libglpk-dev libicu-dev libicu70 curl
 COPY shiny-server.conf /etc/shiny-server/shiny-server.conf
 RUN chmod 777 /etc/shiny-server/shiny-server.conf
 
-# Update node. https://github.com/nodesource/distributions
-RUN apt-get remove nodejs
-RUN curl -fsSL https://deb.nodesource.com/setup_16.x | sudo -E bash - && apt-get install -y nodejs
-
 USER shiny
 
 WORKDIR /srv/shiny-server/app

NAMESPACE

@@ -1,6 +1,11 @@
 # Generated by roxygen2: do not edit by hand
 
+export(create_dca_template_config)
+export(create_template_config)
+export(format_edge_type)
 export(get_asset_view_table)
+export(get_display_names)
+export(graph_by_edge_type)
 export(manifest_download)
 export(manifest_generate)
 export(manifest_populate)
@@ -14,3 +19,6 @@ export(synapse_access)
 export(synapse_get)
 export(synapse_is_certified)
 export(synapse_user_profile)
+export(write_dca_template_config)
+importFrom(httr,GET)
+importFrom(httr,content)

R/schematic_rest_api.R

@@ -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))
   )
 
@@ -314,3 +338,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)
+}

R/template_config.R

@@ -0,0 +1,63 @@
+#' @export
+format_edge_type <- function(edge_types) {
+  et <- dplyr::bind_rows(lapply(edge_types, function(x) data.frame(value = x[[2]], schema_name = x[[1]])))
+  components <- et |>
+    dplyr::filter(tolower(value) == "component") |>
+    dplyr::pull(schema_name)
+  et |>
+    dplyr::filter(value %in% c("Component", "Filename")) |>
+    dplyr::group_by(schema_name) |>
+    dplyr::summarise(file_based = "Filename" %in% value) |>
+    dplyr::filter(schema_name %in% components)
+}
+
+#' @export
+get_display_names <- function(qlist) {
+  if (!"schema_url" %in% names(qlist)) stop("qlist needs element named `schema_url`")
+  if (!"node_list" %in% names(qlist)) stop("qlist needs at least one element named `node_list`")
+  httr::GET(
+    url = "https://schematic-dev.api.sagebionetworks.org/v1/schemas/get_nodes_display_names",
+    query = qlist
+  )
+}
+
+#' @export
+create_template_config <- function(data_model, include_schemas = NULL, exclude_schemas = NULL) {
+  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)
+  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()
+  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")) |>
+    dplyr::select(-file_based)
+  if (!is.null(include_schemas)) {
+    if (any(length(x <- setdiff(include_schemas, config$schema_name)))) stop(sprintf("%s is not a schema name in the data model", x))
+    config <- dplyr::filter(config, schema_name %in% include_schemas)
+  }
+  if (!is.null(exclude_schemas)) {
+    if (any(length(y <- setdiff(exclude_schemas, config$schema_name)))) stop(sprintf("%s is not a schema name in the data model", y))
+    config <- dplyr::filter(config, !schema_name %in% exclude_schemas)
+  }
+  config
+}
+
+#' @export
+create_dca_template_config <- function(data_model, include_schemas = NULL, exclude_schemas = NULL) {
+  df <- create_template_config(data_model, include_schemas, exclude_schemas)
+  schematic_version <- httr::GET("https://schematic-dev.api.sagebionetworks.org/v1/version") |>
+    httr::content()
+  list(
+    manifest_schemas = df,
+    service_version = schematic_version,
+    schema_version = ""
+  )
+}
+
+#' @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)
+  jsonlite::write_json(df, file, pretty = TRUE, auto_unbox = TRUE)
+}

global.R

@@ -37,8 +37,10 @@ options(shiny.maxRequestSize=32*1024^2)
 source_files <- list.files(c("functions", "modules"), pattern = "*\\.R$", recursive = TRUE, full.names = TRUE)
 sapply(source_files, FUN = source)
 
-dcc_config_file <- Sys.getenv("DCA_DCC_CONFIG")
-dcc_config <- read_csv(dcc_config_file, show_col_types = FALSE)
+if (Sys.getenv("DCA_DCC_CONFIG") == "") stop("missing DCA_DCC_CONFIG environment variable")
+dca_dcc_config <- read_json(Sys.getenv("DCA_DCC_CONFIG"), simplifyVector = TRUE)
+tenants_config <- dca_dcc_config$tenants
+config_dir <- dirname(Sys.getenv("DCA_DCC_CONFIG"))
 
 ## Set Up OAuth
 client_id <- Sys.getenv("DCA_CLIENT_ID")
@@ -127,11 +129,6 @@ api <- oauth_endpoint(
 # The 'openid' scope is required by the protocol for retrieving user information.
 scope <- "openid view download modify"
 
-template_config_files <- setNames(dcc_config$template_menu_config_file,
-dcc_config$synapse_asset_view)
-if (dca_schematic_api == "offline") template_config_files <- setNames("www/template_config/config_offline.json",
-  "synXXXXXX")
-
 ## Set Up Virtual Environment
 # ShinyAppys has a limit of 7000 files which this app' grossly exceeds
 # due to its Python dependencies.  To get around the limit we zip up