diff --git a/R/enrichr.R b/R/enrichr.R index 83e974ce..7e81abbf 100644 --- a/R/enrichr.R +++ b/R/enrichr.R @@ -66,28 +66,37 @@ rba_enrichr_libs <- function(organism = "human", ...){ ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "store_in_options", - class = "logical"), - list(arg = "organism", - class = "character", - no_null = TRUE, - val = c("human", "fly", "yeast", "worm", "fish")) - )) + .rba_args( + cons = list( + list(arg = "store_in_options", class = "logical"), + list( + arg = "organism", class = "character", no_null = TRUE, + val = c("human", "fly", "yeast", "worm", "fish") + ) + ) + ) - .msg("Retrieving List of available libraries and statistics from Enrichr %s.", - organism) + .msg( + "Retrieving List of available libraries and statistics from Enrichr %s.", + organism + ) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) {x[[1]]}) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("enrichr", "url"), - path = paste0(.rba_stg("enrichr", "pth", organism), - "datasetStatistics"), - accept = "application/json", - parser = parser_input, - save_to = .rba_file("enrichr_info.json")) + parser_input <- list( + "json->list_simp", + function(x) { x[[1]] } + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("enrichr", "url"), + path = paste0(.rba_stg("enrichr", "pth", organism), "datasetStatistics"), + accept = "application/json", + parser = parser_input, + save_to = .rba_file("enrichr_info.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -100,6 +109,7 @@ rba_enrichr_libs <- function(organism = "human", options("rba_enrichr_libs" = enrichr_libs) } + return(final_output) } @@ -184,28 +194,34 @@ rba_enrichr_add_list <- function(gene_list, ...){ ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "gene_list", - class = "character"), - list(arg = "description", - class = "character"), - list(arg = "organism", - class = "character", - no_null = TRUE, - val = c("human", "fly", "yeast", "worm", "fish")), - list(arg = "speedrichr", - class = "logical", - no_null = TRUE)), - cond = list(list(quote((isTRUE(speedrichr)) && organism != "human"), - "Using speedrichr (to provide background gene list later) is only availbale for `human`."))) - - .msg("Uploading %s gene symbols to Enrichr %s.", - length(gene_list), organism) + .rba_args( + cons = list( + list(arg = "gene_list", class = "character"), + list(arg = "description", class = "character"), + list( + arg = "organism", class = "character", no_null = TRUE, + val = c("human", "fly", "yeast", "worm", "fish") + ), + list(arg = "speedrichr", class = "logical", no_null = TRUE) + ), + cond = list( + list( + quote((isTRUE(speedrichr)) && organism != "human"), + "Using speedrichr (to provide background gene list later) is only availbale for `human`." + ) + ) + ) + + .msg( + "Uploading %s gene symbols to Enrichr %s.", + length(gene_list), organism + ) ## Build POST API Request's URL input_path <- paste0( - .rba_stg( - "enrichr", "pth", ifelse(speedrichr, "speedrichr", organism)), + .rba_stg("enrichr", "pth", ifelse(speedrichr, "speedrichr", organism)), "addList" ) @@ -214,22 +230,25 @@ rba_enrichr_add_list <- function(gene_list, description = "Submitted to speedrichr" } - call_body <- .rba_query(init = list("format" = "text", - "list" = paste(unique(gene_list), - collapse = "\n")), - list("description", - !is.null(description), - description)) + call_body <- .rba_query( + init = list( + "format" = "text", + "list" = paste(unique(gene_list), collapse = "\n") + ), + list("description", !is.null(description), description) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("enrichr", "url"), - path = input_path, - body = call_body, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("enrichr_add_list.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("enrichr", "url"), + path = input_path, + body = call_body, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("enrichr_add_list.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -293,37 +312,43 @@ rba_enrichr_view_list <- function(user_list_id, ...){ ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "user_list_id", - class = c("numeric"), - len = 1), - list(arg = "organism", - class = "character", - no_null = TRUE, - val = c("human", "fly", "yeast", "worm", "fish")), - list(arg = "speedrichr", - class = "logical", - no_null = TRUE)), - cond = list(list(quote((isTRUE(speedrichr)) && organism != "human"), - "Using speedrichr (to provide background gene list later) is only availbale for `human`.")) - ) - - .msg("Retrieving the gene list under the ID %s from Enrichr %s.", - user_list_id, organism) + .rba_args( + cons = list( + list(arg = "user_list_id", class = c("numeric"), len = 1), + list( + arg = "organism", class = "character", no_null = TRUE, + val = c("human", "fly", "yeast", "worm", "fish") + ), + list(arg = "speedrichr", class = "logical", no_null = TRUE) + ), + cond = list( + list( + quote((isTRUE(speedrichr)) && organism != "human"), + "Using speedrichr (to provide background gene list later) is only availbale for `human`." + ) + ) + ) + + .msg( + "Retrieving the gene list under the ID %s from Enrichr %s.", + user_list_id, organism + ) ## Build GET API Request's query call_query <- list("userListId" = user_list_id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("enrichr", "url"), - path = paste0(.rba_stg("enrichr", "pth", organism), - "view"), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file(sprintf("enrichr_view_list_%s.json", - user_list_id))) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("enrichr", "url"), + path = paste0(.rba_stg("enrichr", "pth", organism), "view"), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file(sprintf("enrichr_view_list_%s.json", user_list_id)) + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -394,25 +419,32 @@ rba_enrichr_add_background <- function(background_genes, ...){ ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "background_genes", - class = "character"))) + .rba_args( + cons = list( + list(arg = "background_genes", class = "character") + ) + ) - .msg("Uploading %s background gene symbols to Enrichr.", - length(background_genes)) + .msg( + "Uploading %s background gene symbols to Enrichr.", + length(background_genes) + ) ## Build POST API Request's URL call_body <- list(background = paste(background_genes, collapse = "\n")) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("enrichr", "url"), - path = paste0(.rba_stg("enrichr", "pth", "speedrichr"), - "addbackground"), - body = call_body, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("enrichr_add_background.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("enrichr", "url"), + path = paste0(.rba_stg("enrichr", "pth", "speedrichr"), "addbackground"), + body = call_body, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("enrichr_add_background.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -483,54 +515,75 @@ rba_enrichr_add_background <- function(background_genes, if (is.null(background_id)) { httr_verb <- "get" httr_accept <- "text/tab-separated-values" - call_query <- list("userListId" = user_list_id, - "backgroundType" = gene_set_library) + call_query <- list( + "userListId" = user_list_id, + "backgroundType" = gene_set_library + ) call_body = NULL - path_input <- paste0(.rba_stg("enrichr", "pth", organism), - "export") + path_input <- paste0( + .rba_stg("enrichr", "pth", organism), + "export" + ) parser_input <- function(httr_response) { - parsed_response <- httr::content(httr_response, - as = "text", - type = "text/tab-separated-values", - encoding = "UTF-8") - try(utils::read.delim(textConnection(parsed_response), - sep = "\t", header = TRUE, - stringsAsFactors = FALSE), - silent = !get("diagnostics")) + parsed_response <- httr::content( + httr_response, + as = "text", + type = "text/tab-separated-values", + encoding = "UTF-8" + ) + + try( + utils::read.delim( + textConnection(parsed_response), + sep = "\t", + header = TRUE, + stringsAsFactors = FALSE), + silent = !get("diagnostics") + ) } } else { httr_verb <- "post" httr_accept <- "application/json" call_query <- NULL - call_body <- list("userListId" = user_list_id, - "backgroundid" = background_id, - "backgroundType" = gene_set_library) + call_body <- list( + "userListId" = user_list_id, + "backgroundid" = background_id, + "backgroundType" = gene_set_library + ) - path_input <- paste0(.rba_stg("enrichr", "pth", "speedrichr"), - "backgroundenrich") + path_input <- paste0( + .rba_stg("enrichr", "pth", "speedrichr"), + "backgroundenrich" + ) parser_input <- function(httr_response) { - parsed_response <- gsub("Infinity", "\"Inf\"", httr::content(httr_response, - as = "text", - encoding = "UTF-8")) + parsed_response <- gsub( + "Infinity", "\"Inf\"", + httr::content(httr_response, + as = "text", + encoding = "UTF-8") + ) + # parsed_response <- gsub("NaN", "\"NaN\"", parsed_response) parsed_response <- jsonlite::fromJSON(parsed_response)[[1]] - parsed_response <- lapply(parsed_response, function(response_row) { - names(response_row) <- c("Rank", "Term", - "P.value", "Odds.Ratio", - "Combined.Score", "Genes", - "Adjusted.P.value", - "Old.P.value", "Old.adjusted.P.value") - response_row$Overlapping.genes <- paste0( - response_row$Overlapping.genes, - collapse = ";") - - return(response_row) - }) + parsed_response <- lapply( + parsed_response, + function(response_row) { + names(response_row) <- c("Rank", "Term", + "P.value", "Odds.Ratio", + "Combined.Score", "Genes", + "Adjusted.P.value", + "Old.P.value", "Old.adjusted.P.value") + response_row$Overlapping.genes <- paste0( + response_row$Overlapping.genes, + collapse = ";") + + return(response_row) + }) if (length(parsed_response) == 0) { parsed_response <- data.frame( @@ -545,10 +598,16 @@ rba_enrichr_add_background <- function(background_genes, Old.adjusted.P.value = numeric() ) } else { - parsed_response <- do.call(rbind, lapply(parsed_response, function(response_row) - {as.data.frame(response_row, stringsAsFactors = FALSE)} + parsed_response <- do.call( + rbind, + lapply( + parsed_response, + function(response_row) { + as.data.frame(response_row, stringsAsFactors = FALSE) + } ) ) + numeric_cols <- c("Rank", "P.value", "Odds.Ratio", "Combined.Score", "Adjusted.P.value", "Old.P.value", "Old.adjusted.P.value") parsed_response[numeric_cols] <- lapply(parsed_response[numeric_cols], as.numeric) @@ -557,14 +616,16 @@ rba_enrichr_add_background <- function(background_genes, } } - input_call <- .rba_httr(httr = httr_verb, - .rba_stg("enrichr", "url"), - path = path_input, - query = call_query, - body = call_body, - httr::accept(httr_accept), - parser = parser_input, - save_to = .rba_file(save_name)) + input_call <- .rba_httr( + httr = httr_verb, + url = .rba_stg("enrichr", "url"), + path = path_input, + query = call_query, + body = call_body, + httr::accept(httr_accept), + parser = parser_input, + save_to = .rba_file(save_name) + ) ## Call API Sys.sleep(sleep_time) @@ -573,11 +634,13 @@ rba_enrichr_add_background <- function(background_genes, if (is.data.frame(final_output)) { return(final_output) } else { - error_message <- paste0("Error: Couldn't parse the server response for the requested Enrichr analysis. ", - "Please try again. If the problem persists, kindly report the issue to us. ", - "The server's raw response was: ", - as.character(final_output), - collapse = "\n") + error_message <- paste0( + "Error: Couldn't parse the server response for the requested Enrichr analysis. ", + "Please try again. If the problem persists, kindly report the issue to us. ", + "The server's raw response was: ", + as.character(final_output), + collapse = "\n" + ) if (isTRUE(get("skip_error"))) { return(error_message) } else { @@ -688,10 +751,12 @@ rba_enrichr_enrich <- function(user_list_id, ## get a list of available libraries if (is.null(getOption("rba_enrichr_libs")[[organism]])) { - .msg("Calling rba_enrichr_libs() to get the names of available Enrichr %s libraries.", - organism) - enrichr_libs <- rba_enrichr_libs(organism = organism, - store_in_options = TRUE) + .msg( + "Calling rba_enrichr_libs() to get the names of available Enrichr %s libraries.", + organism + ) + + enrichr_libs <- rba_enrichr_libs(organism = organism, store_in_options = TRUE) if (utils::hasName(enrichr_libs, "libraryName")) { enrichr_libs <- enrichr_libs[["libraryName"]] @@ -711,9 +776,11 @@ rba_enrichr_enrich <- function(user_list_id, if (isFALSE(regex_library_name)) { run_mode <- "single" } else { - gene_set_library <- grep(gene_set_library, - enrichr_libs, - ignore.case = TRUE, value = TRUE, perl = TRUE) + gene_set_library <- grep( + gene_set_library, + enrichr_libs, + ignore.case = TRUE, value = TRUE, perl = TRUE + ) #check the results of regex if (length(gene_set_library) == 0) { no_lib_error <- "Error: No Enrichr libraries matched your regex pattern." @@ -731,67 +798,86 @@ rba_enrichr_enrich <- function(user_list_id, } # end of if length(gene_set_library) > 1 ## Check User-input Arguments - .rba_args(cons = list(list(arg = "user_list_id", - class = c("numeric", "integer"), - len = 1), - list(arg = "gene_set_library", - class = "character", - val = enrichr_libs), - list(arg = "progress_bar", - class = "logical"), - list(arg = "organism", - class = "character", - no_null = TRUE, - val = c("human", "fly", "yeast", "worm", "fish")), - list(arg = "background_id", - class = "character", - len = 1)), - cond = list(list(quote((!is.null(background_id)) && organism != "human"), - "Providing background gene set is only availbale for `human`."))) + .rba_args( + cons = list( + list(arg = "user_list_id", class = c("numeric", "integer"), len = 1), + list(arg = "gene_set_library", class = "character", val = enrichr_libs), + list(arg = "progress_bar", class = "logical"), + list( + arg = "organism", class = "character", no_null = TRUE, + val = c("human", "fly", "yeast", "worm", "fish") + ), + list(arg = "background_id", class = "character", len = 1) + ), + cond = list( + list( + quote((!is.null(background_id)) && organism != "human"), + "Providing background gene set is only availbale for `human`.") + ) + ) ## call Enrichr API if (run_mode == "single") { - .msg("Performing enrichment analysis on gene-list %s against Enrichr %s library: %s.", - user_list_id, organism, gene_set_library) - final_output <- .rba_enrichr_enrich_internal(user_list_id = user_list_id, - background_id = background_id, - gene_set_library = gene_set_library, - save_name = sprintf("enrichr_%s_%s.json", - user_list_id, - gene_set_library), - ...) + .msg( + "Performing enrichment analysis on gene-list %s against Enrichr %s library: %s.", + user_list_id, organism, gene_set_library + ) + + final_output <- .rba_enrichr_enrich_internal( + user_list_id = user_list_id, + background_id = background_id, + gene_set_library = gene_set_library, + save_name = sprintf("enrichr_%s_%s.json", user_list_id, gene_set_library), + ... + ) + return(final_output) } else { - .msg("Performing enrichment analysis on gene-list %s using multiple Enrichr %s libraries.", - user_list_id, organism) - .msg(paste0("Note: You have selected '%s' Enrichr %s libraries. Note that for ", - "each library, a separate call should be sent to Enrichr server. ", - "Thus, this could take a while depending on the number of selected ", - "libraries and your network connection."), - length(gene_set_library), organism) + .msg( + "Performing enrichment analysis on gene-list %s using multiple Enrichr %s libraries.", + user_list_id, + organism + ) + + .msg( + paste0( + "Note: You have selected '%s' Enrichr %s libraries. Note that for ", + "each library, a separate call should be sent to Enrichr server. ", + "Thus, this could take a while depending on the number of selected ", + "libraries and your network connection." + ), + length(gene_set_library), + organism + ) + ## initiate progress bar if (isTRUE(progress_bar)) { - pb <- utils::txtProgressBar(min = 0, - max = length(gene_set_library), - style = 3) + pb <- utils::txtProgressBar( + min = 0, + max = length(gene_set_library), + style = 3 + ) } - final_output <- lapply(gene_set_library, - function(x){ - lib_enrich_res <- .rba_enrichr_enrich_internal(user_list_id = user_list_id, - background_id = background_id, - gene_set_library = x, - save_name = sprintf("enrichr_%s_%s.json", - user_list_id, - x), - sleep_time = 0.5, - ...) - #advance the progress bar - if (isTRUE(progress_bar)) { - utils::setTxtProgressBar(pb, which(gene_set_library == x)) - } - return(lib_enrich_res) - }) + final_output <- lapply( + gene_set_library, + function(x){ + lib_enrich_res <- .rba_enrichr_enrich_internal( + user_list_id = user_list_id, + background_id = background_id, + gene_set_library = x, + save_name = sprintf("enrichr_%s_%s.json", user_list_id, x), + sleep_time = 0.5, + ... + ) + #advance the progress bar + if (isTRUE(progress_bar)) { + utils::setTxtProgressBar(pb, which(gene_set_library == x)) + } + return(lib_enrich_res) + } + ) + if (isTRUE(progress_bar)) {close(pb)} names(final_output) <- gene_set_library return(final_output) @@ -856,35 +942,40 @@ rba_enrichr_gene_map <- function(gene, ...){ ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "gene", - class = "character", - len = 1), - list(arg = "categorize", - class = "logical"), - list(arg = "organism", - class = "character", - no_null = TRUE, - val = c("human", "fly", "yeast", "worm", "fish")) - )) - - .msg("Finding terms that contain %s gene: %s.", organism, gene) + .rba_args( + cons = list( + list(arg = "gene", class = "character", len = 1), + list(arg = "categorize", class = "logical"), + list( + arg = "organism", class = "character", no_null = TRUE, + val = c("human", "fly", "yeast", "worm", "fish") + ) + ) + ) + + .msg( + "Finding terms that contain %s gene: %s.", + organism, gene + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("gene" = gene, - "json" = "true"), - list("setup", - isTRUE(categorize), - "true")) + call_query <- .rba_query( + init = list("gene" = gene, "json" = "true"), + list("setup", isTRUE(categorize), "true") + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("enrichr", "url"), - path = paste0(.rba_stg("enrichr", "pth", organism), - "genemap"), - query = call_query, - accept = "application/json", - parser = "json->list_simp_flt_df", - save_to = .rba_file("enrichr_gene_map.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("enrichr", "url"), + path = paste0(.rba_stg("enrichr", "pth", organism), "genemap"), + query = call_query, + accept = "application/json", + parser = "json->list_simp_flt_df", + save_to = .rba_file("enrichr_gene_map.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -975,25 +1066,30 @@ rba_enrichr <- function(gene_list, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "gene_list", - class = "character"), - list(arg = "description", - class = "character"), - list(arg = "regex_library_name", - class = "logical"), - list(arg = "progress_bar", - class = "logical"), - list(arg = "organism", - class = "character", - no_null = TRUE, - val = c("human", "fly", "yeast", "worm", "fish")), - list(arg = "background_genes", - class = "character")), - cond = list(list(quote((!is.null(background_genes)) && organism != "human"), - "Providing background gene set is only availbale for `human`."), - list(quote(!is.null(background_genes) && (!all(gene_list %in% background_genes))), - "Some of the gene_list elements are not present in background_genes")) + .rba_args( + cons = list( + list(arg = "gene_list", class = "character"), + list(arg = "description", class = "character"), + list(arg = "regex_library_name", class = "logical"), + list(arg = "progress_bar", class = "logical"), + list( + arg = "organism", class = "character", no_null = TRUE, + val = c("human", "fly", "yeast", "worm", "fish") + ), + list(arg = "background_genes", class = "character") + ), + cond = list( + list( + quote((!is.null(background_genes)) && organism != "human"), + "Providing background gene set is only availbale for `human`." + ), + list( + quote(!is.null(background_genes) && (!all(gene_list %in% background_genes))), + "Some of the gene_list elements are not present in background_genes" + ) + ) ) .msg("--Step 1/3:") @@ -1007,10 +1103,12 @@ rba_enrichr <- function(gene_list, step_1_success <- exists("enrichr_libs") && length(enrichr_libs) > 1 if (!step_1_success) { # Halt at step 1 - no_lib_msg <- paste0("Error: Couldn't fetch available Enrichr libraries. Please manually run `rba_enrichr_libs(store_in_options = TRUE)`. ", - "If the problem persists, kindly report this issue to us. The error message was: ", - try(enrichr_libs), - collapse = "\n") + no_lib_msg <- paste0( + "Error: Couldn't fetch available Enrichr libraries. Please manually run `rba_enrichr_libs(store_in_options = TRUE)`. ", + "If the problem persists, kindly report this issue to us. The error message was: ", + try(enrichr_libs), + collapse = "\n" + ) if (isTRUE(get("skip_error"))) { .msg(no_lib_msg) @@ -1022,11 +1120,13 @@ rba_enrichr <- function(gene_list, .msg("--Step 2/3:") Sys.sleep(2) - list_id <- rba_enrichr_add_list(gene_list = gene_list, - description = description, - organism = organism, - speedrichr = !is.null(background_genes), - ...) + list_id <- rba_enrichr_add_list( + gene_list = gene_list, + description = description, + organism = organism, + speedrichr = !is.null(background_genes), + ... + ) step_2_success <- exists("list_id") && utils::hasName(list_id, "userListId") @@ -1045,24 +1145,29 @@ rba_enrichr <- function(gene_list, if (step_2_success) { # proceed to step 3 .msg("--Step 3/3:") Sys.sleep(2) - enriched <- rba_enrichr_enrich(user_list_id = list_id$userListId, - gene_set_library = gene_set_library, - regex_library_name = regex_library_name, - background_id = background_id, - organism = organism, - progress_bar = progress_bar, - ...) + enriched <- rba_enrichr_enrich( + user_list_id = list_id$userListId, + gene_set_library = gene_set_library, + regex_library_name = regex_library_name, + background_id = background_id, + organism = organism, + progress_bar = progress_bar, + ... + ) step_3_success <- exists("enriched") && (is.list(enriched) || is.data.frame(enriched)) if (step_3_success) { # Finish step 3 return(enriched) } else { # Halt at step 3 - no_enriched_msg <- paste0("Error: Couldn't retrieve the submitted Enrichr analysis request. ", - "Please retry or manually run the required steps as demonstrated in the `Enrichr & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", - "If the problem persists, kindly report this issue to us. The error message was:", - try(enriched), - collapse = "\n") + no_enriched_msg <- paste0( + "Error: Couldn't retrieve the submitted Enrichr analysis request. ", + "Please retry or manually run the required steps as demonstrated in the `Enrichr & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", + "If the problem persists, kindly report this issue to us. The error message was:", + try(enriched), + collapse = "\n" + ) + if (isTRUE(get("skip_error"))) { .msg(no_enriched_msg) return(no_enriched_msg) @@ -1071,11 +1176,13 @@ rba_enrichr <- function(gene_list, } } } else { # Halt at step 2 - no_list_msg <- paste0("Error: Couldn't upload your genes list to Enrichr. ", - "Please retry or manually run the required steps as demonstrated in the `Enrichr & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", - "If the problem persists, kindly report this issue to us. The error message was: ", - try(list_id), - collapse = "\n") + no_list_msg <- paste0( + "Error: Couldn't upload your genes list to Enrichr. ", + "Please retry or manually run the required steps as demonstrated in the `Enrichr & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", + "If the problem persists, kindly report this issue to us. The error message was: ", + try(list_id), + collapse = "\n" + ) if (isTRUE(get("skip_error"))) { .msg(no_list_msg) return(no_list_msg) diff --git a/R/helper_functions.R b/R/helper_functions.R index 200cacc6..049a3583 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -12,20 +12,21 @@ #' @family internal_internet_connectivity #' @noRd .rba_api_check <- function(url, diagnostics = FALSE){ - request <- quote(httr::HEAD(url = url, - httr::timeout(getOption("rba_timeout")), - httr::user_agent(getOption("rba_user_agent")), - if (diagnostics) httr::verbose() - )) - test_result <- try(httr::status_code(eval(request)), - silent = !diagnostics) + request <- quote( + httr::HEAD( + url = url, + httr::timeout(getOption("rba_timeout")), + httr::user_agent(getOption("rba_user_agent")), + if (diagnostics) httr::verbose() + ) + ) + test_result <- try(httr::status_code(eval(request)), silent = !diagnostics) if (is.numeric(test_result)) { if (test_result == 200) { return(TRUE) } else { - return(.rba_http_status(test_result, - verbose = FALSE)) + return(.rba_http_status(test_result, verbose = FALSE)) } } else { return(test_result) @@ -70,19 +71,30 @@ rba_connection_test <- function(print_output = TRUE, diagnostics = FALSE) { timeout <- getOption("rba_timeout") skip_error <- getOption("rba_skip_error") - cat_if <- ifelse(test = isTRUE(print_output), - yes = function(...) {cat(...)}, - no = function(...) {invisible()}) + cat_if <- ifelse( + test = isTRUE(print_output), + yes = function(...) { cat(...) }, + no = function(...) { invisible() } + ) + # start tests - .msg("Checking Your connection to the Databases currently supported by rbioapi:", - cond = "print_output") + .msg( + "Checking Your connection to the Databases currently supported by rbioapi:", + cond = "print_output" + ) cat_if("--->>>", "Internet", ":\n") - google <- try(httr::status_code(httr::HEAD("https://google.com/", - if (diagnostics) httr::verbose(), - httr::user_agent(user_agent), - httr::timeout(timeout))) - , silent = TRUE) + google <- try( + httr::status_code( + httr::HEAD( + "https://google.com/", + if (diagnostics) httr::verbose(), + httr::user_agent(user_agent), + httr::timeout(timeout) + ) + ), + silent = TRUE + ) if (google == 200) { cat_if("+++ Connected to the Internet.\n") @@ -91,8 +103,10 @@ rba_connection_test <- function(print_output = TRUE, diagnostics = FALSE) { if (isTRUE(skip_error)) { return("Could not resolve `https://google.com`. Check Your internet Connection.") } else { - stop("Could not resolve `https://google.com`. Check Your internet Connection.", - call. = diagnostics) + stop( + "Could not resolve `https://google.com`. Check Your internet Connection.", + call. = diagnostics + ) } } @@ -188,32 +202,56 @@ rba_options <- function(diagnostics = NULL, skip_error = NULL, timeout = NULL, verbose = NULL) { - .rba_args(cond = list(list(quote(is.character(save_file)), - "As a global option, you can only set save_file to 'logical', not a file path."))) + + .rba_args( + cond = list( + list( + quote(is.character(save_file)), + "As a global option, you can only set save_file to 'logical', not a file path." + ) + ) + ) + ## if empty function was called, show the available options - changes <- vapply(X = ls(), - function(x) { - x <- get(x) - !(is.null(x) || is.na(x))}, - logical(1)) + changes <- vapply( + X = ls(), + function(x) { + x <- get(x) + !(is.null(x) || is.na(x)) + }, + logical(1) + ) + if (!any(changes)) { - options_df <- data.frame(rbioapi_option = getOption("rba_user_options"), - current_value = vapply(names(getOption("rba_user_options")), - function(x) {as.character(getOption(x))}, - character(1)), - allowed_value = getOption("rba_user_options_allowed"), - stringsAsFactors = FALSE, - row.names = NULL) + options_df <- data.frame( + rbioapi_option = getOption("rba_user_options"), + current_value = vapply( + names(getOption("rba_user_options")), + function(x) { as.character(getOption(x)) }, + character(1) + ), + allowed_value = getOption("rba_user_options_allowed"), + stringsAsFactors = FALSE, + row.names = NULL + ) return(options_df) } else { ## change the supplied options for (chng in names(changes[changes])) { chng_content <- get(chng) - eval(parse(text = sprintf(ifelse(is.character(chng_content), - yes = "options(%s = \"%s\")", - no = "options(%s = %s)"), - paste0("rba_", chng), - chng_content))) + eval( + parse( + text = sprintf( + ifelse( + is.character(chng_content), + yes = "options(%s = \"%s\")", + no = "options(%s = %s)" + ), + paste0("rba_", chng), + chng_content + ) + ) + ) } invisible() } @@ -233,24 +271,29 @@ rba_options <- function(diagnostics = NULL, .rba_pages_do <- function(input_call, pb_switch, sleep_time = 1) { if (pb_switch) { ## initiate progress bar - pb <- utils::txtProgressBar(min = 0, - max = length(input_call), - style = 3) + pb <- utils::txtProgressBar( + min = 0, + max = length(input_call), + style = 3 + ) pb_val <- 0 } #do the calls - output <- lapply(X = input_call, - FUN = function(x){ - Sys.sleep(sleep_time) - y <- eval(parse(text = x)) - if (pb_switch) { - # advance the progress bar - pb_now <- get("pb_val", envir = parent.frame(2)) - assign("pb_val", pb_now + 1, envir = parent.frame(2)) - utils::setTxtProgressBar(pb, pb_now + 1) - } - return(y) - }) + output <- lapply( + X = input_call, + FUN = function(x){ + Sys.sleep(sleep_time) + y <- eval(parse(text = x)) + if (pb_switch) { + # advance the progress bar + pb_now <- get("pb_val", envir = parent.frame(2)) + assign("pb_val", pb_now + 1, envir = parent.frame(2)) + utils::setTxtProgressBar(pb, pb_now + 1) + } + return(y) + } + ) + if (pb_switch) {close(pb)} return(output) } @@ -305,12 +348,15 @@ rba_options <- function(diagnostics = NULL, rba_pages <- function(input_call, ...){ ## Internal options ext_args <- list(...) - internal_opts <- list(verbose = TRUE, - sleep_time = 1, - page_check = TRUE, - add_skip_error = TRUE, - list_names = NA, - force_pb = NA) + internal_opts <- list( + verbose = TRUE, + sleep_time = 1, + page_check = TRUE, + add_skip_error = TRUE, + list_names = NA, + force_pb = NA + ) + if (length(ext_args) > 0) { internal_opts[names(ext_args)] <- ext_args } @@ -318,37 +364,57 @@ rba_pages <- function(input_call, ...){ ## Convert the input_call to character if (!inherits(input_call, "call")) { - stop("The call should be wrapped in qoute()", - call. = getOption("rba_diagnostics")) + stop( + "The call should be wrapped in qoute()", + call. = getOption("rba_diagnostics") + ) } - input_call <- gsub(pattern = "\\s+", - replacement = " ", - x = paste0(deparse(input_call), collapse = "")) + input_call <- gsub( + pattern = "\\s+", + replacement = " ", + x = paste0(deparse(input_call), collapse = "") + ) + if (!grepl("^rba_.+\\(", input_call)) { - stop("You should supply a rbioapi function.", - call. = getOption("rba_diagnostics")) + stop( + "You should supply a rbioapi function.", + call. = getOption("rba_diagnostics") + ) } ## Extract start and end pages - start_page <- unlist(regmatches(input_call, - gregexpr("(?<=\"pages:)\\d+(?=:\\d+\")", - input_call, perl = TRUE))) - end_page <- unlist(regmatches(input_call, - gregexpr("(?<=\\d:)\\d+(?=\")", - input_call, perl = TRUE))) + start_page <- unlist( + regmatches( + input_call, + gregexpr("(?<=\"pages:)\\d+(?=:\\d+\")", input_call, perl = TRUE) + ) + ) + + end_page <- unlist( + regmatches( + input_call, + gregexpr("(?<=\\d:)\\d+(?=\")", input_call, perl = TRUE) + ) + ) + start_page <- as.integer(start_page) end_page <- as.integer(end_page) + ## Check pages if (length(start_page) != 1 | length(end_page) != 1) { - stop("The variable you want to paginate should be formatted as:", - "`pages:start:end`.\nfor example: \"pages:1:5\".", - call. = getOption("rba_diagnostics")) + stop( + "The variable you want to paginate should be formatted as:", + "`pages:start:end`.\nfor example: \"pages:1:5\".", + call. = getOption("rba_diagnostics") + ) } if (isTRUE(internal_opts$page_check) && (end_page - start_page > 100)) { - stop("The maximum pages you are allowed to iterate are 100 pages.", - call. = getOption("rba_diagnostics")) + stop( + "The maximum pages you are allowed to iterate are 100 pages.", + call. = getOption("rba_diagnostics") + ) } ## Only show progress bar if verbose, diagnostics and progress bar are off @@ -371,19 +437,29 @@ rba_pages <- function(input_call, ...){ } ## Build the calls - elements_seq <- seq.int(from = start_page, to = end_page, - by = ifelse(test = start_page > end_page, - yes = -1L, - no = 1L)) + elements_seq <- seq.int( + from = start_page, + to = end_page, + by = ifelse(test = start_page > end_page, yes = -1L, no = 1L) + ) + # Add skip_error = TRUE and page numbers to the calls - input_call <- gsub(",\\s*skip_error\\s*=\\s*(TRUE|FALSE)", "", - input_call, perl = TRUE) - input_call <- sub(pattern = "\"pages:\\d+:\\d+\"", - replacement = ifelse(test = isFALSE(internal_opts$add_skip_error), - yes = "%s", - no = "%s, skip_error = TRUE"), - x = input_call, - perl = TRUE) + input_call <- gsub( + pattern = ",\\s*skip_error\\s*=\\s*(TRUE|FALSE)", + replacement = "", + x = input_call, + perl = TRUE + ) + input_call <- sub( + pattern = "\"pages:\\d+:\\d+\"", + replacement = ifelse( + test = isFALSE(internal_opts$add_skip_error), + yes = "%s", + no = "%s, skip_error = TRUE" + ), + x = input_call, + perl = TRUE + ) input_call <- as.list(sprintf(input_call, elements_seq)) @@ -395,10 +471,17 @@ rba_pages <- function(input_call, ...){ } ## Do the calls - .msg("Iterating from page %s to page %s.", start_page, end_page) - final_output <- .rba_pages_do(input_call, - pb_switch = pb_switch, - sleep_time = internal_opts$sleep_time) + .msg( + "Iterating from page %s to page %s.", + start_page, end_page + ) + + final_output <- .rba_pages_do( + input_call, + pb_switch = pb_switch, + sleep_time = internal_opts$sleep_time + ) + return(final_output) } diff --git a/R/internal_functions.R b/R/internal_functions.R index 187b5f7e..fbc6fc65 100644 --- a/R/internal_functions.R +++ b/R/internal_functions.R @@ -18,129 +18,137 @@ #' @noRd .rba_stg <- function(...){ arg <- c(...) - #possible arguments - output <- switch(arg[[1]], - db = c("enrichr", "ensembl","jaspar", "mieaa", "reactome", - "string", "uniprot"), - enrichr = switch( - arg[[2]], - name = "Enrichr", - url = "https://maayanlab.cloud", - pth = switch(match.arg(arg[[3]], - c("human", - "fly", - "yeast", - "worm", - "fish", - "speedrichr")), - human = "Enrichr/", - fly = "FlyEnrichr/", - yeast = "YeastEnrichr/", - worm = "WormEnrichr/", - fish = "FishEnrichr/", - speedrichr = "speedrichr/api/"), - ptn = "^(https?://)?(www\\.)?maayanlab\\.cloud/(.*Enrichr|speedrichr)/", - err_ptn = "^$" - ), - ensembl = switch( - arg[[2]], - name = "Ensembl", - url = "https://rest.ensembl.org", - ptn = "^(https?://)?(www\\.)?rest\\.ensembl\\.org/", - err_ptn = "^4\\d\\d$", - err_prs = list("json->list_simp", - function(x) {x[["error"]][[1]]}) - ), - jaspar = switch( - arg[[2]], - name = "JASPAR", - url = "https://jaspar.elixir.no/", - pth = "api/v1/", - ptn = "^(https?://)?(www\\.)?jaspar\\.elixir\\.no/api/", - err_ptn = "^$" - ), - mieaa = switch( - arg[[2]], - name = "MiEAA", - url = "https://ccb-compute2.cs.uni-saarland.de", - pth = "mieaa/api/v1/", - ptn = "^(https?://)?(www\\.)?ccb-compute2\\.cs\\.uni-saarland\\.de/mieaa2/", - err_ptn = "^4\\d\\d$", - err_prs = list("json->chr") - ), - panther = switch( - arg[[2]], - name = "PANTHER", - url = "https://www.pantherdb.org", - pth = "services/oai/pantherdb/", - ptn = "^(https?://)?(www\\.)?pantherdb\\.org/services/", - err_ptn = "^4\\d\\d&", - err_prs = list("json->list_simp", - function(x) {x$search$error}) - ), - reactome = switch( - arg[[2]], - name = "Reactome", - url = "https://reactome.org", - pth = switch(match.arg(arg[[3]], - c("analysis", - "content")), - analysis = "AnalysisService/", - content = "ContentService/"), - ptn = "^(https?://)?(www\\.)?reactome\\.org/(?:AnalysisService|ContentService)/", - err_ptn = "^4\\d\\d$", - err_prs = list("json->list_simp", - function(x) {x[["messages"]][[1]]}) - ), - string = switch( - arg[[2]], - name = "STRING", - url = "https://version-12-0.string-db.org", - pth = "api/", - ptn = "^(http.?://).*string-db\\.org/api/", - err_ptn = "^4\\d\\d$", - err_prs = list("json->list_simp", - function(x) {paste(x, collapse = "\n")}, - function(x) {gsub("<.+?>| ", "\n", x)}, - function(x) {gsub("(\n)+", "\n", x)}) - ), - uniprot = switch( - arg[[2]], - name = "UniProt", - url = "https://www.ebi.ac.uk", - pth = "proteins/api/", - ptn = "^(https?://)?(www\\.)?ebi\\.ac\\.uk/proteins/api/", - err_prs = list("json->list_simp", - function(x) {x[["errorMessage"]][[1]]}), - err_ptn = "^4\\d\\d$" - ), - options = switch( - as.character(length(arg)), - "1" = options()[grep("^rba_", - names(options()))], - getOption(arg[[2]])), - tests = list("Enrichr" = paste0(.rba_stg("enrichr", "url"), - "/Enrichr"), - "Ensembl" = paste0(.rba_stg("ensembl", "url"), - "/info/ping"), - "JASPAR" = paste0(.rba_stg("jaspar", "url"), - "/api/v1/releases/"), - "miEAA" = paste0(.rba_stg("mieaa", "url"), - "/mieaa2/api/"), - "PANTHER" = paste0(.rba_stg("panther", "url"), - "/services/api/panther"), - "Reactome Content Service" = paste0(.rba_stg("reactome", "url"), - "/ContentService/data/database/name"), - "Reactome Analysis Service" = paste0(.rba_stg("reactome", "url"), - "/AnalysisService/database/name"), - "STRING" = paste0(.rba_stg("string", "url"), - "/api/json/version"), - "UniProt" = paste0(.rba_stg("uniprot", "url"), - "/proteins/api/proteins/P25445") - ), - stop("Internal Error; .rba_stg was called with wrong parameters:\n", - paste0(arg, collapse = ", "), call. = TRUE) + + # Possible arguments + output <- switch( + arg[[1]], + db = c("enrichr", "ensembl","jaspar", "mieaa", "reactome", "string", "uniprot"), + enrichr = switch( + arg[[2]], + name = "Enrichr", + url = "https://maayanlab.cloud", + pth = switch( + match.arg( + arg[[3]], + c("human", "fly", "yeast", "worm", "fish", "speedrichr") + ), + human = "Enrichr/", + fly = "FlyEnrichr/", + yeast = "YeastEnrichr/", + worm = "WormEnrichr/", + fish = "FishEnrichr/", + speedrichr = "speedrichr/api/" + ), + ptn = "^(https?://)?(www\\.)?maayanlab\\.cloud/(.*Enrichr|speedrichr)/", + err_ptn = "^$" + ), + ensembl = switch( + arg[[2]], + name = "Ensembl", + url = "https://rest.ensembl.org", + ptn = "^(https?://)?(www\\.)?rest\\.ensembl\\.org/", + err_ptn = "^4\\d\\d$", + err_prs = list( + "json->list_simp", + function(x) { x[["error"]][[1]] } + ) + ), + jaspar = switch( + arg[[2]], + name = "JASPAR", + url = "https://jaspar.elixir.no/", + pth = "api/v1/", + ptn = "^(https?://)?(www\\.)?jaspar\\.elixir\\.no/api/", + err_ptn = "^$" + ), + mieaa = switch( + arg[[2]], + name = "MiEAA", + url = "https://ccb-compute2.cs.uni-saarland.de", + pth = "mieaa/api/v1/", + ptn = "^(https?://)?(www\\.)?ccb-compute2\\.cs\\.uni-saarland\\.de/mieaa2/", + err_ptn = "^4\\d\\d$", + err_prs = list("json->chr") + ), + panther = switch( + arg[[2]], + name = "PANTHER", + url = "https://www.pantherdb.org", + pth = "services/oai/pantherdb/", + ptn = "^(https?://)?(www\\.)?pantherdb\\.org/services/", + err_ptn = "^4\\d\\d&", + err_prs = list( + "json->list_simp", + function(x) { x$search$error } + ) + ), + reactome = switch( + arg[[2]], + name = "Reactome", + url = "https://reactome.org", + pth = switch( + match.arg( + arg[[3]], + c("analysis", "content") + ), + analysis = "AnalysisService/", + content = "ContentService/" + ), + ptn = "^(https?://)?(www\\.)?reactome\\.org/(?:AnalysisService|ContentService)/", + err_ptn = "^4\\d\\d$", + err_prs = list( + "json->list_simp", + function(x) { x[["messages"]][[1]] } + ) + ), + string = switch( + arg[[2]], + name = "STRING", + url = "https://version-12-0.string-db.org", + pth = "api/", + ptn = "^(http.?://).*string-db\\.org/api/", + err_ptn = "^4\\d\\d$", + err_prs = list( + "json->list_simp", + function(x) { paste(x, collapse = "\n") }, + function(x) { gsub("<.+?>| ", "\n", x) }, + function(x) { gsub("(\n)+", "\n", x) } + ) + ), + uniprot = switch( + arg[[2]], + name = "UniProt", + url = "https://www.ebi.ac.uk", + pth = "proteins/api/", + ptn = "^(https?://)?(www\\.)?ebi\\.ac\\.uk/proteins/api/", + err_prs = list( + "json->list_simp", + function(x) { x[["errorMessage"]][[1]] } + ), + err_ptn = "^4\\d\\d$" + ), + options = switch( + as.character(length(arg)), + "1" = options()[grep("^rba_", names(options()))], + getOption(arg[[2]]) + ), + tests = list( + "Enrichr" = paste0(.rba_stg("enrichr", "url"), "/Enrichr"), + "Ensembl" = paste0(.rba_stg("ensembl", "url"), "/info/ping"), + "JASPAR" = paste0(.rba_stg("jaspar", "url"), "/api/v1/releases/"), + "miEAA" = paste0(.rba_stg("mieaa", "url"), "/mieaa2/api/"), + "PANTHER" = paste0(.rba_stg("panther", "url"), "/services/api/panther"), + "Reactome Content Service" = paste0(.rba_stg("reactome", "url"), "/ContentService/data/database/name"), + "Reactome Analysis Service" = paste0(.rba_stg("reactome", "url"), "/AnalysisService/database/name"), + "STRING" = paste0(.rba_stg("string", "url"), "/api/json/version"), + "UniProt" = paste0(.rba_stg("uniprot", "url"), "/proteins/api/proteins/P25445") + ), + stop( + "Internal Error; .rba_stg was called with wrong parameters:\n", + paste0(arg, collapse = ", "), call. = TRUE + ) ) + return(output) } @@ -171,6 +179,7 @@ diagnostics = FALSE, skip_error = TRUE) { if (isTRUE(diagnostics)) {message("Testing the internet connection.")} + test_call <- quote( httr::status_code(httr::HEAD("https://www.google.com/", httr::timeout(getOption("rba_timeout")), @@ -180,6 +189,7 @@ retry_count <- 0 while (net_status != 200 && retry_count < retry_max) { + retry_count <- retry_count + 1 if (isTRUE(verbose)) { message(sprintf("No internet connection, waiting for %s seconds and retrying (retry count: %s/%s).", @@ -189,6 +199,7 @@ } Sys.sleep(retry_wait) net_status <- try(eval(test_call), silent = TRUE) + } #end of while if (net_status == 200) { @@ -222,94 +233,107 @@ http_status <- as.character(http_status) stopifnot(grepl("^[12345]\\d\\d$", http_status)) - resp <- switch(substr(http_status, 1, 1), - "1" = list(class = "Informational", - deff = switch( - http_status, - "100" = "Continue", - "101" = "Switching Protocols", - "102" = "Processing", - "103" = "Early Hints")), - "2" = list(class = "Success", - deff = switch( - http_status, - "200" = "OK", - "201" = "Created", - "202" = "Accepted", - "203" = "Non-Authoritative Information", - "204" = "No Content", - "205" = "Reset Content", - "206" = "Partial Content", - "207" = "Multi-Status", - "208" = "Already Reported", - "226" = "IM Used")), - "3" = list(class = "Redirection", - deff = switch( - http_status, - "300" = "Multiple Choices", - "301" = "Moved Permanently", - "302" = "Found", - "303" = "See Other", - "304" = "Not Modified", - "305" = "Use Proxy", - "306" = "Switch Proxy", - "307" = "Temporary Redirect", - "308" = "Permanent Redirect")), - "4" = list(class = "Redirection", - deff = switch( - http_status, - "400" = "Bad Request", - "401" = "Unauthorized", - "402" = "Payment Required", - "403" = "Forbidden", - "404" = "Not Found", - "405" = "Method Not Allowed", - "406" = "Not Acceptable", - "407" = "Proxy Authentication Required", - "408" = "Request Timeout", - "409" = "Conflict", - "410" = "Gone", - "411" = "Length Required", - "412" = "Precondition Failed", - "413" = "Payload Too Large", - "414" = "URI Too Long", - "415" = "Unsupported Media Type", - "416" = "Range Not Satisfiable", - "417" = "Expectation Failed", - "421" = "Misdirected Request", - "422" = "Unprocessable Entity", - "423" = "Locked", - "424" = "Failed Dependency", - "425" = "Too Early", - "426" = "Upgrade Required", - "428" = "Precondition Required", - "429" = "Too Many Requests", - "431" = "Request Header Fields Too Large", - "451" = "Unavailable For Legal Reasons")), - "5" = list(class = "Redirection", - deff = switch( - http_status, - "500" = "Internal Server Error", - "501" = "Not Implemented", - "502" = "Bad Gateway", - "503" = "Service Unavailable", - "504" = "Gateway Timeout", - "505" = "HTTP Version Not Supported", - "506" = "Variant Also Negotiates", - "507" = "Insufficient Storage", - "508" = "Loop Detected", - "510" = "Not Extended", - "511" = "Network Authentication Required")) + resp <- switch( + substr(http_status, 1, 1), + "1" = list( + class = "Informational", + deff = switch( + http_status, + "100" = "Continue", + "101" = "Switching Protocols", + "102" = "Processing", + "103" = "Early Hints") + ), + "2" = list( + class = "Success", + deff = switch( + http_status, + "200" = "OK", + "201" = "Created", + "202" = "Accepted", + "203" = "Non-Authoritative Information", + "204" = "No Content", + "205" = "Reset Content", + "206" = "Partial Content", + "207" = "Multi-Status", + "208" = "Already Reported", + "226" = "IM Used") + ), + "3" = list( + class = "Redirection", + deff = switch( + http_status, + "300" = "Multiple Choices", + "301" = "Moved Permanently", + "302" = "Found", + "303" = "See Other", + "304" = "Not Modified", + "305" = "Use Proxy", + "306" = "Switch Proxy", + "307" = "Temporary Redirect", + "308" = "Permanent Redirect") + ), + "4" = list( + class = "Redirection", + deff = switch( + http_status, + "400" = "Bad Request", + "401" = "Unauthorized", + "402" = "Payment Required", + "403" = "Forbidden", + "404" = "Not Found", + "405" = "Method Not Allowed", + "406" = "Not Acceptable", + "407" = "Proxy Authentication Required", + "408" = "Request Timeout", + "409" = "Conflict", + "410" = "Gone", + "411" = "Length Required", + "412" = "Precondition Failed", + "413" = "Payload Too Large", + "414" = "URI Too Long", + "415" = "Unsupported Media Type", + "416" = "Range Not Satisfiable", + "417" = "Expectation Failed", + "421" = "Misdirected Request", + "422" = "Unprocessable Entity", + "423" = "Locked", + "424" = "Failed Dependency", + "425" = "Too Early", + "426" = "Upgrade Required", + "428" = "Precondition Required", + "429" = "Too Many Requests", + "431" = "Request Header Fields Too Large", + "451" = "Unavailable For Legal Reasons") + ), + "5" = list( + class = "Redirection", + deff = switch( + http_status, + "500" = "Internal Server Error", + "501" = "Not Implemented", + "502" = "Bad Gateway", + "503" = "Service Unavailable", + "504" = "Gateway Timeout", + "505" = "HTTP Version Not Supported", + "506" = "Variant Also Negotiates", + "507" = "Insufficient Storage", + "508" = "Loop Detected", + "510" = "Not Extended", + "511" = "Network Authentication Required") + ) + ) + + output <- ifelse( + !is.null(resp$deff), + yes = sprintf("HTTP Status '%s' (%s: %s)", http_status, resp$class, resp$deff), + no = sprintf("HTTP Status '%s' (%s class)", http_status, resp$class) ) - output <- ifelse(!is.null(resp$deff), - yes = sprintf("HTTP Status '%s' (%s: %s)", - http_status, resp$class, resp$deff), - no = sprintf("HTTP Status '%s' (%s class)", - http_status, resp$class)) if (isTRUE(verbose)) { output <- sprintf("The server returned %s.", output) } + return(output) } @@ -342,35 +366,45 @@ ext_par <- ext_par$extra_pars } ## evaluate extra parameters - ext_evl <- vapply(X = ext_par, - FUN = function(x) { - if (length(x[[2]]) > 1) { - warning("Internal Query Builder:\n", - x[[1]], - " has more than one element. Only the first element will be used.", - call. = FALSE) - x[[2]] <- x[[2]][[1]] - } - if (isTRUE(x[[2]])) { - return(TRUE) - } else if (isFALSE(x[[2]])) { - return(FALSE)} - else { - warning("Internal Query Builder:\n The evaluation result of ", - x[[1]], - " is not TRUE or FALSE, thus skipping it.", - call. = FALSE) - return(FALSE)} - }, - FUN.VALUE = logical(1)) + ext_evl <- vapply( + X = ext_par, + FUN = function(x) { + + if (length(x[[2]]) > 1) { + warning( + "Internal Query Builder:\n", + x[[1]], + " has more than one element. Only the first element will be used.", + call. = FALSE + ) + x[[2]] <- x[[2]][[1]] + } + + if (isTRUE(x[[2]])) { + return(TRUE) + } else if (isFALSE(x[[2]])) { + return(FALSE) + } else { + warning( + "Internal Query Builder:\n The evaluation result of ", + x[[1]], + " is not TRUE or FALSE, thus skipping it.", + call. = FALSE + ) + return(FALSE)} + }, + FUN.VALUE = logical(1) + ) # extract extra parameters where theirs second element was TRUE - ext_val <- lapply(ext_par[ext_evl], function(x) {x[[3]]}) + ext_val <- lapply(ext_par[ext_evl], function(x) { x[[3]] }) # set names to the extracted parameters if (length(ext_val) >= 1) { - names(ext_val) <- vapply(ext_par[ext_evl], - function(x) {x[[1]]}, - character(1)) + names(ext_val) <- vapply( + ext_par[ext_evl], + function(x) { x[[1]] }, + character(1) + ) init <- append(init, ext_val) } return(init) @@ -416,89 +450,113 @@ path = "", ...) { ## assign global options - diagnostics <- get0("diagnostics", envir = parent.frame(1), - ifnotfound = getOption("rba_diagnostics")) - progress <- get0("progress", envir = parent.frame(1), - ifnotfound = getOption("rba_progress")) - timeout <- get0("timeout", envir = parent.frame(1), - ifnotfound = getOption("rba_timeout")) + diagnostics <- get0("diagnostics", envir = parent.frame(1), ifnotfound = getOption("rba_diagnostics")) + progress <- get0("progress", envir = parent.frame(1), ifnotfound = getOption("rba_progress")) + timeout <- get0("timeout", envir = parent.frame(1), ifnotfound = getOption("rba_timeout")) + ### 1 capture extra arguments # possible args: all args supported by httr + # args to this function: [file/obj_]accept, [file/obj_]parser, save_to ext_args <- list(...) ### 2 build main HTTP request (using httr) - httr_call <- list(switch(httr, - "get" = quote(httr::GET), - "post" = quote(httr::POST), - "head" = quote(httr::HEAD), - "put" = quote(httr::PUT), - "delete" = quote(httr::DELETE), - "patch" = quote(httr::PATCH), - stop("Internal Error; what verb to use with httr?", - call. = TRUE)), - url = utils::URLencode(URL = url, repeated = FALSE), - path = utils::URLencode(URL = path, repeated = FALSE), - quote(httr::user_agent(getOption("rba_user_agent"))), - quote(httr::timeout(timeout)) + httr_call <- list( + switch( + httr, + "get" = quote(httr::GET), + "post" = quote(httr::POST), + "head" = quote(httr::HEAD), + "put" = quote(httr::PUT), + "delete" = quote(httr::DELETE), + "patch" = quote(httr::PATCH), + stop("Internal Error; what verb to use with httr?", call. = TRUE) + ), + url = utils::URLencode(URL = url, repeated = FALSE), + path = utils::URLencode(URL = path, repeated = FALSE), + quote(httr::user_agent(getOption("rba_user_agent"))), + quote(httr::timeout(timeout)) ) + if (isTRUE(diagnostics)) { httr_call <- append(httr_call, quote(httr::verbose())) } + if (isTRUE(progress)) { httr_call <- append(httr_call, quote(httr::progress())) } ### 3 deal with extra arguments if (length(ext_args) >= 1) { + ### 3.1 check if there is "save to file vs return R object" scenario if (sum(utils::hasName(ext_args, "save_to"), utils::hasName(ext_args, "file_accept"), utils::hasName(ext_args, "obj_accept")) == 3) { ## 3.1.a it was up to the end-user to choose the response type if (isFALSE(ext_args$save_to)) { - httr_call <- append(httr_call, - list(str2lang(sprintf("httr::accept(\"%s\")", - ext_args$obj_accept)))) + httr_call <- append( + httr_call, + list( + str2lang(sprintf("httr::accept(\"%s\")", ext_args$obj_accept)) + ) + ) if (utils::hasName(ext_args, "obj_parser")) {parser <- ext_args$obj_parser} } else { - httr_call <- append(httr_call, - list(str2lang(sprintf("httr::accept(\"%s\")", - ext_args$file_accept)), - str2lang(sprintf("httr::write_disk(\"%s\", overwrite = TRUE)", - ext_args$save_to)) - )) + httr_call <- append( + httr_call, + list( + str2lang(sprintf("httr::accept(\"%s\")", ext_args$file_accept)), + str2lang(sprintf("httr::write_disk(\"%s\", overwrite = TRUE)", ext_args$save_to)) + ) + ) if (utils::hasName(ext_args, "file_parser")) {parser <- ext_args$file_parser} } + } else { + ## 3.1.b it was a pre-defined response type # accept header? if (utils::hasName(ext_args, "accept")) { - httr_call <- append(httr_call, - list(str2lang(sprintf("httr::accept(\"%s\")", - ext_args$accept)))) + httr_call <- append( + httr_call, + list( + str2lang(sprintf("httr::accept(\"%s\")", ext_args$accept)) + ) + ) } # save to file? if (utils::hasName(ext_args, "save_to") && !isFALSE(ext_args$save_to)) { - httr_call <- append(httr_call, - list(str2lang(sprintf("httr::write_disk(\"%s\", overwrite = TRUE)", - ext_args$save_to)))) + httr_call <- append( + httr_call, + list( + str2lang(sprintf("httr::write_disk(\"%s\", overwrite = TRUE)", ext_args$save_to)) + ) + ) } # parser? if (utils::hasName(ext_args, "parser")) { parser <- ext_args$parser } else { - parser <- function(x) {x} + parser <- function(x) { x } } + } + ### remove extra arguments that you don't want in httr function call ext_args <- ext_args[!grepl("^(?:accept|file_accept|obj_accept|save_to|\\w*parser)$", names(ext_args))] + } else { - parser <- function(x) {x} + + parser <- function(x) { x } + } #end of if (length(ext_args... - httr_call <- list(call = as.call(append(httr_call, ext_args)), - parser = parser) + + httr_call <- list( + call = as.call(append(httr_call, ext_args)), + parser = parser + ) + return(httr_call) } @@ -544,45 +602,62 @@ verbose = TRUE, diagnostics = FALSE) { ## 1 call API - response <- try(eval(input_call, envir = parent.frame(n = 2)), - silent = !diagnostics) + response <- try( + eval(input_call, envir = parent.frame(n = 2)), + silent = !diagnostics + ) + ## 2 check the internet connection & 5xx http status if (!inherits(response, "response") || substr(response$status_code, 1, 1) == "5") { + ## 2.1 there is an internet connection or server issue # wait for the internet connection - net_connected <- .rba_net_handle(retry_max = retry_max, - retry_wait = retry_wait, - verbose = verbose, - diagnostics = diagnostics, - skip_error = skip_error) + net_connected <- .rba_net_handle( + retry_max = retry_max, + retry_wait = retry_wait, + verbose = verbose, + diagnostics = diagnostics, + skip_error = skip_error + ) if (isTRUE(net_connected)) { ## 2.1.1 net_connection test is passed - response <- try(eval(input_call, envir = parent.frame(n = 2)), - silent = !diagnostics) + response <- try( + eval(input_call, envir = parent.frame(n = 2)), + silent = !diagnostics + ) } + } # end of step 2 ## 3 Decide what to return if (!inherits(response, "response")) { + ## 3.1 errors un-related to server's response - error_message <- ifelse(test = net_connected, - yes = as.character(response), - no = "No internet connection. Stopping code execution!") + error_message <- ifelse( + test = net_connected, + yes = as.character(response), + no = "No internet connection. Stopping code execution!" + ) if (isFALSE(diagnostics)) { - error_message <- gsub(pattern = "(^Error in .*?\\(.*?\\) :\\s*)|(\\s*$)", - replacement = "", - x = error_message, - perl = TRUE) + error_message <- gsub( + pattern = "(^Error in .*?\\(.*?\\) :\\s*)|(\\s*$)", + replacement = "", + x = error_message, + perl = TRUE + ) } + # stop or return error? if (isTRUE(skip_error)) { return(error_message) } else { stop(error_message, call. = diagnostics) } + } else if (substr(response$status_code, 1, 1) != "2") { + ## 3.2 API call was not successful error_message <- .rba_error_parser(response = response, verbose = verbose) if (isTRUE(skip_error)) { @@ -590,9 +665,12 @@ } else { stop(error_message, call. = diagnostics) } + } else { + ## 3.3 Everything is OK (HTTP status == 200) return(response) + } } @@ -625,23 +703,22 @@ .rba_skeleton <- function(input_call, response_parser = NULL) { ## 0 assign options variables - diagnostics <- get0("diagnostics", envir = parent.frame(1), - ifnotfound = getOption("rba_diagnostics")) - verbose <- get0("verbose", envir = parent.frame(1), - ifnotfound = getOption("rba_verbose")) - retry_max <- get0("retry_max", envir = parent.frame(1), - ifnotfound = getOption("rba_retry_max")) - retry_wait <- get0("retry_wait", envir = parent.frame(1), - ifnotfound = getOption("rba_retry_wait")) - skip_error <- get0("skip_error", envir = parent.frame(1), - ifnotfound = getOption("rba_skip_error")) + diagnostics <- get0("diagnostics", envir = parent.frame(1), ifnotfound = getOption("rba_diagnostics")) + verbose <- get0("verbose", envir = parent.frame(1), ifnotfound = getOption("rba_verbose")) + retry_max <- get0("retry_max", envir = parent.frame(1), ifnotfound = getOption("rba_retry_max")) + retry_wait <- get0("retry_wait", envir = parent.frame(1), ifnotfound = getOption("rba_retry_wait")) + skip_error <- get0("skip_error", envir = parent.frame(1), ifnotfound = getOption("rba_skip_error")) + ## 1 Make API Call - response <- .rba_api_call(input_call = input_call$call, - skip_error = skip_error, - retry_max = retry_max, - retry_wait = retry_wait, - verbose = verbose, - diagnostics = diagnostics) + response <- .rba_api_call( + input_call = input_call$call, + skip_error = skip_error, + retry_max = retry_max, + retry_wait = retry_wait, + verbose = verbose, + diagnostics = diagnostics + ) + ## 2 Parse the the response if possible # Parser supplied via .rba_skeleton's 'response parser' argument will # override the 'parser' supplied in input call @@ -655,35 +732,45 @@ if (inherits(response, "response")) { # There is a HTTP response, not an error message if (!is.null(parser_input)) { + # A parser is provided for the response - parsed_response <- try(.rba_response_parser(response = response, - parsers = parser_input), - silent = TRUE) + parsed_response <- try( + .rba_response_parser(response = response, parsers = parser_input), + silent = TRUE + ) if (!inherits(parsed_response, "try-error")) { return(parsed_response) } else if (identical(httr::content(response, as = "text", encoding = "UTF-8"), "")) { return(NULL) } else { - parse_error_msg <- paste("Internal Error:", - "Failed to parse the server's response.", - "This is probably because the server has changed the response format.", - "Please report this bug to us:", - "\n", - parsed_response, - sep = " ") + parse_error_msg <- paste( + "Internal Error:", + "Failed to parse the server's response.", + "This is probably because the server has changed the response format.", + "Please report this bug to us:", + "\n", + parsed_response, + sep = " " + ) if (isTRUE(skip_error)) { return(parse_error_msg) } else { stop(parse_error_msg, call. = TRUE) } } + } else { + # No parser is provided for the response return(invisible(NULL)) + } + } else { + return(response) + } } @@ -712,23 +799,31 @@ .rba_args_req <- function(cons, n = 2) { # List required arguments *arguments with no default value f_name <- as.character(sys.calls()[[sys.nframe() - n]])[[1]] - f_args <- try(names(formals(f_name)), - silent = TRUE) + f_args <- try( + names(formals(f_name)), + silent = TRUE + ) + if (!inherits(f_args, "try-error")) { + f <- paste0(deparse(get(f_name)), collapse = "") - req <- regmatches(f, - regexpr("(?<=^function \\().*?(?=\\)\\s{)", - f, perl = TRUE)) - req <- f_args[!grepl(pattern = "(=)|(\\.\\.\\.)", - x = unlist(strsplit(req, ",")))] + req <- regmatches( + f, + regexpr("(?<=^function \\().*?(?=\\)\\s{)", + f, perl = TRUE) + ) + req <- f_args[!grepl(pattern = "(=)|(\\.\\.\\.)", x = unlist(strsplit(req, ",")))] # Add `na_null = TRUE` to the required function - cons <- lapply(X = cons, - FUN = function(x) { - if (x[["arg"]] %in% req) { - x[["no_null"]] <- TRUE - } - return(x) - }) + cons <- lapply( + X = cons, + FUN = function(x) { + if (x[["arg"]] %in% req) { + x[["no_null"]] <- TRUE + } + return(x) + } + ) + } return(cons) @@ -757,51 +852,47 @@ #' @noRd .rba_args_opts <- function(cons = NULL, cond = NULL, what) { if (what == "cons") { - ext_cons <- list(timeout = list(arg = "timeout", - class = "numeric", - len = 1, - ran = c(0.001, 3600)), - dir_name = list(arg = "dir_name", - class = "character", - len = 1), - diagnostics = list(arg = "diagnostics", - class = "logical", - len = 1), - retry_max = list(arg = "retry_max", - class = "numeric", - len = 1), - progress = list(arg = "progress", - class = "logical", - len = 1), - save_file = list(arg = "save_file", - class = c("logical", - "character"), - len = 1), - skip_error = list(arg = "skip_error", - class = "logical", - len = 1), - verbose = list(arg = "verbose", - class = "logical", - len = 1), - retry_wait = list(arg = "retry_wait", - class = "numeric", - len = 1, - min_val = 0)) - cons <- append(ext_cons[names(ext_cons) %in% ls(envir = parent.frame(2))], - cons) + + ext_cons <- list( + timeout = list(arg = "timeout", class = "numeric", len = 1, ran = c(0.001, 3600)), + dir_name = list(arg = "dir_name", class = "character", len = 1), + diagnostics = list(arg = "diagnostics", class = "logical", len = 1), + retry_max = list(arg = "retry_max", class = "numeric", len = 1), + progress = list(arg = "progress", class = "logical", len = 1), + save_file = list(arg = "save_file", class = c("logical", "character"), len = 1), + skip_error = list(arg = "skip_error", class = "logical", len = 1), + verbose = list(arg = "verbose", class = "logical", len = 1), + retry_wait = list(arg = "retry_wait", class = "numeric", len = 1, min_val = 0) + ) + cons <- append( + ext_cons[names(ext_cons) %in% ls(envir = parent.frame(2))], + cons + ) return(cons) + } else if (what == "cond") { - ext_cond <- list(dir_name = list(quote(grepl("[\\\\/:\"*?<>|]+", dir_name, perl = TRUE)), - "Invalid dir_name. Directory name cannot include these characters: \\/?%*:|<>"), - save_file = list(quote(!is.logical(save_file) && - !grepl("^[a-zA-z]:|^\\\\\\w|^/|\\w+\\.\\w+$", - save_file)), - "Invalid save_file. You should set it to 'logical' or 'a valid file path'.")) - cond <- append(ext_cond[names(ext_cond) %in% ls(envir = parent.frame(2))], - cond) + + ext_cond <- list( + dir_name = list( + quote(grepl("[\\\\/:\"*?<>|]+", dir_name, perl = TRUE)), + "Invalid dir_name. Directory name cannot include these characters: \\/?%*:|<>" + ), + save_file = list( + quote(!is.logical(save_file) && !grepl("^[a-zA-z]:|^\\\\\\w|^/|\\w+\\.\\w+$", save_file)), + "Invalid save_file. You should set it to 'logical' or 'a valid file path'." + ) + ) + cond <- append( + ext_cond[names(ext_cond) %in% ls(envir = parent.frame(2))], + cond + ) + return(cond) + } else { + stop("Internal Error; `what` should be `cons` or `cond.`", call. = TRUE) + } } @@ -821,24 +912,35 @@ #' @noRd .rba_args_cons_chk <- function(cons_i, what) { if (!is.null(cons_i[["evl_arg"]])) { - output <- all(switch(what, - "class" = class(cons_i[["evl_arg"]]) %in% cons_i[["class"]], - "val" = all(cons_i[["evl_arg"]] %in% cons_i[["val"]]), - "ran" = all(cons_i[["evl_arg"]] >= cons_i[["ran"]][[1]], - cons_i[["evl_arg"]] <= cons_i[["ran"]][[2]]), - "len" = length(cons_i[["evl_arg"]]) == cons_i[["len"]], - "min_len" = length(cons_i[["evl_arg"]]) >= cons_i[["min_len"]], - "max_len" = length(cons_i[["evl_arg"]]) <= cons_i[["max_len"]], - "min_val" = cons_i[["evl_arg"]] >= cons_i[["min_val"]], - "max_val" = cons_i[["evl_arg"]] <= cons_i[["max_val"]], - "regex" = grepl(pattern = cons_i[["regex"]], - x = cons_i[["evl_arg"]], - ignore.case = FALSE, perl = TRUE), - stop("Internal Error; constrian is not defiend: ", - what, call. = TRUE))) + + output <- all( + switch( + what, + "class" = class(cons_i[["evl_arg"]]) %in% cons_i[["class"]], + "val" = all(cons_i[["evl_arg"]] %in% cons_i[["val"]]), + "ran" = all( + cons_i[["evl_arg"]] >= cons_i[["ran"]][[1]], + cons_i[["evl_arg"]] <= cons_i[["ran"]][[2]] + ), + "len" = length(cons_i[["evl_arg"]]) == cons_i[["len"]], + "min_len" = length(cons_i[["evl_arg"]]) >= cons_i[["min_len"]], + "max_len" = length(cons_i[["evl_arg"]]) <= cons_i[["max_len"]], + "min_val" = cons_i[["evl_arg"]] >= cons_i[["min_val"]], + "max_val" = cons_i[["evl_arg"]] <= cons_i[["max_val"]], + "regex" = grepl( + pattern = cons_i[["regex"]], + x = cons_i[["evl_arg"]], + ignore.case = FALSE, perl = TRUE + ), + stop("Internal Error; constrian is not defiend: ", what, call. = TRUE) + ) + ) return(output) + } else { + return(TRUE) + } } @@ -857,49 +959,66 @@ #' @family internal_arguments_check #' @noRd .rba_args_cons_msg <- function(cons_i, what) { - switch(what, - "no_null" = sprintf("Invalid Argument: `%s` cannot be NULL.", - cons_i[["arg"]]), - "class" = sprintf("Invalid Argument: %s should be of class `%s`.\n\t(Your supplied argument is \"%s\".)", - cons_i[["arg"]], - .paste2(cons_i[["class"]], last = " or ", - quote = "\""), - class(cons_i[["evl_arg"]])), - "val" = sprintf("Invalid Argument: %s should be either `%s`.\n\t(Your supplied argument is `%s`.)", - cons_i[["arg"]], - .paste2(cons_i[["val"]], last = " or ", - quote = "\""), - cons_i[["evl_arg"]]), - "ran" = sprintf("Invalid Argument: %s should be `from %s to %s`.\n\t(Your supplied argument is `%s`.)", - cons_i[["arg"]], - cons_i[["ran"]][[1]], - cons_i[["ran"]][[2]], - cons_i[["evl_arg"]]), - "len" = sprintf("Invalid Argument: %s should be of length `%s`.\n\t(Your supplied argument's length is `%s`.)", - cons_i[["arg"]], - cons_i[["len"]], - length(cons_i[["evl_arg"]])), - "min_len" = sprintf("Invalid Argument: %s should be of minimum length `%s`.\n\t(Your supplied argument's length is `%s`.)", - cons_i[["arg"]], - cons_i[["min_len"]], - length(cons_i[["evl_arg"]])), - "max_len" = sprintf("Invalid Argument: %s should be of maximum length `%s`.\n\t(Your supplied argument's length is `%s`.)", - cons_i[["arg"]], - cons_i[["max_len"]], - length(cons_i[["evl_arg"]])), - "min_val" = sprintf("Invalid Argument: %s should be equal to or greater than `%s`.\n\t(Your supplied argument is `%s`.)", - cons_i[["arg"]], - cons_i[["min_val"]], - cons_i[["evl_arg"]]), - "max_val" = sprintf("Invalid Argument: %s should be equal to or less than `%s`.\n\t(Your supplied argument is `%s`.)", - cons_i[["arg"]], - cons_i[["max_val"]], - cons_i[["evl_arg"]]), - "regex" = sprintf("Invalid Argument: %s do not have a valid format.\n\t(It should match regex pattern: %s ).", - cons_i[["arg"]], - cons_i[["regex"]]), - stop("Internal Error: constrian message is not defiend: ", - what, call. = TRUE) + switch( + what, + "no_null" = sprintf( + "Invalid Argument: `%s` cannot be NULL.", cons_i[["arg"]] + ), + "class" = sprintf( + "Invalid Argument: %s should be of class `%s`.\n\t(Your supplied argument is \"%s\".)", + cons_i[["arg"]], + .paste2(cons_i[["class"]], last = " or ", quote = "\""), + class(cons_i[["evl_arg"]]) + ), + "val" = sprintf( + "Invalid Argument: %s should be either `%s`.\n\t(Your supplied argument is `%s`.)", + cons_i[["arg"]], + .paste2(cons_i[["val"]], last = " or ", quote = "\""), + cons_i[["evl_arg"]] + ), + "ran" = sprintf( + "Invalid Argument: %s should be `from %s to %s`.\n\t(Your supplied argument is `%s`.)", + cons_i[["arg"]], + cons_i[["ran"]][[1]], + cons_i[["ran"]][[2]], + cons_i[["evl_arg"]] + ), + "len" = sprintf( + "Invalid Argument: %s should be of length `%s`.\n\t(Your supplied argument's length is `%s`.)", + cons_i[["arg"]], + cons_i[["len"]], + length(cons_i[["evl_arg"]]) + ), + "min_len" = sprintf( + "Invalid Argument: %s should be of minimum length `%s`.\n\t(Your supplied argument's length is `%s`.)", + cons_i[["arg"]], + cons_i[["min_len"]], + length(cons_i[["evl_arg"]]) + ), + "max_len" = sprintf( + "Invalid Argument: %s should be of maximum length `%s`.\n\t(Your supplied argument's length is `%s`.)", + cons_i[["arg"]], + cons_i[["max_len"]], + length(cons_i[["evl_arg"]]) + ), + "min_val" = sprintf( + "Invalid Argument: %s should be equal to or greater than `%s`.\n\t(Your supplied argument is `%s`.)", + cons_i[["arg"]], + cons_i[["min_val"]], + cons_i[["evl_arg"]] + ), + "max_val" = sprintf( + "Invalid Argument: %s should be equal to or less than `%s`.\n\t(Your supplied argument is `%s`.)", + cons_i[["arg"]], + cons_i[["max_val"]], + cons_i[["evl_arg"]] + ), + "regex" = sprintf( + "Invalid Argument: %s do not have a valid format.\n\t(It should match regex pattern: %s ).", + cons_i[["arg"]], + cons_i[["regex"]] + ), + stop("Internal Error: constrian message is not defiend: ", what, call. = TRUE) ) } @@ -917,6 +1036,7 @@ #' @noRd .rba_args_cons_wrp <- function(cons_i) { if (is.null(cons_i[["evl_arg"]])) { + # check if the NULL argument is required or optional if (isTRUE(cons_i[["no_null"]])) { #it is not optional! @@ -925,23 +1045,28 @@ # It is optional, don't run the arguments check. return(NA) } + } else { + # argument is not NULL (user supplied something) all_cons <- setdiff(names(cons_i), c("arg", "class", "evl_arg", "no_null")) - cons_i_errs <- lapply(all_cons, - function(x){ - if (.rba_args_cons_chk(cons_i = cons_i, what = x)) { - return(NA) - } else { - return(.rba_args_cons_msg(cons_i = cons_i, what = x)) - } - }) + cons_i_errs <- lapply( + all_cons, + function(x){ + if (.rba_args_cons_chk(cons_i = cons_i, what = x)) { + return(NA) + } else { + return(.rba_args_cons_msg(cons_i = cons_i, what = x)) + } + } + ) if (any(!is.na(cons_i_errs))) { return(unlist(cons_i_errs[which(!is.na(cons_i_errs))])) } else { return(NA) } #end of any(!is.na(cons_i_errs)) + } #end of if (is.null(cons_i[["evl_arg"]])) } @@ -964,36 +1089,64 @@ #' @noRd .rba_args_cond <- function(cond_i) { if (is.call(cond_i[[1]])) { + cond_i_1 <- eval(cond_i[[1]], envir = parent.frame(3)) + } else if (is.character(cond_i[[1]])) { + cond_i_1 <- eval(parse(text = cond_i[[1]]), envir = parent.frame(3)) + } else { - stop("Internal Error; the first element in the condition sublist", - "should be either a charachter or quoted call!", call. = TRUE) + + stop( + "Internal Error; the first element in the condition sublist", + "should be either a charachter or quoted call!", + call. = TRUE + ) + } + ## Create an Error message if (isTRUE(cond_i_1)) { - err_obj <- switch(as.character(length(cond_i)), - "2" = { - if (is.character(cond_i[[2]])) { - list(msg = cond_i[[2]], - warn = FALSE) - } else { - list(msg = sprintf("Argument's conditions are not satisfied; `%s` is TRUE.", - as.character(enquote(cond_i[[1]]))[[2]]), - warn = isTRUE(cond_i[[2]])) - }}, - "3" = list(msg = cond_i[[2]], - warn = isTRUE(cond_i[[3]])), - "1" = list(msg = sprintf("Argument's conditions are not satisfied; `%s` is TRUE.", - as.character(enquote(cond_i[[1]]))[[2]]), - warn = FALSE), - stop("Internal Error; invalid condition: ", - enquote(cond_i[[1]])[[2]], call. = TRUE) + + err_obj <- switch( + as.character(length(cond_i)), + "2" = { + if (is.character(cond_i[[2]])) { + list( + msg = cond_i[[2]], + warn = FALSE + ) + } else { + list( + msg = sprintf( + "Argument's conditions are not satisfied; `%s` is TRUE.", + as.character(enquote(cond_i[[1]]))[[2]] + ), + warn = isTRUE(cond_i[[2]]) + ) + } + }, + "3" = list( + msg = cond_i[[2]], + warn = isTRUE(cond_i[[3]]) + ), + "1" = list( + msg = sprintf( + "Argument's conditions are not satisfied; `%s` is TRUE.", + as.character(enquote(cond_i[[1]]))[[2]] + ), + warn = FALSE + ), + stop("Internal Error; invalid condition: ", enquote(cond_i[[1]])[[2]], call. = TRUE) ) return(err_obj) + } else { - return(NA)} + + return(NA) + + } } #' Internal user's Arguments Check @@ -1055,52 +1208,69 @@ ### 2 Check Arguments errors <- c() ## 2.1 check if the supplied object can be evaluated - cons <- lapply(X = cons, - FUN = function(cons_i){ - cons_i[["evl_arg"]] <- try(expr = get(x = cons_i[["arg"]], - envir = parent.frame(3)), - silent = TRUE) - return(cons_i) - }) - cons_not_exist <- vapply(X = cons, - FUN = function(x) { - inherits(x[["evl_arg"]], "try-error") - }, - FUN.VALUE = logical(1)) + cons <- lapply( + X = cons, + FUN = function(cons_i){ + cons_i[["evl_arg"]] <- try( + expr = get(x = cons_i[["arg"]], envir = parent.frame(3)), + silent = TRUE + ) + return(cons_i) + } + ) + cons_not_exist <- vapply( + X = cons, + FUN = function(x) { + inherits(x[["evl_arg"]], "try-error") + }, + FUN.VALUE = logical(1) + ) if (any(cons_not_exist)) { # some object didn't exist! + #generate errors - errors <- append(errors, - vapply(X = cons[cons_not_exist], - FUN = function(x){ - error_message <- regmatches(x[["evl_arg"]], - regexpr("(?<=(Error: )|(Error : )).*?(?=\n)", - x[["evl_arg"]], perl = TRUE)) - return(ifelse(length(error_message) == 0, - yes = sub("^Error in.*: +\n", "", x[["evl_arg"]][[1]], perl = TRUE), - no = error_message - )) - }, - FUN.VALUE = character(1) - )) + errors <- append( + errors, + vapply( + X = cons[cons_not_exist], + FUN = function(x){ + error_message <- regmatches( + x[["evl_arg"]], + regexpr("(?<=(Error: )|(Error : )).*?(?=\n)", x[["evl_arg"]], perl = TRUE) + ) + return( + ifelse( + length(error_message) == 0, + yes = sub("^Error in.*: +\n", "", x[["evl_arg"]][[1]], perl = TRUE), + no = error_message + ) + ) + }, + FUN.VALUE = character(1) + ) + ) #remove from cons cons <- cons[!cons_not_exist] + } + ## 2.2 check class - class_errs <- lapply(cons, - function(x) { - if (.rba_args_cons_chk(cons_i = x, what = "class")) { - return(NA) - } else { - return(.rba_args_cons_msg(cons_i = x, - what = "class")) - } - }) + class_errs <- lapply( + cons, + function(x) { + if (.rba_args_cons_chk(cons_i = x, what = "class")) { + return(NA) + } else { + return(.rba_args_cons_msg(cons_i = x, what = "class")) + } + } + ) if (any(!is.na(class_errs))) { errors <- append(errors, unlist(class_errs[!is.na(class_errs)])) cons <- cons[is.na(class_errs)] # remove elements with wrong class } + ## 2.3 check other constrains if their class is correct ### Add no_null for arguments with no default value cons <- .rba_args_req(cons = cons, n = 2) @@ -1110,15 +1280,21 @@ if (any(!is.na(other_errs))) { errors <- append(errors, other_errs[!is.na(other_errs)]) } + ## 2.4 Take actions for the errors if (length(errors) == 1) { + stop(errors, call. = diagnostics) + } else if (length(errors) > 1) { + error_message <- paste0("\n", seq_along(errors), "- ", errors) - stop(sprintf("Your supplied arguments contains the following `%s Errors`.", - length(errors)), - error_message, - call. = diagnostics) + stop( + sprintf("Your supplied arguments contains the following `%s Errors`.", length(errors)), + error_message, + call. = diagnostics + ) + } ### 3 Check relationship between arguments @@ -1132,16 +1308,16 @@ if (length(cond_err) == 1) { cond_msg <- cond_err[[1]][["msg"]] } else if (length(cond_err) > 1) { - cond_msg <- paste0("\n", seq_along(cond_err), "- ", - vapply(X = cond_err, - FUN = function(x){ - x[["msg"]] - }, - FUN.VALUE = character(1)), - collapse = "") - cond_msg <- sprintf("Your supplied arguments contains the following `%s Conditional Issues`.:%s", - length(cond_msg), - cond_msg) + cond_msg <- paste0( + "\n", seq_along(cond_err), "- ", + vapply(X = cond_err, FUN = function(x) { x[["msg"]] }, FUN.VALUE = character(1)), + collapse = "" + ) + cond_msg <- sprintf( + "Your supplied arguments contains the following `%s Conditional Issues`.:%s", + length(cond_msg), + cond_msg + ) } ## 3.3 Take actions for the errors if (cond_warning == TRUE || all(vapply(X = cond_err, @@ -1185,81 +1361,95 @@ #' @noRd .rba_response_parser <- function(response, parsers) { if (!is.vector(parsers)) { parsers <- list(parsers)} - parsers <- sapply(X = parsers, - FUN = function(parser){ - #create a parser if not supplied - if (!is.function(parser)) { - parser <- switch( - parser, - "json->df" = function(x) { - data.frame(jsonlite::fromJSON(httr::content(x, - as = "text", - encoding = "UTF-8"), - flatten = TRUE), - stringsAsFactors = FALSE) - }, - "json->df_no_flat" = function(x) { - data.frame(jsonlite::fromJSON(httr::content(x, - as = "text", - encoding = "UTF-8"), - flatten = FALSE), - stringsAsFactors = FALSE) - }, - "json->list_simp" = function(x) { - as.list(jsonlite::fromJSON(httr::content(x, - as = "text", - encoding = "UTF-8"), - simplifyVector = TRUE)) - }, - "json->list_simp_flt_df" = function(x) { - sapply(X = as.list(jsonlite::fromJSON(httr::content(x, - as = "text", - encoding = "UTF-8"), - simplifyVector = TRUE)), - FUN = function(y){ - if (is.data.frame(y)) { - jsonlite::flatten(y) - } else { - y - } - }) - - }, - "json->list" = function(x) { - as.list(jsonlite::fromJSON(httr::content(x, - as = "text", - encoding = "UTF-8"), - simplifyVector = FALSE)) - }, - "json->chr" = function(x) { - as.character(jsonlite::fromJSON(httr::content(x, - as = "text", - encoding = "UTF-8"))) - }, - "text->chr" = function(x) { - as.character(httr::content(x, - as = "text", - encoding = "UTF-8")) - }, - "text->df" = function(x) { - utils::read.table(text = httr::content(x, - type = "text/plain", - as = "text", - encoding = "UTF-8"), - header = FALSE, - stringsAsFactors = FALSE) - }, - "tsv->df" = function(x) { - as.character(httr::content(x, - as = "text", - encoding = "UTF-8")) - }, - stop("Internal Error; Specify a valid parser name or supply a function!", - call. = TRUE) - ) - } - return(parser) - }) + + parsers <- sapply( + X = parsers, + FUN = function(parser){ + #create a parser if not supplied + if (!is.function(parser)) { + parser <- switch( + parser, + "json->df" = function(x) { + data.frame( + jsonlite::fromJSON( + httr::content(x, as = "text", encoding = "UTF-8"), + flatten = TRUE + ), + stringsAsFactors = FALSE + ) + }, + "json->df_no_flat" = function(x) { + data.frame( + jsonlite::fromJSON( + httr::content(x, as = "text", encoding = "UTF-8"), + flatten = FALSE + ), + stringsAsFactors = FALSE + ) + }, + "json->list_simp" = function(x) { + as.list( + jsonlite::fromJSON( + httr::content(x, as = "text", encoding = "UTF-8"), + simplifyVector = TRUE + ) + ) + }, + "json->list_simp_flt_df" = function(x) { + sapply( + X = as.list( + jsonlite::fromJSON( + httr::content(x, as = "text", encoding = "UTF-8"), + simplifyVector = TRUE + ) + ), + FUN = function(y){ + if (is.data.frame(y)) { + jsonlite::flatten(y) + } else { + y + } + } + ) + }, + "json->list" = function(x) { + as.list( + jsonlite::fromJSON( + httr::content(x, as = "text", encoding = "UTF-8"), + simplifyVector = FALSE + ) + ) + }, + "json->chr" = function(x) { + as.character( + jsonlite::fromJSON( + httr::content(x, as = "text", encoding = "UTF-8") + ) + ) + }, + "text->chr" = function(x) { + as.character( + httr::content(x, as = "text", encoding = "UTF-8") + ) + }, + "text->df" = function(x) { + utils::read.table( + text = httr::content(x, type = "text/plain", as = "text", encoding = "UTF-8"), + header = FALSE, + stringsAsFactors = FALSE + ) + }, + "tsv->df" = function(x) { + as.character( + httr::content(x, as = "text", encoding = "UTF-8") + ) + }, + stop("Internal Error; Specify a valid parser name or supply a function!", call. = TRUE) + ) + } + return(parser) + } + ) # sequentially handle the response to the parsers for (parser in seq_along(parsers)) { @@ -1294,12 +1484,14 @@ .rba_error_parser <- function(response, verbose = FALSE) { ## detect the database name - dbs <- vapply(X = .rba_stg("db"), - FUN = function(db) { - grepl(.rba_stg(db, "ptn"), response$url, - perl = TRUE, ignore.case = TRUE)}, - FUN.VALUE = logical(1) + dbs <- vapply( + X = .rba_stg("db"), + FUN = function(db) { + grepl(.rba_stg(db, "ptn"), response$url, perl = TRUE, ignore.case = TRUE) + }, + FUN.VALUE = logical(1) ) + db <- names(dbs)[dbs] ## parse the error if (length(db) == 1 && @@ -1309,19 +1501,15 @@ sprintf( "%s server returned \"%s\".\n With this error message:\n \"%s\"", .rba_stg(db, "name"), - .rba_http_status(http_status = response$status_code, - verbose = FALSE), - .rba_response_parser(response = response, - parsers = .rba_stg(db, "err_prs")) + .rba_http_status(http_status = response$status_code, verbose = FALSE), + .rba_response_parser(response = response, parsers = .rba_stg(db, "err_prs")) )}, error = function(e) { - .rba_http_status(http_status = response$status_code, - verbose = verbose) + .rba_http_status(http_status = response$status_code, verbose = verbose) }) } else { ## The API server returns only status code with no error string - error_message <- .rba_http_status(http_status = response$status_code, - verbose = verbose) + error_message <- .rba_http_status(http_status = response$status_code, verbose = verbose) } return(error_message) } @@ -1350,14 +1538,18 @@ #' #' @family internal_misc #' @noRd -.msg <- function(fmt, ..., sprintf = TRUE, cond = "verbose", - sep = "", collapse = NULL) { +.msg <- function(fmt, + ..., + sprintf = TRUE, + cond = "verbose", + sep = "", + collapse = NULL) { if (isTRUE(get0(cond, envir = parent.frame(1), ifnotfound = FALSE))) { - m <- ifelse(isTRUE(sprintf) && - is.character(fmt) && - grepl("%s", fmt, fixed = TRUE), - yes = sprintf(fmt, ...), - no = paste(fmt, ..., sep = sep, collapse = collapse)) + m <- ifelse( + isTRUE(sprintf) && is.character(fmt) && grepl("%s", fmt, fixed = TRUE), + yes = sprintf(fmt, ...), + no = paste(fmt, ..., sep = sep, collapse = collapse) + ) if (!is.na(m)) { message(m, appendLF = TRUE) } @@ -1381,17 +1573,19 @@ #' @family internal_misc #' @noRd .paste2 <- function(..., - last = " and ", sep = ", ", - quote = NULL, quote_all = NULL) { + last = " and ", + sep = ", ", + quote = NULL, + quote_all = NULL) { input <- c(...) len <- length(input) if (!is.null(quote)) { input <- sprintf("%s%s%s", quote, input, quote) } if (len > 1) { - input <- paste(paste0(input[-len], collapse = sep), - input[len], - sep = last) + input <- paste( + paste0(input[-len], collapse = sep), input[len], sep = last + ) } if (!is.null(quote_all)) { input <- sprintf("%s%s%s", quote_all, input, quote_all) @@ -1433,35 +1627,54 @@ save_to = NULL, dir_name = NULL) { if (is.null(save_to)) { - save_to <- get0(x = "save_file", - ifnotfound = FALSE, - envir = parent.frame(1)) + save_to <- get0( + x = "save_file", + ifnotfound = FALSE, + envir = parent.frame(1) + ) if (is.na(save_to)) {save_to <- FALSE} } if (!isFALSE(save_to)) { ## 1 file path will be generated unless save_to == FALSE # set values - diagnostics <- get0("diagnostics", envir = parent.frame(1), - ifnotfound = getOption("rba_diagnostics")) - verbose <- get0("verbose", envir = parent.frame(1), - ifnotfound = getOption("rba_verbose")) + diagnostics <- get0( + "diagnostics", + envir = parent.frame(1), + ifnotfound = getOption("rba_diagnostics") + ) + verbose <- get0( + "verbose", + envir = parent.frame(1), + ifnotfound = getOption("rba_verbose") + ) + # set defaults - def_file_ext <- regmatches(file, regexpr("(?<=\\.)\\w+?$", - file, perl = TRUE)) - def_file_name <- regmatches(file, - regexpr(sprintf("^.*(?=\\.%s$)", def_file_ext), - file, perl = TRUE)) + def_file_ext <- regmatches( + file, + regexpr("(?<=\\.)\\w+?$", file, perl = TRUE) + ) + + def_file_name <- regmatches( + file, + regexpr(sprintf("^.*(?=\\.%s$)", def_file_ext), file, perl = TRUE) + ) + ## File path is in "save_to", if not in "file = file_name.file_ext" if (is.character(save_to)) { + + # 2a the user supplied a file path, just check if it is valid if (!grepl("^[a-zA-z]:|^\\\\\\w|^/|^\\w+\\.\\w+$", save_to)) { ## 2a.1 not a valid file path! - warning(sprintf("\"%s\" is not a valid file path. Ignored that.", - save_to), - call. = diagnostics) + warning( + sprintf("\"%s\" is not a valid file path. Ignored that.", save_to), + call. = diagnostics + ) save_to <- TRUE + } else { + ## 2a.2 the supplied file path is valid ## 2a.2.1 Does the path end to a directory or file? if (!grepl("/$", save_to, perl = TRUE) && @@ -1469,29 +1682,42 @@ # 2a.2.1a it's file! overwrite <- TRUE # extract the file name and extension - file_ext <- regmatches(basename(save_to), - regexpr("(?<=\\.)\\w+?$", - basename(save_to), perl = TRUE)) - file_name <- regmatches(basename(save_to), - regexpr(sprintf("^.*(?=\\.%s$)", file_ext), - basename(save_to), perl = TRUE)) + file_ext <- regmatches( + basename(save_to), + regexpr("(?<=\\.)\\w+?$", basename(save_to), perl = TRUE) + ) + file_name <- regmatches( + basename(save_to), + regexpr(sprintf("^.*(?=\\.%s$)", file_ext), basename(save_to), perl = TRUE) + ) # 2a.3 Check if the path and extension agree if (!grepl(def_file_ext, file_ext, ignore.case = TRUE)) { - warning(sprintf("The Response file's type (\"%s\") does not match the extension of your supplied file path(\"%s\").", - def_file_ext, basename(save_to)), - call. = diagnostics) + warning( + sprintf( + "The Response file's type (\"%s\") does not match the extension of your supplied file path(\"%s\").", + def_file_ext, basename(save_to) + ), + call. = diagnostics + ) } + } else { + #2a.2.1b it's directory overwrite <- FALSE ## append the default file name to the directory path file_ext <- def_file_ext file_name <- def_file_name - save_to <- file.path(sub("/$", "", save_to), - paste0(file_name, ".", file_ext)) + save_to <- file.path( + sub("/$", "", save_to), + paste0(file_name, ".", file_ext) + ) + } + } } + if (isTRUE(save_to)) { ## 2b User didn't supply a file path, use defaults overwrite <- FALSE @@ -1499,10 +1725,11 @@ file_ext <- def_file_ext file_name <- def_file_name ## 2b.2 set directory name - dir_name <- ifelse(is.null(dir_name), - yes = get0("dir_name", envir = parent.frame(1), - ifnotfound = getOption("rba_dir_name")), - no = dir_name) + dir_name <- ifelse( + is.null(dir_name), + yes = get0("dir_name", envir = parent.frame(1), ifnotfound = getOption("rba_dir_name")), + no = dir_name + ) ## 2b.3 set file path save_to <- file.path(getwd(), dir_name, paste0(file_name, ".", file_ext)) } # end of if is.character(save_to) @@ -1510,28 +1737,39 @@ ## 3 now that you have a file path... ## 3.1 check if a file doesn't exist with this path if (isFALSE(overwrite) && file.exists(save_to)) { + ## add an incremented file - exst_files <- list.files(path = dirname(save_to), - pattern = sprintf("(^%s)(_\\d+)*(\\.%s$)", - file_name, file_ext), - full.names = FALSE) - incrt <- regmatches(exst_files, - regexpr(sprintf("(?<=^%s_)(\\d+)*(?=\\.%s)", - file_name, file_ext), - exst_files, perl = TRUE)) + exst_files <- list.files( + path = dirname(save_to), + pattern = sprintf("(^%s)(_\\d+)*(\\.%s$)", file_name, file_ext), + full.names = FALSE + ) + incrt <- regmatches( + exst_files, + regexpr(sprintf("(?<=^%s_)(\\d+)*(?=\\.%s)", file_name, file_ext), exst_files, perl = TRUE) + ) if (length(incrt) == 0) { incrt <- 1 } else {incrt <- max(as.numeric(incrt)) + 1} - save_to <- file.path(dirname(save_to), - paste0(file_name, "_", incrt, ".", file_ext)) + + save_to <- file.path( + dirname(save_to), + paste0(file_name, "_", incrt, ".", file_ext) + ) + } else { + ## 3.2 file doesn't exist. create the directory just in case ### 4 create the directory - dir.create(dirname(save_to), - showWarnings = FALSE, - recursive = TRUE) + dir.create(dirname(save_to), showWarnings = FALSE, recursive = TRUE) + } - .msg("Saving the server response to: \"%s\"", save_to) + + .msg( + "Saving the server response to: \"%s\"", + save_to + ) + } # end if !isFALSE(save_to) return(save_to) } @@ -1563,7 +1801,9 @@ .rba_ext_args <- function(..., ignore_save = FALSE) { ext_args <- list(...) rba_opts <- getOption("rba_user_options") #available options for the end-users + if (length(ext_args) > 0) { #user supplied something in ... + ext_arg_names <- names(ext_args) if (is.null(ext_arg_names)) { @@ -1574,37 +1814,62 @@ invalid_args <- which(!ext_arg_names %in% c(rba_opts, "")) if (length(c(unnamed_args, invalid_args)) > 0) { - warning(sprintf("invalid rbioapi options were ignored:%s%s", - ifelse(length(unnamed_args) != 0, - yes = sprintf("\n- unnamed argument(s): %s", - .paste2(ext_args[unnamed_args], - quote = "`")), - no = ""), - ifelse(length(invalid_args) != 0, - yes = sprintf("\n- %s", - .paste2(sprintf("%s = %s", - ext_arg_names[invalid_args], - ext_args[invalid_args]), - last = " and ", - quote = "`")), - no = "") - ), call. = FALSE) + warning( + sprintf( + "invalid rbioapi options were ignored:%s%s", + ifelse( + length(unnamed_args) != 0, + yes = sprintf( + "\n- unnamed argument(s): %s", + .paste2(ext_args[unnamed_args], quote = "`") + ), + no = "" + ), + ifelse( + length(invalid_args) != 0, + yes = sprintf( + "\n- %s", + .paste2( + sprintf( + "%s = %s", + ext_arg_names[invalid_args], + ext_args[invalid_args]), + last = " and ", + quote = "`" + ) + ), + no = "" + ) + ), + call. = FALSE + ) ext_args <- ext_args[-c(unnamed_args, invalid_args)] + } + if (isTRUE(ignore_save) && utils::hasName(ext_args, "save_file")) { - warning("This function has a dedicated file-saving argument, ", - "'save_file' option was ignored.", - call. = FALSE) + + warning( + "This function has a dedicated file-saving argument, ", + "'save_file' option was ignored.", + call. = FALSE + ) rba_opts <- rba_opts[names(rba_opts) != "rba_save_file"] + } } #end of if (length(ext_args) > 0) + # create option variables for (opt in rba_opts) { - assign(x = opt, - value = ifelse(is.null(ext_args[[opt]]) || is.na(ext_args[[opt]]), - yes = getOption(paste0("rba_", opt)), - no = ext_args[[opt]]), - envir = parent.frame(1)) + assign( + x = opt, + value = ifelse( + is.null(ext_args[[opt]]) || is.na(ext_args[[opt]]), + yes = getOption(paste0("rba_", opt)), + no = ext_args[[opt]] + ), + envir = parent.frame(1) + ) } invisible() diff --git a/R/jaspar.R b/R/jaspar.R index 48923b49..43c611e7 100644 --- a/R/jaspar.R +++ b/R/jaspar.R @@ -43,33 +43,40 @@ rba_jaspar_collections <- function(release = 2024, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)) - )) + .rba_args( + cons = list( + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ) + ) + ) - .msg("Retrieving a list of collections available in JASPAR release %s.", - release) + .msg( + "Retrieving a list of collections available in JASPAR release %s.", + release + ) ## Build GET API Request's query - call_query <- list("release" = release, - "page_size" = 1000) + call_query <- list("release" = release, "page_size" = 1000) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) x[["results"]] + parser_input <- list( + "json->list_simp", + function(x) { x[["results"]] } ) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = paste0(.rba_stg("jaspar", "pth"), - "collections/"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("jaspar_collections.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = paste0(.rba_stg("jaspar", "pth"), "collections/"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("jaspar_collections.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -150,66 +157,63 @@ rba_jaspar_collections_matrices <- function(collection, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "collection", - class = "character", - val = c("CORE", - "CNE", - "PHYLOFACTS", - "SPLICE", - "POLII", - "FAM", - "PBM", - "PBM_HOMEO", - "PBM_HLH", - "UNVALIDATED")), - list(arg = "only_last_version", - class = "logical"), - list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)), - list(arg = "search", - class = "character"), - list(arg = "order", - class = "character"), - list(arg = "page_size", - class = "numeric", - ran = c(1,1000)), - list(arg = "page", - class = "numeric", - min_val = 1) - )) - - .msg("Retrieving a list of matrix profiles available in JASPAR %s collection release %s (page %s).", - collection, release, page) + .rba_args( + cons = list( + list( + arg = "collection", class = "character", + val = c("CORE", + "CNE", + "PHYLOFACTS", + "SPLICE", + "POLII", + "FAM", + "PBM", + "PBM_HOMEO", + "PBM_HLH", + "UNVALIDATED") + ), + list(arg = "only_last_version", class = "logical"), + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ), + list(arg = "search", class = "character"), + list(arg = "order", class = "character"), + list(arg = "page_size", class = "numeric", ran = c(1,1000)), + list(arg = "page", class = "numeric", min_val = 1) + ) + ) + + .msg( + "Retrieving a list of matrix profiles available in JASPAR %s collection release %s (page %s).", + collection, release, page + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("collection" = collection, - "release" = release, - "page_size" = page_size, - "page" = page), - list("version", - isTRUE(only_last_version), - "latest"), - list("search", - !is.null(search), - search), - list("order", - !is.null(order), - paste0(order, collapse = ",")) + call_query <- .rba_query( + init = list( + "collection" = collection, + "release" = release, + "page_size" = page_size, + "page" = page + ), + list("version", isTRUE(only_last_version), "latest"), + list("search", !is.null(search), search), + list("order",!is.null(order), paste0(order, collapse = ",")) ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%s/collections/%s/", - .rba_stg("jaspar", "pth"), - collection), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_collections_profiles.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%s/collections/%s/", .rba_stg("jaspar", "pth"), collection), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_collections_profiles.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -310,102 +314,73 @@ rba_jaspar_matrix_search <- function(term = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "term", - class = "character"), - list(arg = "tf_name", - class = "character"), - list(arg = "tf_class", - class = "character"), - list(arg = "tf_family", - class = "character"), - list(arg = "tax_group", - class = "character"), - list(arg = "tax_id", - class = "numeric"), - list(arg = "data_type", - class = "character"), - list(arg = "collection", - class = "character", - val = c("CORE", - "CNE", - "PHYLOFACTS", - "SPLICE", - "POLII", - "FAM", - "PBM", - "PBM_HOMEO", - "PBM_HLH", - "UNVALIDATED")), - list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)), - list(arg = "order", - class = "character"), - list(arg = "only_last_version", - class = "logical"), - list(arg = "page_size", - class = "numeric", - ran = c(1,1000)), - list(arg = "page", - class = "numeric", - min_val = 1) - )) - - .msg("Retrieving a list of matrix profiles available in JASPAR release %s based on your search query.", - release) + .rba_args( + cons = list( + list(arg = "term", class = "character"), + list(arg = "tf_name", class = "character"), + list(arg = "tf_class", class = "character"), + list(arg = "tf_family", class = "character"), + list(arg = "tax_group", class = "character"), + list(arg = "tax_id", class = "numeric"), + list(arg = "data_type", class = "character"), + list( + arg = "collection", class = "character", + val = c("CORE", + "CNE", + "PHYLOFACTS", + "SPLICE", + "POLII", + "FAM", + "PBM", + "PBM_HOMEO", + "PBM_HLH", + "UNVALIDATED") + ), + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ), + list(arg = "order", class = "character"), + list(arg = "only_last_version", class = "logical"), + list(arg = "page_size", class = "numeric", ran = c(1,1000)), + list(arg = "page", class = "numeric", min_val = 1) + ) + ) + + .msg( + "Retrieving a list of matrix profiles available in JASPAR release %s based on your search query.", + release + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("release" = release, - "page_size" = page_size, - "page" = page), - list("search", - !is.null(term), - term), - list("name", - !is.null(tf_name), - tf_name), - list("tf_class", - !is.null(tf_class), - tf_class), - list("tf_family", - !is.null(tf_family), - tf_family), - list("tax_group", - !is.null(tax_group), - tax_group), - list("tax_id", - !is.null(tax_id), - paste0(tax_id, collapse = ",")), - list("data_type", - !is.null(data_type), - data_type), - list("collection", - !is.null(collection), - collection), - list("search", - !is.null(term), - term), - list("search", - !is.null(term), - term), - list("version", - isTRUE(only_last_version), - "latest"), - list("order", - !is.null(order), - paste0(order, collapse = ",")) + call_query <- .rba_query( + init = list("release" = release, "page_size" = page_size, "page" = page), + list("search", !is.null(term), term), + list("name", !is.null(tf_name), tf_name), + list("tf_class", !is.null(tf_class), tf_class), + list("tf_family", !is.null(tf_family), tf_family), + list("tax_group", !is.null(tax_group), tax_group), + list("tax_id", !is.null(tax_id), paste0(tax_id, collapse = ",")), + list("data_type", !is.null(data_type), data_type), + list("collection", !is.null(collection), collection), + list("search", !is.null(term), term), + list("search", !is.null(term), term), + list("version", isTRUE(only_last_version), "latest"), + list("order", !is.null(order), paste0(order, collapse = ",")) ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = paste0(.rba_stg("jaspar", "pth"), "matrix/"), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_matrix_search.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = paste0(.rba_stg("jaspar", "pth"), "matrix/"), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_matrix_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -461,39 +436,46 @@ rba_jaspar_matrix_versions <- function(base_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list( list(arg = "base_id", - class = "character"), - list(arg = "order", - class = "character")), - cond = list(list(quote(grepl("\\.\\d+" ,base_id)), - "base_id cannot be versioned. ")) + .rba_args( + cons = list( + list(arg = "base_id", class = "character"), + list(arg = "order", class = "character")), + cond = list( + list( + quote(grepl("\\.\\d+" ,base_id)), + "base_id cannot be versioned." + ) + ) ) - .msg("Retrieving a list of matrix profile versions under base ID %s.", - base_id) + .msg( + "Retrieving a list of matrix profile versions under base ID %s.", + base_id + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("base_id" = base_id, - "page_size" = 1000), - list("order", - !is.null(order), - paste0(order, collapse = ","))) + call_query <- .rba_query( + init = list("base_id" = base_id, "page_size" = 1000), + list("order", !is.null(order), paste0(order, collapse = ",")) + ) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) x[["results"]] + parser_input <- list( + "json->list_simp", + function(x) { x[["results"]] } ) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%smatrix/%s/versions/", - .rba_stg("jaspar", "pth"), - base_id), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("jaspar_matrix_versions.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%smatrix/%s/versions/", .rba_stg("jaspar", "pth"), base_id), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("jaspar_matrix_versions.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -561,62 +543,74 @@ rba_jaspar_matrix <- function(matrix_id, ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) ## Check User-input Arguments - .rba_args(cons = list(list(arg = "matrix_id", - class = "character"), - list(arg = "file_format", - class = "character", - val = c("yaml", - "jaspar", - "transfac", - "pfm", - "meme")), - list(arg = "save_to", - class = "character") - )) - - .msg("Retrieving details of matrix profile with ID %s.", matrix_id) + .rba_args( + cons = list( + list(arg = "matrix_id", class = "character"), + list( + arg = "file_format", class = "character", + val = c("yaml", "jaspar", "transfac", "pfm", "meme") + ), + list(arg = "save_to", class = "character") + ) + ) + + .msg( + "Retrieving details of matrix profile with ID %s.", + matrix_id + ) ## Build Function-Specific Call if (is.null(file_format)) { + accept_input <- "application/json" - parser_input <- list("json->list_simp", - function(x) { - x$pfm <- as.matrix(t(as.data.frame(x$pfm[c("A", "C", "G", "T")]))) - return(x)}) + parser_input <- list( + "json->list_simp", + function(x) { + x$pfm <- as.matrix(t(as.data.frame(x$pfm[c("A", "C", "G", "T")]))) + return(x) + } + ) - save_to_input <- ifelse(isTRUE(save_to), - .rba_file("jaspar_matrix.json", - save_to = save_to), - .rba_file("jaspar_matrix.json") + save_to_input <- ifelse( + isTRUE(save_to), + .rba_file("jaspar_matrix.json", save_to = save_to), + .rba_file("jaspar_matrix.json") ) } else { - accept_input <- switch(file_format, - "yaml" = "application/yaml", - "jaspar" = "text/jaspar", - "transfac" = "text/transfac", - "pfm" = "text/pfm", - "meme" = "text/meme") + + accept_input <- switch( + file_format, + "yaml" = "application/yaml", + "jaspar" = "text/jaspar", + "transfac" = "text/transfac", + "pfm" = "text/pfm", + "meme" = "text/meme" + ) parser_input <- "text->chr" - save_to_input <- .rba_file(file = sprintf("%s.%s", - matrix_id, file_format), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) + save_to_input <- .rba_file( + file = sprintf("%s.%s", matrix_id, file_format), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, + no = save_to + ) + ) + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%smatrix/%s/", - .rba_stg("jaspar", "pth"), - matrix_id), - accept = accept_input, - parser = parser_input, - save_to = save_to_input) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%smatrix/%s/", .rba_stg("jaspar", "pth"), matrix_id), + accept = accept_input, + parser = parser_input, + save_to = save_to_input + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -672,46 +666,62 @@ rba_jaspar_releases <- function(release_number = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "release_number", - class = "numeric", - ran = c(1,8)) - )) - - .msg(ifelse(is.null(release_number), - yes = "Retrieving a list of all releases of JASPAR database.", - no = sprintf("Retrieving a details of JASPAR database release number %s.", - release_number)) + .rba_args( + cons = list( + list(arg = "release_number", class = "numeric", ran = c(1,8)) + ) + ) + + .msg( + ifelse( + is.null(release_number), + yes = "Retrieving a list of all releases of JASPAR database.", + no = sprintf( + "Retrieving a details of JASPAR database release number %s.", + release_number + ) + ) ) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("release_number", - !is.null(release_number), - release_number), - list("page_size", - is.null(release_number), - 1000) + call_query <- .rba_query( + init = list(), + list("release_number", !is.null(release_number), release_number), + list("page_size", is.null(release_number), 1000) ) ## Build Function-Specific Call if (is.null(release_number)) { + path_input <- paste0(.rba_stg("jaspar", "pth"), "releases/") - parser_input <- list("json->list_simp", - function(x) x[["results"]]) + + parser_input <- list( + "json->list_simp", + function(x) { x[["results"]] } + ) + } else { - path_input <- sprintf("%sreleases/%s", - .rba_stg("jaspar", "pth"), release_number) + + path_input <- sprintf( + "%sreleases/%s", + .rba_stg("jaspar", "pth"), release_number + ) parser_input <- "json->list_simp" + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("jaspar_matrix.json")) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("jaspar_matrix.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -762,28 +772,33 @@ rba_jaspar_sites <- function(matrix_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list( list(arg = "matrix_id", - class = "character")) + .rba_args( + cons = list( + list(arg = "matrix_id", class = "character") + ) ) - .msg("Retrieving binding sites information of matrix profile with ID %s.", - matrix_id) + .msg( + "Retrieving binding sites information of matrix profile with ID %s.", + matrix_id + ) ## Build GET API Request's query call_query <- list("matrix_id" = matrix_id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%ssites/%s/", - .rba_stg("jaspar", "pth"), - matrix_id), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_sites.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%ssites/%s/", .rba_stg("jaspar", "pth"), matrix_id), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_sites.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -842,45 +857,46 @@ rba_jaspar_species <- function(release = 2024, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)), - list(arg = "search", - class = "character"), - list(arg = "order", - class = "character") - )) - - .msg("Retrieving a list of species available in JASPAR release %s.", - release) + .rba_args( + cons = list( + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ), + list(arg = "search", class = "character"), + list(arg = "order", class = "character") + ) + ) + + .msg( + "Retrieving a list of species available in JASPAR release %s.", + release + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("release" = release, - "page" = 1, - "page_size" = 1000), - list("search", - !is.null(search), - search), - list("order", - !is.null(order), - paste0(order, collapse = ",")) + call_query <- .rba_query( + init = list("release" = release, "page" = 1, "page_size" = 1000), + list("search", !is.null(search), search), + list("order", !is.null(order), paste0(order, collapse = ",")) ) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) x[["results"]] + parser_input <- list( + "json->list_simp", + function(x) { x[["results"]] } ) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = paste0(.rba_stg("jaspar", "pth"), - "species/"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("jaspar_species.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = paste0(.rba_stg("jaspar", "pth"), "species/"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("jaspar_species.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -956,56 +972,51 @@ rba_jaspar_species_matrices <- function(tax_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "tax_id", - class = "numeric"), - list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)), - list(arg = "only_last_version", - class = "logical"), - list(arg = "search", - class = "character"), - list(arg = "order", - class = "character"), - list(arg = "page_size", - class = "numeric", - ran = c(1,1000)), - list(arg = "page", - class = "numeric", - min_val = 1) - )) - - .msg("Retrieving a list of matrix profiles of species %s available in JASPAR release %s (page %s).", - tax_id, release, page) + .rba_args( + cons = list( + list(arg = "tax_id", class = "numeric"), + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ), + list(arg = "only_last_version", class = "logical"), + list(arg = "search", class = "character"), + list(arg = "order", class = "character"), + list(arg = "page_size", class = "numeric", ran = c(1,1000)), + list(arg = "page", class = "numeric", min_val = 1) + ) + ) + + .msg( + "Retrieving a list of matrix profiles of species %s available in JASPAR release %s (page %s).", + tax_id, release, page + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("tax_id" = tax_id, - "release" = release, - "page" = page, - "page_size" = page_size), - list("version", - isTRUE(only_last_version), - "latest"), - list("search", - !is.null(search), - search), - list("order", - !is.null(order), - paste0(order, collapse = ",")) + call_query <- .rba_query( + init = list( + "tax_id" = tax_id, + "release" = release, + "page" = page, + "page_size" = page_size + ), + list("version", isTRUE(only_last_version), "latest"), + list("search", !is.null(search), search), + list("order", !is.null(order), paste0(order, collapse = ",")) ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%sspecies/%s/", - .rba_stg("jaspar", "pth"), - tax_id), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_species_matrices.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%sspecies/%s/", .rba_stg("jaspar", "pth"), tax_id), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_species_matrices.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1057,33 +1068,40 @@ rba_jaspar_taxons <- function(release = 2024, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)) - )) + .rba_args( + cons = list( + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ) + ) + ) - .msg("Retrieving a list of taxonomic groups available in JASPAR release %s.", - release) + .msg( + "Retrieving a list of taxonomic groups available in JASPAR release %s.", + release + ) ## Build GET API Request's query - call_query <- list("release" = release, - "page_size" = 1000) + call_query <- list("release" = release, "page_size" = 1000) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) x[["results"]] + parser_input <- list( + "json->list_simp", + function(x) { x[["results"]] } ) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = paste0(.rba_stg("jaspar", "pth"), - "taxon/"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("jaspar_taxons.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = paste0(.rba_stg("jaspar", "pth"), "taxon/"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("jaspar_taxons.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1160,65 +1178,62 @@ rba_jaspar_taxons_matrices <- function(tax_group, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "tax_group", - class = "character", - val = c("plants", - "vertebrates", - "insects", - "urochordates", - "nematodes", - "fungi", - "trematodes", - "protozoa", - "cnidaria")), - list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)), - list(arg = "only_last_version", - class = "logical"), - list(arg = "search", - class = "character"), - list(arg = "order", - class = "character"), - list(arg = "page_size", - class = "numeric", - ran = c(1,1000)), - list(arg = "page", - class = "numeric", - min_val = 1) - )) - - .msg("Retrieving a list of matrix profiles of taxonomic group %s available in JASPAR release %s (page %s).", - tax_group, release, page) + .rba_args( + cons = list( + list( + arg = "tax_group", class = "character", + val = c("plants", + "vertebrates", + "insects", + "urochordates", + "nematodes", + "fungi", + "trematodes", + "protozoa", + "cnidaria") + ), + list( + arg = "release", class = "numeric", no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ), + list(arg = "only_last_version", class = "logical"), + list(arg = "search", class = "character"), + list(arg = "order", class = "character"), + list(arg = "page_size", class = "numeric", ran = c(1,1000)), + list(arg = "page", class = "numeric", min_val = 1) + ) + ) + + .msg( + "Retrieving a list of matrix profiles of taxonomic group %s available in JASPAR release %s (page %s).", + tax_group, release, page + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("tax_group" = tax_group, - "release" = release, - "page" = page, - "page_size" = page_size), - list("version", - isTRUE(only_last_version), - "latest"), - list("search", - !is.null(search), - search), - list("order", - !is.null(order), - paste0(order, collapse = ",")) + call_query <- .rba_query( + init = list( + "tax_group" = tax_group, + "release" = release, + "page" = page, + "page_size" = page_size + ), + list("version", isTRUE(only_last_version), "latest"), + list("search", !is.null(search), search), + list("order", !is.null(order), paste0(order, collapse = ",")) ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%staxon/%s/", - .rba_stg("jaspar", "pth"), - tax_group), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_taxon_matrices.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%staxon/%s/", .rba_stg("jaspar", "pth"), tax_group), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_taxon_matrices.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1301,63 +1316,60 @@ rba_jaspar_tffm_search <- function(term = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "term", - class = "character"), - list(arg = "release", - class = "numeric", - no_null = TRUE, - val = c(2014, 2016, 2018, 2020, 2022, 2024)), - list(arg = "tax_group", - class = "character", - val = c("plants", - "vertebrates", - "insects", - "urochordates", - "nematodes", - "fungi", - "trematodes", - "protozoa", - "cnidaria")), - list(arg = "search", - class = "character"), - list(arg = "order", - class = "character"), - list(arg = "page_size", - class = "numeric", - ran = c(1,1000)), - list(arg = "page", - class = "numeric", - min_val = 1) - )) - - .msg("Retrieving a list of TFFM profiles available in JASPAR release %s based on your search query.", - release) + .rba_args( + cons = list( + list(arg = "term", class = "character"), + list( + arg = "release", + class = "numeric", + no_null = TRUE, + val = c(2014, 2016, 2018, 2020, 2022, 2024) + ), + list( + arg = "tax_group", + class = "character", + val = c("plants", + "vertebrates", + "insects", + "urochordates", + "nematodes", + "fungi", + "trematodes", + "protozoa", + "cnidaria") + ), + list(arg = "search", class = "character"), + list(arg = "order", class = "character"), + list(arg = "page_size", class = "numeric", ran = c(1,1000)), + list(arg = "page", class = "numeric", min_val = 1) + ) + ) + + .msg( + "Retrieving a list of TFFM profiles available in JASPAR release %s based on your search query.", + release + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("release" = release, - "page" = page, - "page_size" = page_size), - list("search", - !is.null(term), - term), - list("tax_group", - !is.null(tax_group), - tax_group), - list("order", - !is.null(order), - paste0(order, collapse = ",")) + call_query <- .rba_query( + init = list("release" = release, "page" = page, "page_size" = page_size), + list("search", !is.null(term), term), + list("tax_group", !is.null(tax_group), tax_group), + list("order", !is.null(order), paste0(order, collapse = ",")) ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = paste0(.rba_stg("jaspar", "pth"), - "tffm/"), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_tffm_search.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = paste0(.rba_stg("jaspar", "pth"), "tffm/"), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_tffm_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1407,27 +1419,33 @@ rba_jaspar_tffm <- function(tffm_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list( list(arg = "tffm_id", - class = "character")) + .rba_args( + cons = list( + list(arg = "tffm_id", class = "character") + ) ) - .msg("Retrieving details of TFFM profile with ID %s.", tffm_id) + .msg( + "Retrieving details of TFFM profile with ID %s.", + tffm_id + ) ## Build GET API Request's query call_query <- list("tffm_id" = tffm_id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("jaspar", "url"), - path = sprintf("%stffm/%s/", - .rba_stg("jaspar", "pth"), - tffm_id), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("jaspar_tffm.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("jaspar", "url"), + path = sprintf("%stffm/%s/", .rba_stg("jaspar", "pth"), tffm_id), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("jaspar_tffm.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/mieaa.R b/R/mieaa.R index 78a6a262..ecba2cb9 100644 --- a/R/mieaa.R +++ b/R/mieaa.R @@ -23,8 +23,10 @@ #' @family "miEAA" #' @noRd .rba_mieaa_species <- function(sp, to_name = FALSE) { + diagnostics <- get0("diagnostics", envir = parent.frame(1), ifnotfound = getOption("rba_diagnostics")) + sp_df <- data.frame( abbreviation = c("hsa", "mmu", "rno", "ath", "bta", "cel", "dme", "dre", "gga", "ssc"), @@ -35,10 +37,15 @@ "Bos taurus", "Caenorhabditis elegans", "Drosophila melanogaster", "Danio rerio", "Gallus gallus", "Sus scrofa"), - stringsAsFactors = FALSE) + stringsAsFactors = FALSE + ) + if (isTRUE(to_name)) { + return(sp_df$specie_name[[which(sp_df$abbreviation == sp)]]) + } else { + sp_table <- c( "hsa" = "hsa", "hsa" = 9606L, "hsa" = "Homo sapiens", "mmu" = "mmu", "mmu" = 10090L, "mmu" = "Mus musculus", @@ -49,16 +56,27 @@ "dme" = "dme", "dme" = 7227L, "dme" = "Drosophila melanogaster", "dre" = "dre", "dre" = 7955L, "dre" = "Danio rerio", "gga" = "gga", "gga" = 9031L, "gga" = "Gallus gallus", - "ssc" = "ssc", "ssc" = 9823L, "ssc" = "Sus scrofa") + "ssc" = "ssc", "ssc" = 9823L, "ssc" = "Sus scrofa" + ) + + sp_match <- pmatch( + x = tolower(sp), + table = tolower(sp_table), + nomatch = 0, + duplicates.ok = FALSE + ) - sp_match <- pmatch(x = tolower(sp), table = tolower(sp_table), - nomatch = 0, duplicates.ok = FALSE) if (sp_match != 0) { + return(names(sp_table)[[sp_match]]) + } else { - stop("Species should be or partially match one the following values:\n", - paste(utils::capture.output(print(sp_df)), collapse = "\n"), - call. = diagnostics) + + stop( + "Species should be or partially match one the following values:\n", + paste(utils::capture.output(print(sp_df)), collapse = "\n"), + call. = diagnostics + ) } } } @@ -116,42 +134,55 @@ rba_mieaa_cats <- function(mirna_type, species, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "mirna_type", - class = "character", - val = c("mature", - "precursor")), - list(arg = "species", - class = c("character", - "numeric"), - len = 1))) + .rba_args( + cons = list( + list(arg = "mirna_type", class = "character", val = c("mature", "precursor")), + list(arg = "species", class = c("character", "numeric"), len = 1) + ) + ) + # convert species input to abbreviation species <- .rba_mieaa_species(species, to_name = FALSE) - .msg("Retrieving available enrichment categories of %s for %s.", - switch(mirna_type, - "mature" = "miRNA", - "precursor" = "miRNA precursor"), - .rba_mieaa_species(species, to_name = TRUE)) + .msg( + "Retrieving available enrichment categories of %s for %s.", + switch( + mirna_type, + "mature" = "miRNA", + "precursor" = "miRNA precursor" + ), + .rba_mieaa_species(species, to_name = TRUE) + ) ## Build Function-Specific Call - parser_input <- list("json->df", - function(x) { - y <- x[[1]] - names(y) <- x[[2]] - return(y)}) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("mieaa", "url"), - path = sprintf("%senrichment_categories/%s/%s/", - .rba_stg("mieaa", "pth"), - species, - switch(mirna_type, - "mature" = "mirna", - "precursor" = "precursor")), - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_mieaa_cats.json")) + parser_input <- list( + "json->df", + function(x) { + y <- x[[1]] + names(y) <- x[[2]] + return(y) + } + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("mieaa", "url"), + path = sprintf( + "%senrichment_categories/%s/%s/", + .rba_stg("mieaa", "pth"), + species, + switch( + mirna_type, + "mature" = "mirna", + "precursor" = "precursor" + ) + ), + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_mieaa_cats.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -214,53 +245,60 @@ rba_mieaa_convert_version <- function(mirna, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "mirna", - class = "character"), - list(arg = "mirna_type", - class = "character", - val = c("mature", - "precursor")), - list(arg = "input_version", - class = "numeric", - val = c(9.1, 10, 12:22)), - list(arg = "output_version", - class = "numeric", - val = c(9.1, 10, 12:22)), - list(arg = "simple_output", - class = "logical"))) - - .msg("Converting %s %s miRNA IDs from mirbase v%s to v%s.", - length(mirna), - mirna_type, - input_version, output_version) + .rba_args( + cons = list( + list(arg = "mirna", class = "character"), + list(arg = "mirna_type", class = "character", val = c("mature", "precursor")), + list(arg = "input_version", class = "numeric", val = c(9.1, 10, 12:22)), + list(arg = "output_version", class = "numeric", val = c(9.1, 10, 12:22)), + list(arg = "simple_output", class = "logical")) + ) + + .msg( + "Converting %s %s miRNA IDs from mirbase v%s to v%s.", + length(mirna), + mirna_type, + input_version, output_version + ) + ## Build POST API Request's body - call_body <- list(mirnas = paste(mirna, collapse = "\n"), - mirbase_input_version = paste0("v", input_version), - mirbase_output_version = paste0("v", output_version), - input_type = ifelse(mirna_type == "mature", - yes = "mirna", no = "precursor"), - output_format = ifelse(isTRUE(simple_output), - yes = "oneline", - no = "tabsep")) + call_body <- list( + mirnas = paste(mirna, collapse = "\n"), + mirbase_input_version = paste0("v", input_version), + mirbase_output_version = paste0("v", output_version), + input_type = ifelse(mirna_type == "mature", yes = "mirna", no = "precursor"), + output_format = ifelse(isTRUE(simple_output), yes = "oneline", no = "tabsep") + ) ## Build Function-Specific Call if (isTRUE(simple_output)) { - parser_input <- list("text->df", function(x) {x[, 1]}) + + parser_input <- list( + "text->df", + function(x) { x[, 1] } + ) + } else { - parser_input <- list("text->df", function(x) { - colnames(x) <- x[1, ]; x <- x[-1, ] }) + + parser_input <- list( + "text->df", + function(x) { colnames(x) <- x[1, ]; x <- x[-1, ] } + ) + } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("mieaa", "url"), - path = sprintf("%smirbase_converter/", - .rba_stg("mieaa", "pth")), - encode = "multipart", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_mieaa_convert_version.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("mieaa", "url"), + path = sprintf("%smirbase_converter/", .rba_stg("mieaa", "pth")), + encode = "multipart", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_mieaa_convert_version.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -323,56 +361,63 @@ rba_mieaa_convert_type <- function(mirna, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "mirna", - class = "character"), - list(arg = "input_type", - class = "character", - val = c("mature", - "precursor")), - list(arg = "only_unique", - class = "logical"), - list(arg = "simple_output", - class = "logical"))) - - .msg("Converting %s %s miRNA IDs to %s IDs.", - length(mirna), - input_type, - ifelse(input_type == "mature", - yes = "precursor", no = "mature")) + .rba_args( + cons = list( + list(arg = "mirna", class = "character"), + list(arg = "input_type", class = "character", val = c("mature", "precursor")), + list(arg = "only_unique", class = "logical"), + list(arg = "simple_output", class = "logical") + ) + ) + + .msg( + "Converting %s %s miRNA IDs to %s IDs.", + length(mirna), + input_type, + ifelse(input_type == "mature", yes = "precursor", no = "mature") + ) + ## Build POST API Request's body - call_body <- list(mirnas = paste(mirna, collapse = "\n"), - input_type = ifelse(input_type == "mature", - yes = "to_precursor", no = "to_mirna"), - output_format = ifelse(isTRUE(simple_output), - yes = "newline", - no = "tabsep"), - conversion_type = ifelse(isTRUE(only_unique), - yes = "unique", - no = "all")) + call_body <- list( + mirnas = paste(mirna, collapse = "\n"), + input_type = ifelse(input_type == "mature", yes = "to_precursor", no = "to_mirna"), + output_format = ifelse(isTRUE(simple_output), yes = "newline", no = "tabsep"), + conversion_type = ifelse(isTRUE(only_unique), yes = "unique", no = "all") + ) ## Build Function-Specific Call if (isTRUE(simple_output)) { - parser_input <- list("text->df", function(x) {x[, 1]}) + + parser_input <- list( + "text->df", + function(x) { x[, 1] } + ) + } else { - parser_input <- list("text->df", - function(x) { - names(x) <- c(input_type, - setdiff(c("mature", "precursor"), - input_type)) - return(x) - }) + parser_input <- list( + "text->df", + function(x) { + names(x) <- c( + input_type, + setdiff(c("mature", "precursor"), input_type) + ) + return(x) + } + ) } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("mieaa", "url"), - path = sprintf("%smirna_precursor_converter/", - .rba_stg("mieaa", "pth")), - encode = "multipart", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_mieaa_convert_type.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("mieaa", "url"), + path = sprintf("%smirna_precursor_converter/", .rba_stg("mieaa", "pth")), + encode = "multipart", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_mieaa_convert_type.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -486,102 +531,101 @@ rba_mieaa_enrich_submit <- function(test_set, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "test_type", - class = "character", - val = c("GSEA", - "ORA")), - list(arg = "test_set", - class = "character", - no_null = TRUE), - list(arg = "mirna_type", - class = "character", - no_null = TRUE, - val = c("mature", - "precursor")), - list(arg = "species", - class = c("character", - "numeric"), - no_null = TRUE, - len = 1), - list(arg = "categories", - class = "character"), - list(arg = "p_adj_method", - class = "character", - val = c("none", - "fdr", - "bonferroni", - "BY", - "hochberg", - "holm", - "hommel")), - list(arg = "independent_p_adj", - class = "logical"), - list(arg = "sig_level", - class = "numeric", - ran = c(0, 1)), - list(arg = "min_hits", - class = "numeric") - )) + .rba_args( + cons = list( + list(arg = "test_type", class = "character", val = c("GSEA", "ORA")), + list(arg = "test_set", class = "character", no_null = TRUE), + list( + arg = "mirna_type", class = "character", no_null = TRUE, + val = c("mature", "precursor") + ), + list(arg = "species", class = c("character", "numeric"), no_null = TRUE, len = 1), + list(arg = "categories", class = "character"), + list( + arg = "p_adj_method", class = "character", + val = c("none", "fdr", "bonferroni", "BY", "hochberg", "holm", "hommel") + ), + list(arg = "independent_p_adj", class = "logical"), + list(arg = "sig_level", class = "numeric", ran = c(0, 1)), + list(arg = "min_hits", class = "numeric") + ) + ) + ## handle function-specific inputs #species species <- .rba_mieaa_species(sp = species, to_name = FALSE) #categories - all_cats <- rba_mieaa_cats(mirna_type = mirna_type, - species = species, - verbose = FALSE) + all_cats <- rba_mieaa_cats(mirna_type = mirna_type, species = species, verbose = FALSE) + if (is.null(categories)) { + categories <- all_cats - .msg("No categories were supplied, Requesting enrichment using all of the %s available categories for species '%s'.", - length(categories), - .rba_mieaa_species(species, to_name = TRUE)) + .msg( + "No categories were supplied, Requesting enrichment using all of the %s available categories for species '%s'.", + length(categories), + .rba_mieaa_species(species, to_name = TRUE) + ) + } else { + cats_dif <- setdiff(categories, all_cats) if (length(cats_dif) != 0) { - invalid_cats_msg <- sprintf("Invalid categories! The following requested categories do not match your supplied specie and miRNA type:\n%s", - .paste2(cats_dif, last = " and ")) + invalid_cats_msg <- sprintf( + "Invalid categories! The following requested categories do not match your supplied specie and miRNA type:\n%s", + .paste2(cats_dif, last = " and ") + ) if (isTRUE(get("skip_error"))) { return(invalid_cats_msg) } else { - stop(invalid_cats_msg, - call. = FALSE) + stop(invalid_cats_msg, call. = FALSE) } - } + } + names(categories) <- rep("categories", length(categories)) - .msg("Submitting %s enrichment request for %s miRNA IDs of species %s to miEAA servers.", - test_type, length(test_set), .rba_mieaa_species(species, to_name = TRUE)) + .msg( + "Submitting %s enrichment request for %s miRNA IDs of species %s to miEAA servers.", + test_type, + length(test_set), + .rba_mieaa_species(species, to_name = TRUE) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list(testset = paste(test_set, collapse = "\n"), - p_value_adjustment = p_adj_method, - independent_p_adjust = ifelse(independent_p_adj, - yes = "True", - no = "False"), - significance_level = sig_level, - threshold_level = min_hits), - list("reference_set", - test_type == "ORA" && !is.null(ref_set), - paste(ref_set, collapse = "\n"))) + call_body <- .rba_query( + init = list( + testset = paste(test_set, collapse = "\n"), + p_value_adjustment = p_adj_method, + independent_p_adjust = ifelse(independent_p_adj, yes = "True", no = "False"), + significance_level = sig_level, + threshold_level = min_hits + ), + list("reference_set", test_type == "ORA" && !is.null(ref_set), paste(ref_set, collapse = "\n")) + ) + call_body <- append(call_body, categories) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("mieaa", "url"), - path = sprintf("%senrichment_analysis/%s/%s/%s/", - .rba_stg("mieaa", "pth"), - species, - switch(mirna_type, - "mature" = "mirna", - "precursor" = "precursor"), - test_type), - encode = "multipart", - body = call_body, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("rba_mieaa_info.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("mieaa", "url"), + path = sprintf( + "%senrichment_analysis/%s/%s/%s/", + .rba_stg("mieaa", "pth"), + species, + switch(mirna_type, "mature" = "mirna", "precursor" = "precursor"), + test_type + ), + encode = "multipart", + body = call_body, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("rba_mieaa_info.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -635,23 +679,28 @@ rba_mieaa_enrich_submit <- function(test_set, rba_mieaa_enrich_status <- function(job_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "job_id", - class = "character", - len = 1))) + .rba_args( + cons = list( + list(arg = "job_id", class = "character", len = 1) + ) + ) - .msg("Retrieving status of submitted enrichment request with ID: %s", - job_id) + .msg( + "Retrieving status of submitted enrichment request with ID: %s", + job_id + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("mieaa", "url"), - path = sprintf("%sjob_status/%s/", - .rba_stg("mieaa", "pth"), - job_id), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("rba_mieaa_info.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("mieaa", "url"), + path = sprintf("%sjob_status/%s/", .rba_stg("mieaa", "pth"), job_id), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("rba_mieaa_info.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -710,53 +759,59 @@ rba_mieaa_enrich_results <- function(job_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "job_id", - class = "character", - len = 1), - list(arg = "sort_by", - class = "character", - no_null = TRUE, - val = c("category", - "subcategory", - "enrichment", - "p_value", - "p_adjusted", - "q_value", - "observed")))) - - .msg("Retrieving results of submitted enrichment request with ID: %s", - job_id) + .rba_args( + cons = list( + list(arg = "job_id", class = "character", len = 1), + list( + arg = "sort_by", class = "character", no_null = TRUE, + val = c("category", + "subcategory", + "enrichment", + "p_value", + "p_adjusted", + "q_value", + "observed") + ) + ) + ) + + .msg( + "Retrieving results of submitted enrichment request with ID: %s", + job_id + ) ## Build Function-Specific Call - parser_input <- list("json->df", - function(x) { - if (ncol(x) == 9) { - colnames(x) <- c("Category", "Subcategory", - "Enrichment", "P-value", - "P-adjusted", "Q-value", - "Expected", "Observed", - "miRNAs/precursors") - } - if (ncol(x) == 8) { - colnames(x) <- c("Category", "Subcategory", - "Enrichment", "P-value", - "P-adjusted", "Q-value", - "Observed", "miRNAs/precursors") - - } - return(x) - } + parser_input <- list( + "json->df", + function(x) { + if (ncol(x) == 9) { + colnames(x) <- c("Category", "Subcategory", + "Enrichment", "P-value", + "P-adjusted", "Q-value", + "Expected", "Observed", + "miRNAs/precursors") + } + if (ncol(x) == 8) { + colnames(x) <- c("Category", "Subcategory", + "Enrichment", "P-value", + "P-adjusted", "Q-value", + "Observed", "miRNAs/precursors") + + } + return(x) + } ) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("mieaa", "url"), - path = sprintf("%s/enrichment_analysis/results/%s/", - .rba_stg("mieaa", "pth"), - job_id), - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_mieaa_info.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("mieaa", "url"), + path = sprintf("%s/enrichment_analysis/results/%s/", .rba_stg("mieaa", "pth"), job_id), + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_mieaa_info.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -834,25 +889,34 @@ rba_mieaa_enrich <- function(test_set, ...) { ## Load Global Options .rba_ext_args(...) - .msg(" -- Step 1/3: Submitting Enrichment analysis request:") - step1 <- rba_mieaa_enrich_submit(test_set = test_set, - mirna_type = mirna_type, - species = species, - test_type = test_type, - categories = categories, - p_adj_method = p_adj_method, - independent_p_adj = independent_p_adj, - sig_level = sig_level, - min_hits = min_hits, - ref_set = ref_set, - ...) + + .msg( + " -- Step 1/3: Submitting Enrichment analysis request:" + ) + + step1 <- rba_mieaa_enrich_submit( + test_set = test_set, + mirna_type = mirna_type, + species = species, + test_type = test_type, + categories = categories, + p_adj_method = p_adj_method, + independent_p_adj = independent_p_adj, + sig_level = sig_level, + min_hits = min_hits, + ref_set = ref_set, + ... + ) if (utils::hasName(step1, "job_id")) { # Go to step 2 - .msg("\n -- Step 2/3: Checking for Submitted enrichment analysis's status every 5 seconds.\n", - " Your submitted job ID is: ", step1$job_id) - step2 <- list(status = 0L, - `results-URL` = NULL) + .msg( + "\n -- Step 2/3: Checking for Submitted enrichment analysis's status every 5 seconds.\n", + " Your submitted job ID is: ", + step1$job_id + ) + + step2 <- list(status = 0L, `results-URL` = NULL) tried <- 0 try_max <- ifelse(interactive(), Inf, 25) @@ -860,47 +924,59 @@ rba_mieaa_enrich <- function(test_set, cat(".") tried <- tried + 1 Sys.sleep(5) - step2 <- rba_mieaa_enrich_status(job_id = step1$job_id, - verbose = FALSE, ...) + step2 <- rba_mieaa_enrich_status( + job_id = step1$job_id, + verbose = FALSE, + ... + ) } if (utils::hasName(step2, "status") && step2$status == 100L) { # Go to step 3 - .msg("\n -- Step 3/3: Retrieving the results.") + .msg( + "\n -- Step 3/3: Retrieving the results." + ) + Sys.sleep(1) - step3 <- rba_mieaa_enrich_results(job_id = step1$job_id, - sort_by = sort_by, - sort_asc = sort_asc, - ...) + step3 <- rba_mieaa_enrich_results( + job_id = step1$job_id, + sort_by = sort_by, + sort_asc = sort_asc, + ... + ) return(step3) } else { # Halt at step 2 - job_stuck_msg <- paste0("Error: The miEAA server didn't complete the analysis.", - "Please retry or manually run the required steps as demonstrated in the `miEAA & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", - "If the problem persists, kindly report this issue to us. The error message was: ", - try(step2$status), - collapse = "\n") + job_stuck_msg <- paste0( + "Error: The miEAA server didn't complete the analysis.", + "Please retry or manually run the required steps as demonstrated in the `miEAA & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", + "If the problem persists, kindly report this issue to us. The error message was: ", + try(step2$status), + collapse = "\n" + ) + if (isTRUE(get("skip_error"))) { return(job_stuck_msg) } else { - stop(job_stuck_msg, - call. = get("diagnostics")) + stop(job_stuck_msg, call. = get("diagnostics")) } } } else { # halt at step 1 - no_job_id_msg <- paste0("Error: Couldn't submit analysis request to miEAA. ", - "Please retry or manually run the required steps as demonstrated in the `miEAA & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", - "If the problem persists, kindly report this issue to us. The error message was: ", - try(step1), - collapse = "\n") + no_job_id_msg <- paste0( + "Error: Couldn't submit analysis request to miEAA. ", + "Please retry or manually run the required steps as demonstrated in the `miEAA & rbioapi` vignette article, section `Approach 2: Going step-by-step`. ", + "If the problem persists, kindly report this issue to us. The error message was: ", + try(step1), + collapse = "\n" + ) + if (isTRUE(get("skip_error"))) { return(no_job_id_msg) } else { - stop(no_job_id_msg, - call. = get("diagnostics")) + stop(no_job_id_msg, call. = get("diagnostics")) } } diff --git a/R/panther.R b/R/panther.R index dc4cc790..f3499444 100644 --- a/R/panther.R +++ b/R/panther.R @@ -47,34 +47,47 @@ rba_panther_mapping <- function(genes, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "genes", - class = c("character", - "numeric"), - max_len = 1000), - list(arg = "organism", - class = "numeric", - len = 1))) - .msg("Mapping %s input genes from organims %s to PANTHER databse.", - length(genes), organism) + .rba_args( + cons = list( + list(arg = "genes", class = c("character", "numeric"), max_len = 1000), + list(arg = "organism", class = "numeric", len = 1) + ) + ) + + .msg( + "Mapping %s input genes from organims %s to PANTHER databse.", + length(genes), organism + ) ## Build POST API Request's body - call_body <- list(geneInputList = paste(genes, collapse = ","), - organism = organism) + call_body <- list( + geneInputList = paste(genes, collapse = ","), + organism = organism + ) ## Build Function-Specific Call - parser_input <- list("json->list", - function(x) {list(unmapped_list = x$search$unmapped_list, - mapped_genes = x$search$mapped_genes)}) - input_call <- .rba_httr(httr = "post", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - "geneinfo"), - encode = "form", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_panther_mapping.json")) + parser_input <- list( + "json->list", + function(x) { + list( + unmapped_list = x$search$unmapped_list, + mapped_genes = x$search$mapped_genes + ) + } + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), "geneinfo"), + encode = "form", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_panther_mapping.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -223,124 +236,136 @@ rba_panther_enrich <- function(genes, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "genes", - class = c("character", - "data.frame")), - list(arg = "organism", - class = "numeric", - len = 1), - list(arg = "annot_dataset", - class = "character", - len = 1), - list(arg = "test_type", - class = "character", - val = c("FISHER", "BINOMIAL", "Mann-Whitney"), - len = 1), - list(arg = "correction", - class = "character", - val = c("FDR", "BONFERRONI", "NONE"), - len = 1), - list(arg = "cutoff", - class = "numeric", - len = 1, - ran = c(0, 1)), - list(arg = "ref_genes", - class = c("character", - "numeric"), - max_len = 100000), - list(arg = "ref_organism", - class = "numeric", - len = 1)), - cond = list(list(quote(xor(is.null(ref_organism), is.null(ref_genes))), - "'ref_organism' and 'ref_genes' should be supplied togeather."), - list(quote(is.data.frame(genes) && (ncol(genes) != 2 || !inherits(genes[[1]], "character") || !inherits(genes[[2]], "numeric"))), - "If the `genes` parameter is a data frame, statistical enrichment analysis will be performed.\nThe gene parameter should be a data frame with 2 columns, where the first column contains the genes identifiers and the second column contains numerical expression values."), - list(quote(is.data.frame(genes) && !is.null(test_type) && test_type != "Mann-Whitney"), - "If the `genes` parameter is a data frame, statistical enrichment analysis will be performed.\nThus, the only valid parameter for `test_type` is 'Mann-Whitney'."), - list(quote(is.character(genes) && !is.null(test_type) && test_type == "Mann-Whitney"), - "If the `genes` parameter is a character vector, over-representation analysis will be performed.\nThus, the valid parameters for `test_type` are either 'FISHER' or 'BINOMIAL'."), - list(quote(is.data.frame(genes) && any(!is.null(ref_genes), !is.null(ref_organism))), - "If the `genes` parameter is a data frame, statistical enrichment analysis will be performed.\nProviding Reference gene list (`ref_genes` and `ref_organism`) is not possible in this mode.") - ) + .rba_args( + cons = list( + list(arg = "genes", class = c("character", "data.frame")), + list(arg = "organism", class = "numeric", len = 1), + list(arg = "annot_dataset", class = "character", len = 1), + list( + arg = "test_type", class = "character", len = 1, + val = c("FISHER", "BINOMIAL", "Mann-Whitney") + ), + list( + arg = "correction", class = "character", len = 1, + val = c("FDR", "BONFERRONI", "NONE") + ), + list(arg = "cutoff", class = "numeric", len = 1, ran = c(0, 1)), + list(arg = "ref_genes", class = c("character","numeric"), max_len = 100000), + list(arg = "ref_organism", class = "numeric", len = 1) + ), + cond = list( + list( + quote(xor(is.null(ref_organism), is.null(ref_genes))), + "'ref_organism' and 'ref_genes' should be supplied togeather." + ), + list( + quote(is.data.frame(genes) && (ncol(genes) != 2 || !inherits(genes[[1]], "character") || !inherits(genes[[2]], "numeric"))), + "If the `genes` parameter is a data frame, statistical enrichment analysis will be performed.\nThe gene parameter should be a data frame with 2 columns, where the first column contains the genes identifiers and the second column contains numerical expression values." + ), + list( + quote(is.data.frame(genes) && !is.null(test_type) && test_type != "Mann-Whitney"), + "If the `genes` parameter is a data frame, statistical enrichment analysis will be performed.\nThus, the only valid parameter for `test_type` is 'Mann-Whitney'." + ), + list( + quote(is.character(genes) && !is.null(test_type) && test_type == "Mann-Whitney"), + "If the `genes` parameter is a character vector, over-representation analysis will be performed.\nThus, the valid parameters for `test_type` are either 'FISHER' or 'BINOMIAL'." + ), + list( + quote(is.data.frame(genes) && any(!is.null(ref_genes), !is.null(ref_organism))), + "If the `genes` parameter is a data frame, statistical enrichment analysis will be performed.\nProviding Reference gene list (`ref_genes` and `ref_organism`) is not possible in this mode." + ) + ) ) if (is.character(genes)) { + if (is.null(test_type)) { test_type = "FISHER" } # Over-representation analysis - .msg("Performing PANTHER over-representation analysis (%s test) on %s genes from `organism %s` against `%s` datasets.", - switch(test_type, "FISHER" = "Fisher's exact", "BINOMIAL" = "Binomial"), - length(genes), organism, annot_dataset) - + .msg( + "Performing PANTHER over-representation analysis (%s test) on %s genes from `organism %s` against `%s` datasets.", + switch(test_type, "FISHER" = "Fisher's exact", "BINOMIAL" = "Binomial"), + length(genes), organism, annot_dataset + ) path_input <- "enrich/overrep" encode_input <- "form" ## Build POST API Request's body - call_body <- .rba_query(init = list(geneInputList = paste(genes, - collapse = ","), - organism = organism, - annotDataSet = annot_dataset, - enrichmentTestType = test_type, - correction = correction), - list("refInputList", - !all(is.null(ref_genes)), - paste(ref_genes, collapse = ",")), - list("refOrganism", - !is.null(ref_organism), - ref_organism)) + call_body <- .rba_query( + init = list( + geneInputList = paste(genes, collapse = ","), + organism = organism, + annotDataSet = annot_dataset, + enrichmentTestType = test_type, + correction = correction + ), + list("refInputList", !all(is.null(ref_genes)), paste(ref_genes, collapse = ",")), + list("refOrganism", !is.null(ref_organism), ref_organism) + ) } else { + # Enrichment analysis - .msg("Performing PANTHER statistical enrichment analysis (Mann-Whitney U Test) on %s genes and expression values from `organism %s` against `%s` datasets.", - nrow(genes), organism, annot_dataset) + .msg( + "Performing PANTHER statistical enrichment analysis (Mann-Whitney U Test) on %s genes and expression values from `organism %s` against `%s` datasets.", + nrow(genes), organism, annot_dataset + ) path_input <- "enrich/statenrich" encode_input <- "multipart" ## Build POST API Request's body temp_file <- tempfile(pattern = "rba_", fileext = ".txt") - utils::write.table(x = genes, - file = temp_file, - sep = "\t", - quote = FALSE, - row.names = FALSE, - col.names = FALSE) - - call_body <- list(organism = organism, - annotDataSet = annot_dataset, - correction = correction, - geneExp = httr::upload_file(temp_file)) + utils::write.table( + x = genes, + file = temp_file, + sep = "\t", + quote = FALSE, + row.names = FALSE, + col.names = FALSE + ) + + call_body <- list( + organism = organism, + annotDataSet = annot_dataset, + correction = correction, + geneExp = httr::upload_file(temp_file) + ) } ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) { - if (utils::hasName(x, "results")) { - x <- x$results - x$result <- jsonlite::flatten(x$result) - - if (!is.null(cutoff)) { - if (correction == "FDR") { - x$result <- x$result[x$result$fdr <= cutoff, ] - } else { - x$result <- x$result[x$result$pValue <= cutoff, ] - } - } - } - - return(x) - }) - - input_call <- .rba_httr(httr = "post", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - path_input), - encode = encode_input, - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_panther_enrich.json")) + parser_input <- list( + "json->list_simp", + function(x) { + if (utils::hasName(x, "results")) { + x <- x$results + x$result <- jsonlite::flatten(x$result) + + if (!is.null(cutoff)) { + if (correction == "FDR") { + x$result <- x$result[x$result$fdr <= cutoff, ] + } else { + x$result <- x$result[x$result$pValue <= cutoff, ] + } + } + } + + return(x) + } + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), path_input), + encode = encode_input, + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_panther_enrich.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -408,90 +433,109 @@ rba_panther_info <- function(what, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "what", - class = "character", - val = c("organisms", - "datasets", - "families", - "species_tree", - "pathways")), - list(arg = "organism_chr_loc", - class = "logical", - len = 1), - list(arg = "families_page", - class = "numeric", - len = 1)), - cond = list(list(quote(families_page != 1 && what != "families"), - "'families_page' was ignored because 'what' argument is not 'families'.", - warn = TRUE), - list(quote(isTRUE(organism_chr_loc)), - "'organism_chr_loc' was ignored because 'what' argument is not 'organisms'.", - warn = TRUE))) - .msg("Retrieving %s%s.", - switch(what, - "organisms" = "supported organisms in PANTHER", - "datasets" = "available annotation datasets", - "families" = "available family IDs", - "species_tree" = "phylogenetic tree of PANTHER species", - "pathways" = "available pathway IDs"), - ifelse(what == "families", - yes = sprintf(" (page %s)", families_page), - no = "")) + .rba_args( + cons = list( + list( + arg = "what", class = "character", + val = c("organisms", "datasets", "families", "species_tree", "pathways") + ), + list(arg = "organism_chr_loc", class = "logical", len = 1), + list(arg = "families_page", class = "numeric", len = 1) + ), + cond = list( + list( + quote(families_page != 1 && what != "families"), + "'families_page' was ignored because 'what' argument is not 'families'.", + warn = TRUE + ), + list( + quote(isTRUE(organism_chr_loc)), + "'organism_chr_loc' was ignored because 'what' argument is not 'organisms'.", + warn = TRUE + ) + ) + ) + + .msg( + "Retrieving %s%s.", + switch( + what, + "organisms" = "supported organisms in PANTHER", + "datasets" = "available annotation datasets", + "families" = "available family IDs", + "species_tree" = "phylogenetic tree of PANTHER species", + "pathways" = "available pathway IDs" + ), + ifelse(what == "families", yes = sprintf(" (page %s)", families_page), no = "") + ) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("type", - what == "organisms" && isTRUE(organism_chr_loc), - "chrLoc"), - list("startIndex", - what == "families", - (families_page - 1) * 1000 + 1)) + call_query <- .rba_query( + init = list(), + list("type", what == "organisms" && isTRUE(organism_chr_loc), "chrLoc"), + list("startIndex", what == "families", (families_page - 1) * 1000 + 1) + ) ## Build Function-Specific Call - switch(what, - "organisms" = { - path_input <- "supportedgenomes" - parser_input <- list("json->list_simp", - function(x) {x$search$output$genomes$genome}) - }, - "datasets" = { - path_input <- "supportedannotdatasets" - parser_input <- list("json->list_simp", - function(x) {x$search$annotation_data_sets$annotation_data_type}) - }, - "families" = { - path_input <- "supportedpantherfamilies" - parser_input <- list("json->list_simp", - function(x) { - y <- list(familiy = x$search$panther_family_subfam_list$family, - page = families_page, - pages_count = x$search$number_of_families %/% 1000 - ) - }) - }, - "species_tree" = { - path_input <- "speciestree" - parser_input <- list("json->list", - function(x) {x$species_tree}) - }, - "pathways" = { - path_input <- "supportedpantherpathways" - parser_input <- list("json->list_simp", - function(x) { - x$search$output$PANTHER_pathway_list$pathway - }) - }) - - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - path_input), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("panther_info.json")) + switch( + what, + "organisms" = { + path_input <- "supportedgenomes" + parser_input <- list( + "json->list_simp", + function(x) { x$search$output$genomes$genome } + ) + }, + "datasets" = { + path_input <- "supportedannotdatasets" + parser_input <- list( + "json->list_simp", + function(x) { x$search$annotation_data_sets$annotation_data_type } + ) + }, + "families" = { + path_input <- "supportedpantherfamilies" + parser_input <- list( + "json->list_simp", + function(x) { + list( + familiy = x$search$panther_family_subfam_list$family, + page = families_page, + pages_count = x$search$number_of_families %/% 1000 + ) + } + ) + }, + "species_tree" = { + path_input <- "speciestree" + parser_input <- list( + "json->list", + function(x) { x$species_tree } + ) + }, + "pathways" = { + path_input <- "supportedpantherpathways" + parser_input <- list( + "json->list_simp", + function(x) { + x$search$output$PANTHER_pathway_list$pathway + } + ) + } + ) + + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), path_input), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("panther_info.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -562,54 +606,48 @@ rba_panther_ortholog <- function(genes, ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "genes", - class = c("character", - "numeric"), - max_len = 10), - list(arg = "organism", - class = "numeric", - len = 1), - list(arg = "type", - class = "character", - val = c("LDO", - "all"), - len = 1), - list(arg = "target_organisms", - class = "numeric"), - list(arg = "seq_pos", - class = "numeric", - len = 1), - list(arg = "include_msa", - class = "logical", - len = 1)), - cond = list(list(quote(!is.null(seq_pos) && length(genes) > 1), - "When 'seq_pos' is supplied, 'genes' argument should be a single input."), - list(quote(!is.null(include_msa) && is.null(seq_pos)), - "'include_msa' was ignored because no 'seq_pos' was supplied.", - warn = TRUE))) - .msg("Retrieving %s orthologs of genes %s.", - type, .paste2(genes, quote_all = "'")) + .rba_args( + cons = list( + list(arg = "genes", class = c("character", "numeric"), max_len = 10), + list(arg = "organism", class = "numeric", len = 1), + list(arg = "type", class = "character", val = c("LDO", "all"), len = 1), + list(arg = "target_organisms", class = "numeric"), + list(arg = "seq_pos", class = "numeric", len = 1), + list(arg = "include_msa", class = "logical", len = 1) + ), + cond = list( + list( + quote(!is.null(seq_pos) && length(genes) > 1), + "When 'seq_pos' is supplied, 'genes' argument should be a single input." + ), + list( + quote(!is.null(include_msa) && is.null(seq_pos)), + "'include_msa' was ignored because no 'seq_pos' was supplied.", + warn = TRUE + ) + ) + ) + + .msg( + "Retrieving %s orthologs of genes %s.", + type, + .paste2(genes, quote_all = "'") + ) ## Build POST API Request's body - call_body <- .rba_query(init = list(organism = organism, - orthologType = type), - list("geneInputList", - is.null(seq_pos), - paste(genes, collapse = ",")), - list("gene", - !is.null(seq_pos), - genes), - list("targetOrganism", - !is.null(target_organisms), - paste(target_organisms, collapse = ",")), - list("pos", - !is.null(seq_pos), - seq_pos), - list("includeMsa", - !is.null(include_msa) && !is.null(seq_pos), - ifelse(isTRUE(include_msa), - yes = "true", no = "false")) + call_body <- .rba_query( + init = list(organism = organism, orthologType = type), + list("geneInputList", is.null(seq_pos), paste(genes, collapse = ",")), + list("gene", !is.null(seq_pos), genes), + list("targetOrganism", !is.null(target_organisms), paste(target_organisms, collapse = ",")), + list("pos", !is.null(seq_pos), seq_pos), + list( + "includeMsa", + !is.null(include_msa) && !is.null(seq_pos), + ifelse(isTRUE(include_msa), yes = "true", no = "false") + ) ) ## Build Function-Specific Call @@ -618,17 +656,22 @@ rba_panther_ortholog <- function(genes, } else { path_input <- "homologpos" } - parser_input <- list("json->list_simp", - function(x) {x$search$mapping$mapped}) - input_call <- .rba_httr(httr = "post", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - "ortholog/", path_input), - encode = "form", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_panther_ortholog.json")) + + parser_input <- list( + "json->list_simp", + function(x) { x$search$mapping$mapped } + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), "ortholog/", path_input), + encode = "form", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_panther_ortholog.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -692,53 +735,60 @@ rba_panther_homolog <- function(genes, ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "genes", - class = c("character", - "numeric"), - max_len = 10), - list(arg = "organism", - class = "numeric", - len = 1), - list(arg = "type", - class = "character", - val = c("P", - "X", - "LDX"), - len = 1), - list(arg = "target_organisms", - class = "numeric")), - cond = list(list(quote(type == "P" && !is.null(target_organisms)), - "For Paralog, target organism and organism should be the same. thus, 'target_organisms' was ignored.", - warn = TRUE), - list(quote(type != "P" && !is.null(target_organisms) && organism %in% target_organisms), - "For horizontal gene transfers or least diverged horizontal gene transfers, the target organism should be different from the input organism"))) - .msg("Retrieving %s homologs of genes %s.", - type, .paste2(genes, quote_all = "'")) + .rba_args( + cons = list( + list(arg = "genes", class = c("character", "numeric"), max_len = 10), + list(arg = "organism", class = "numeric", len = 1), + list(arg = "type", class = "character", val = c("P", "X", "LDX"), len = 1), + list(arg = "target_organisms", class = "numeric") + ), + cond = list( + list( + quote(type == "P" && !is.null(target_organisms)), + "For Paralog, target organism and organism should be the same. thus, 'target_organisms' was ignored.", + warn = TRUE + ), + list( + quote(type != "P" && !is.null(target_organisms) && organism %in% target_organisms), + "For horizontal gene transfers or least diverged horizontal gene transfers, the target organism should be different from the input organism" + ) + ) + ) + + .msg( + "Retrieving %s homologs of genes %s.", + type,.paste2(genes, quote_all = "'") + ) ## Build POST API Request's body - call_body <- .rba_query(init = list(geneInputList = paste(genes, collapse = ","), - organism = organism, - homologType = type), - list("targetOrganism", - !is.null(target_organisms), - paste(target_organisms, collapse = ",")) + call_body <- .rba_query( + init = list( + geneInputList = paste(genes, collapse = ","), + organism = organism, + homologType = type + ), + list("targetOrganism", !is.null(target_organisms), paste(target_organisms, collapse = ",")) ) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) {x$search$mapping$mapped}) - - input_call <- .rba_httr(httr = "post", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - "ortholog/homologOther"), - encode = "form", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_panther_homolog.json")) + parser_input <- list( + "json->list_simp", + function(x) { x$search$mapping$mapped } + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), "ortholog/homologOther"), + encode = "form", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_panther_homolog.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -799,51 +849,66 @@ rba_panther_family <- function(id, ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "id", - class = "character", - len = 1), - list(arg = "what", - class = "character", - val = c("ortholog", - "msa", - "tree"), - len = 1), - list(arg = "target_organisms", - class = "numeric"))) - .msg( "Retrieving %s information of PANTHER family %s.", what, id) + .rba_args( + cons = list( + list(arg = "id", class = "character", len = 1), + list( + arg = "what", class = "character", len = 1, + val = c("ortholog", "msa", "tree") + ), + list(arg = "target_organisms", class = "numeric") + ) + ) + + .msg( + "Retrieving %s information of PANTHER family %s.", + what, id + ) ## Build POST API Request's body - call_body <- .rba_query(init = list(family = id), - list("taxonFltr", - !is.null(target_organisms), - paste(target_organisms, collapse = ",")) + call_body <- .rba_query( + init = list(family = id), + list("taxonFltr", !is.null(target_organisms), paste(target_organisms, collapse = ",")) ) ## Build Function-Specific Call - switch(what, - "ortholog" = { - path_input <- "familyortholog" - parser_input <- list("json->list_simp", - function(x) {x$search$ortholog_list$ortholog}) - }, - "msa" = { - path_input <- "familymsa" - parser_input <- list("json->list_simp", - function(x) {x$search$MSA_list$sequence_info})}, - "tree" = { - path_input <- "treeinfo" - parser_input <- list("json->list_simp", - function(x) {x$search$tree_topology})}) - input_call <- .rba_httr(httr = "post", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - path_input), - encode = "form", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_panther_family.json")) + switch( + what, + "ortholog" = { + path_input <- "familyortholog" + parser_input <- list( + "json->list_simp", + function(x) { x$search$ortholog_list$ortholog } + ) + }, + "msa" = { + path_input <- "familymsa" + parser_input <- list( + "json->list_simp", + function(x) { x$search$MSA_list$sequence_info } + ) + }, + "tree" = { + path_input <- "treeinfo" + parser_input <- list( + "json->list_simp", + function(x) { x$search$tree_topology } + ) + } + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), path_input), + encode = "form", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_panther_family.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -900,36 +965,46 @@ rba_panther_tree_grafter <- function(protein_seq, ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "protein_seq", - class = "character", - len = 1), - list(arg = "target_organisms", - class = "numeric")), - cond = list(list(quote(nchar(protein_seq) > 5000), - "Maximum allowed length of protein sequence is 50kb."))) - .msg("Retrieving a PANTHER family tree with your input protein grated in it.") + .rba_args( + cons = list( + list(arg = "protein_seq", class = "character", len = 1), + list(arg = "target_organisms", class = "numeric") + ), + cond = list( + list( + quote(nchar(protein_seq) > 5000), + "Maximum allowed length of protein sequence is 50kb.") + ) + ) + + .msg( + "Retrieving a PANTHER family tree with your input protein grated in it." + ) ## Build POST API Request's body - call_body <- .rba_query(init = list(sequence = protein_seq), - list("taxonFltr", - !is.null(target_organisms), - paste(target_organisms, collapse = ",")) + call_body <- .rba_query( + init = list(sequence = protein_seq), + list("taxonFltr", !is.null(target_organisms), paste(target_organisms, collapse = ",")) ) ## Build Function-Specific Call - parser_input <- list("json->list_simp", - function(x) {x$search}) - - input_call <- .rba_httr(httr = "post", - url = .rba_stg("panther", "url"), - path = paste0(.rba_stg("panther", "pth"), - "graftsequence"), - encode = "form", - body = call_body, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("rba_panther_tree_grafter.json")) + parser_input <- list( + "json->list_simp", + function(x) { x$search } + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("panther", "url"), + path = paste0(.rba_stg("panther", "pth"), "graftsequence"), + encode = "form", + body = call_body, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("rba_panther_tree_grafter.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/reactome_analysis.R b/R/reactome_analysis.R index 9871322b..1e2884e4 100644 --- a/R/reactome_analysis.R +++ b/R/reactome_analysis.R @@ -21,20 +21,22 @@ .rba_reactome_input <- function(input, type = NULL, handle = TRUE){ - diagnostics <- get0("diagnostics", envir = parent.frame(1), - ifnotfound = getOption("rba_diagnostics")) + + diagnostics <- get0( + "diagnostics", + envir = parent.frame(1), + ifnotfound = getOption("rba_diagnostics") + ) + ### 1 identify input if (is.null(type)) { - if (is.data.frame(input) | - is.matrix(input)) { + + if (is.data.frame(input) | is.matrix(input)) { type <- "table" - } else if (is.vector(input) && - length(input) > 1) { + } else if (is.vector(input) && length(input) > 1) { type <- "vector" - } else if (is.character(input) && - length(input) == 1) { - if (grepl(pattern = "^[a-zA-z]:|^\\\\\\w|^/|^\\w+\\.\\w+$", - x = input)) { + } else if (is.character(input) && length(input) == 1) { + if (grepl(pattern = "^[a-zA-z]:|^\\\\\\w|^/|^\\w+\\.\\w+$", x = input)) { type <- "file" if (!file.exists(input)) { stop("You supplied a file path that does not exist or it is not ", @@ -51,48 +53,54 @@ type <- "vector" } } else { - stop("Could not identify your input format. Please specify it using 'input_format' argument.", - call. = diagnostics) + stop( + "Could not identify your input format. Please specify it using 'input_format' argument.", + call. = diagnostics + ) } + } + ### 2 handle input if (isFALSE(handle)) { + return(type) + } else { - if (type == "file" | - type == "url") { - return(list(type = type, - file = input)) + + if (type == "file" | type == "url") { + return(list(type = type, file = input)) } else { temp_file <- tempfile(pattern = "rba", fileext = ".txt") if (type == "table") { - input <- as.data.frame(input, - stringsAsFactors = FALSE) - #make sure that every column name starts with # + input <- as.data.frame(input, stringsAsFactors = FALSE) + # make sure that every column name starts with # inproper_colnames <- !grepl("^#", colnames(input)[[1]]) if (any(inproper_colnames)) { - colnames(input)[[1]] <- paste0("#", - colnames(input)[[1]]) + colnames(input)[[1]] <- paste0("#", colnames(input)[[1]]) } - utils::write.table(x = input, - file = temp_file, - sep = "\t", - quote = FALSE, - row.names = FALSE, - col.names = TRUE) - return(list(type = "file", - file = temp_file)) + utils::write.table( + x = input, + file = temp_file, + sep = "\t", + quote = FALSE, + row.names = FALSE, + col.names = TRUE + ) + return(list(type = "file", file = temp_file)) } else if (type == "vector") { - writeLines(text = c("#Gene names", input), - con = temp_file, - sep = "\n") - return(list(type = "file", - file = temp_file)) + writeLines( + text = c("#Gene names", input), + con = temp_file, + sep = "\n" + ) + return(list(type = "file", file = temp_file)) } else { stop("Internal error!", call. = TRUE) } } + } } #### Identifiers Endpoints #### @@ -242,119 +250,126 @@ rba_reactome_analysis <- function(input, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "input", - class = c("character", - "numeric", - "data.frame", - "matrix")), - list(arg = "input_format", - class = "character", - val = c("table", - "vector", - "file", - "url")), - list(arg = "projection", - class = "logical"), - list(arg = "interactors", - class = "logical"), - list(arg = "species", - class = c("character", - "numeric")), - list(arg = "sort_by", - class = "character", - val = c("NAME", - "TOTAL_ENTITIES", - "TOTAL_INTERACTORS", - "TOTAL_REACTIONS", - "FOUND_ENTITIES", - "FOUND_INTERACTORS", - "FOUND_REACTIONS", - "ENTITIES_RATIO", - "ENTITIES_PVALUE", - "ENTITIES_FDR", - "REACTIONS_RATIO")), - list(arg = "order", - class = "character", - val = c("ASC", - "DESC")), - list(arg = "resource", - class = "character", - val = c("TOTAL", - "UNIPROT", - "ENSEMBL", - "CHEBI", - "IUPHAR", - "MIRBASE", - "NCBI_PROTEIN", - "EMBL", - "COMPOUND", - "ENTITIES_FDR", - "PUBCHEM_COMPOUND")), - list(arg = "p_value", - class = "numeric"), - list(arg = "include_disease", - class = "logical"), - list(arg = "min", - class = "numeric"), - list(arg = "max", - class = "numeric")), - cond = list(list("sum(projection, !is.null(species)) == 2", - "You cannot supply 'species' when 'projection' argument is TRUE")) + .rba_args( + cons = list( + list( + arg = "input", + class = c("character", "numeric", "data.frame", "matrix") + ), + list( + arg = "input_format", class = "character", + val = c("table", + "vector", + "file", + "url") + ), + list(arg = "projection", class = "logical"), + list(arg = "interactors", class = "logical"), + list(arg = "species", class = c("character", "numeric")), + list( + arg = "sort_by", class = "character", + val = c("NAME", + "TOTAL_ENTITIES", + "TOTAL_INTERACTORS", + "TOTAL_REACTIONS", + "FOUND_ENTITIES", + "FOUND_INTERACTORS", + "FOUND_REACTIONS", + "ENTITIES_RATIO", + "ENTITIES_PVALUE", + "ENTITIES_FDR", + "REACTIONS_RATIO") + ), + list(arg = "order", class = "character", val = c("ASC", "DESC")), + list( + arg = "resource", class = "character", + val = c("TOTAL", + "UNIPROT", + "ENSEMBL", + "CHEBI", + "IUPHAR", + "MIRBASE", + "NCBI_PROTEIN", + "EMBL", + "COMPOUND", + "ENTITIES_FDR", + "PUBCHEM_COMPOUND") + ), + list(arg = "p_value", class = "numeric"), + list(arg = "include_disease", class = "logical"), + list(arg = "min", class = "numeric"), + list(arg = "max", class = "numeric") + ), + cond = list( + list( + "sum(projection, !is.null(species)) == 2", + "You cannot supply 'species' when 'projection' argument is TRUE" + ) + ) ) - .msg("Retrieving Reactome Analysis Results of your supplied Identifiers.") + .msg( + "Retrieving Reactome Analysis Results of your supplied Identifiers." + ) ## Build POST API Request's query - call_query <- list("interactors" = ifelse(interactors, "true", "false"), - "sortBy" = sort_by, - "order" = order, - "resource" = resource, - "includeDisease" = ifelse(include_disease, "true", "false")) - - call_query <- .rba_query(init = call_query, - list("species", - !is.null(species), - species), - list("pValue", - !is.null(p_value), - p_value), - list("min", - !is.null(min), - min), - list("max", - !is.null(max), - max)) + call_query <- list( + "interactors" = ifelse(interactors, "true", "false"), + "sortBy" = sort_by, + "order" = order, + "resource" = resource, + "includeDisease" = ifelse(include_disease, "true", "false") + ) + + call_query <- .rba_query( + init = call_query, list("species", !is.null(species), species), + list("pValue", !is.null(p_value), p_value), + list("min", !is.null(min), min), + list("max", !is.null(max),max) + ) + ## Build POST API Request's URL # handle supplied input - input <- .rba_reactome_input(input = input, - type = input_format, - handle = TRUE) + input <- .rba_reactome_input( + input = input, + type = input_format, + handle = TRUE + ) + if (input$type == "file") { - call_body <- httr::upload_file(path = input$file, - type = "text/plain") + call_body <- httr::upload_file(path = input$file, type = "text/plain") } else if (input$type == "url") { call_body <- input$file } ## Build Function-Specific Call - path_input <- paste0(.rba_stg("reactome", "pth", "analysis"), - "identifiers/") + path_input <- paste0( + .rba_stg("reactome", "pth", "analysis"), + "identifiers/" + ) + if (input$type == "url") { - paste0(path_input, "/url") + path_input <- paste0(path_input, "/url") } + if (isTRUE(projection)) { path_input <- paste0(path_input, "/projection") } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = path_input, - body = call_body, - query = call_query, - httr::content_type("text/plain"), - accept = "application/json", - parser = "json->list_simp_flt_df", - save_to = .rba_file("reactome_analysis.json")) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = path_input, + body = call_body, + query = call_query, + httr::content_type("text/plain"), + accept = "application/json", + parser = "json->list_simp_flt_df", + save_to = .rba_file("reactome_analysis.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -452,84 +467,83 @@ rba_reactome_analysis_pdf <- function(token, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "token", - class = "character"), - list(arg = "species", - class = c("character", - "numeric")), - list(arg = "save_to", - class = "character"), - list(arg = "number", - class = "numeric"), - list(arg = "resource", - class = "character", - val = c("TOTAL", - "UNIPROT", - "ENSEMBL", - "CHEBI", - "IUPHAR", - "MIRBASE", - "NCBI_PROTEIN", - "EMBL", - "COMPOUND", - "ENTITIES_FDR", - "PUBCHEM_COMPOUND")), - list(arg = "diagram_profile", - class = "character", - val = c("Modern", - "Standard")), - list(arg = "analysis_profile", - class = "character", - val = c("Standard", - "Strosobar", - "Copper Plus")), - list(arg = "fireworks_profile", - class = "character", - val = c("Copper", - "Copper Plus", - "Barium Lithium", - "calcium salts")))) - - .msg("Downloading a pdf report of Reactome analysis result with token %s.", - token) + .rba_args( + cons = list( + list(arg = "token", class = "character"), + list(arg = "species", class = c("character", "numeric")), + list(arg = "save_to", class = "character"), + list(arg = "number", class = "numeric"), + list( + arg = "resource", class = "character", + val = c("TOTAL", + "UNIPROT", + "ENSEMBL", + "CHEBI", + "IUPHAR", + "MIRBASE", + "NCBI_PROTEIN", + "EMBL", + "COMPOUND", + "ENTITIES_FDR", + "PUBCHEM_COMPOUND") + ), + list( + arg = "diagram_profile", class = "character", + val = c("Modern", "Standard") + ), + list( + arg = "analysis_profile", class = "character", + val = c("Standard", "Strosobar", "Copper Plus") + ), + list( + arg = "fireworks_profile", class = "character", + val = c("Copper", "Copper Plus", "Barium Lithium", "calcium salts") + ) + ) + ) + + .msg( + "Downloading a pdf report of Reactome analysis result with token %s.", + token + ) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("number", - number != 25, - number), - list("resource", - resource != "TOTAL", - resource), - list("token", - !is.null(token), - token), - list("diagramProfile", - diagram_profile != "Modern", - diagram_profile), - list("analysisProfile", - analysis_profile != "Standard", - analysis_profile), - list("fireworksProfile", - fireworks_profile != "Barium Lithium", - fireworks_profile)) + call_query <- .rba_query( + init = list(), + list("number", number != 25, number), + list("resource", resource != "TOTAL", resource), + list("token", !is.null(token), token), + list("diagramProfile", diagram_profile != "Modern", diagram_profile), + list("analysisProfile", analysis_profile != "Standard", analysis_profile), + list("fireworksProfile", fireworks_profile != "Barium Lithium", fireworks_profile) + ) # create file_path - save_to <- .rba_file(file = paste0(token, ".pdf"), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) + save_to <- .rba_file( + file = paste0(token, ".pdf"), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, + no = save_to + ) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sreport/%s/%s/%s.pdf", - .rba_stg("reactome", "pth", "analysis"), - token, species, token), - query = call_query, - accept = "application/pdf", - parser = NULL, - save_to = save_to) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sreport/%s/%s/%s.pdf", + .rba_stg("reactome", "pth", "analysis"), token, species, token + ), + query = call_query, + accept = "application/pdf", + parser = NULL, + save_to = save_to + ) + ## Call API invisible(.rba_skeleton(input_call)) } @@ -624,58 +638,68 @@ rba_reactome_analysis_download <- function(token, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "token", - class = "character"), - list(arg = "request", - class = "character", - val = c("found_ids", - "not_found_ids", - "pathways", - "results", - "results_gz")), - list(arg = "save_to", - class = "character"), - list(arg = "resource", - class = "character", - no_null = TRUE, - val = c("TOTAL", - "UNIPROT", - "ENSEMBL", - "CHEBI", - "IUPHAR", - "MIRBASE", - "NCBI_PROTEIN", - "EMBL", - "COMPOUND", - "ENTITIES_FDR", - "PUBCHEM_COMPOUND"))), - cond = list(list('grepl("^results|^not_found_ids$", request) & resource != "TOTAL"', - c("You cannot supply 'resource' with ", - request, " request. ignoring resource."))), - cond_warning = TRUE) - - .msg("Saving %s of the Reactome Analysis asociated with token: %s", - switch(request, - "found_ids" = "found identifiers", - "not_found_ids" = "not-found identifiers", - "pathways" = "pathway results", - "results" = "full results", - "results_gz" = "compressed full results"), - token) + .rba_args( + cons = list( + list(arg = "token", class = "character"), + list( + arg = "request", class = "character", + val = c("found_ids", "not_found_ids", "pathways", "results", "results_gz") + ), + list(arg = "save_to", class = "character"), + list( + arg = "resource", class = "character", no_null = TRUE, + val = c("TOTAL", + "UNIPROT", + "ENSEMBL", + "CHEBI", + "IUPHAR", + "MIRBASE", + "NCBI_PROTEIN", + "EMBL", + "COMPOUND", + "ENTITIES_FDR", + "PUBCHEM_COMPOUND") + ) + ), + cond = list( + list( + 'grepl("^results|^not_found_ids$", request) & resource != "TOTAL"', + c("You cannot supply 'resource' with ", request, " request. ignoring resource.") + ) + ), + cond_warning = TRUE + ) + + .msg( + "Saving %s of the Reactome Analysis asociated with token: %s", + switch( + request, + "found_ids" = "found identifiers", + "not_found_ids" = "not-found identifiers", + "pathways" = "pathway results", + "results" = "full results", + "results_gz" = "compressed full results"), + token + ) + ## Build Function-Specific Call - path_input <- sprintf("%sdownload/%s/", - .rba_stg("reactome", "pth", "analysis"), - token) - path_input <- switch(request, - "found_ids" = sprintf("%sentities/found/%s/%s.csv", - path_input, resource, token), - "not_found_ids" = sprintf("%sentities/notfound/%s.csv", - path_input, token), - "pathways" = sprintf("%sentities/pathways/%s/%s.csv", - path_input, resource, token), - "results" = paste0(path_input, "result.json"), - "results_gz" = paste0(path_input, "result.json.gz")) + path_input <- sprintf( + "%sdownload/%s/", + .rba_stg("reactome", "pth", "analysis"), + token + ) + + path_input <- switch( + request, + "found_ids" = sprintf("%sentities/found/%s/%s.csv", path_input, resource, token), + "not_found_ids" = sprintf("%sentities/notfound/%s.csv", path_input, token), + "pathways" = sprintf("%sentities/pathways/%s/%s.csv", path_input, resource, token), + "results" = paste0(path_input, "result.json"), + "results_gz" = paste0(path_input, "result.json.gz") + ) + if (request == "results") { output_format <- "json" accept_input <- "application/json" @@ -686,17 +710,25 @@ rba_reactome_analysis_download <- function(token, output_format <- "csv" accept_input <- "text/csv" } + # create file_path - save_to <- .rba_file(file = paste0(request, "_", token, ".", output_format), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accept = accept_input, - save_to = save_to, - parser = NULL) + save_to <- .rba_file( + file = paste0(request, "_", token, ".", output_format), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, no = save_to + ) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accept = accept_input, + save_to = save_to, + parser = NULL + ) + ## Call API invisible(.rba_skeleton(input_call)) } @@ -765,38 +797,56 @@ rba_reactome_analysis_import <- function(input, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "input", - class = "character"), - list(arg = "input_format", - class = "character", - val = c("file", - "url")))) - .msg("Importing the input json file into the Reactome services.") + .rba_args( + cons = list( + list(arg = "input", class = "character"), + list(arg = "input_format", class = "character", val = c("file", "url")) + ) + ) + + .msg( + "Importing the input json file into the Reactome services." + ) ## Build Function-Specific Call # handling input - input <- .rba_reactome_input(input = input, - type = input_format, - handle = TRUE) + input <- .rba_reactome_input( + input = input, + type = input_format, + handle = TRUE + ) + if (input$type == "url") { - path_input <- paste0(.rba_stg("reactome", "pth", "analysis"), - "import/url") + + path_input <- paste0( + .rba_stg("reactome", "pth", "analysis"), + "import/url" + ) call_body <- input$file + } else { - path_input <- paste0(.rba_stg("reactome", "pth", "analysis"), - "import/") - call_body <- httr::upload_file(path = input$file, - type = "application/json") + + path_input <- paste0( + .rba_stg("reactome", "pth", "analysis"), + "import/" + ) + call_body <- httr::upload_file(path = input$file, type = "application/json") + } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = path_input, - body = call_body, - httr::content_type("text/plain"), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("reactome_analysis_import.json")) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = path_input, + body = call_body, + httr::content_type("text/plain"), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("reactome_analysis_import.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -871,53 +921,64 @@ rba_reactome_analysis_mapping <- function(input, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "input", - class = c("character", - "numeric")), - list(arg = "input_format", - class = "character", - val = c("vector", - "file", - "url")), - list(arg = "projection", - class = "logical"), - list(arg = "interactors", - class = "logical"))) - - .msg("Mapping your supplied input identifiers.") + .rba_args( + cons = list( + list(arg = "input", class = c("character", "numeric")), + list( + arg = "input_format", class = "character", + val = c("vector", "file", "url") + ), + list(arg = "projection", class = "logical"), + list(arg = "interactors", class = "logical") + ) + ) + + .msg( + "Mapping your supplied input identifiers." + ) ## Build POST API Request's query call_query <- list("interactors" = ifelse(interactors, "true", "false")) + ## Build POST API Request's URL # handle supplied input - input <- .rba_reactome_input(input = input, - type = input_format, - handle = TRUE) + input <- .rba_reactome_input( + input = input, + type = input_format, + handle = TRUE + ) + if (input$type == "file") { - call_body <- httr::upload_file(path = input$file, - type = "text/plain") + call_body <- httr::upload_file(path = input$file, type = "text/plain") } else if (input$type == "url") { call_body <- input$file } + ## Build Function-Specific Call - path_input <- paste0(.rba_stg("reactome", "pth", "analysis"), - "mapping/") + path_input <- paste0(.rba_stg("reactome", "pth", "analysis"), "mapping/") + if (input$type == "url") { - paste0(path_input, "/url") + path_input <- paste0(path_input, "/url") } + if (isTRUE(projection)) { path_input <- paste0(path_input, "/projection") } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = path_input, - body = call_body, - query = call_query, - httr::content_type("text/plain"), - accept = "application/json", - parser = "json->list", - save_to = .rba_file("reactome_analysis_mapping.json")) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = path_input, + body = call_body, + query = call_query, + httr::content_type("text/plain"), + accept = "application/json", + parser = "json->list", + save_to = .rba_file("reactome_analysis_mapping.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -1006,72 +1067,76 @@ rba_reactome_analysis_species <- function(species_dbid, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "species_dbid", - class = "numeric"), - list(arg = "sort_by", - class = "character", - val = c("NAME", - "TOTAL_ENTITIES", - "TOTAL_INTERACTORS", - "TOTAL_REACTIONS", - "FOUND_ENTITIES", - "FOUND_INTERACTORS", - "FOUND_REACTIONS", - "ENTITIES_RATIO", - "ENTITIES_PVALUE", - "ENTITIES_FDR", - "REACTIONS_RATIO")), - list(arg = "order", - class = "character", - val = c("ASC", - "DESC")), - list(arg = "resource", - class = "character", - val = c("TOTAL", - "UNIPROT", - "ENSEMBL", - "CHEBI", - "IUPHAR", - "MIRBASE", - "NCBI_PROTEIN", - "EMBL", - "COMPOUND", - "ENTITIES_FDR", - "PUBCHEM_COMPOUND")), - list(arg = "p_value", - class = "numeric"), - list(arg = "min", - class = "numeric"), - list(arg = "max", - class = "numeric"))) - - .msg("Comparing human's pathways and computationally inferred pathways of specie %s.", - species_dbid) + .rba_args( + cons = list( + list(arg = "species_dbid", class = "numeric"), + list( + arg = "sort_by", + class = "character", + val = c("NAME", + "TOTAL_ENTITIES", + "TOTAL_INTERACTORS", + "TOTAL_REACTIONS", + "FOUND_ENTITIES", + "FOUND_INTERACTORS", + "FOUND_REACTIONS", + "ENTITIES_RATIO", + "ENTITIES_PVALUE", + "ENTITIES_FDR", + "REACTIONS_RATIO") + ), + list(arg = "order", class = "character", val = c("ASC", "DESC")), + list( + arg = "resource", + class = "character", + val = c("TOTAL", + "UNIPROT", + "ENSEMBL", + "CHEBI", + "IUPHAR", + "MIRBASE", + "NCBI_PROTEIN", + "EMBL", + "COMPOUND", + "ENTITIES_FDR", + "PUBCHEM_COMPOUND") + ), + list(arg = "p_value", class = "numeric"), + list(arg = "min", class = "numeric"), + list(arg = "max", class = "numeric") + ) + ) + + .msg( + "Comparing human's pathways and computationally inferred pathways of specie %s.", + species_dbid + ) + ## Build POST API Request's query - call_query <- list("sortBy" = sort_by, - "order" = order, - "resource" = resource) - call_query <- .rba_query(init = call_query, - list("pValue", - !is.null(p_value), - p_value), - list("min", - !is.null(min), - min), - list("max", - !is.null(max), - max)) + call_query <- .rba_query( + init = list("sortBy" = sort_by, "order" = order, "resource" = resource), + list("pValue", !is.null(p_value), p_value), + list("min", !is.null(min), min), + list("max", !is.null(max), max) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "analysis"), - "species/homoSapiens/", - species_dbid), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("reactome_analysis_species.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "analysis"), + "species/homoSapiens/", + species_dbid + ), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("reactome_analysis_species.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -1168,80 +1233,78 @@ rba_reactome_analysis_token <- function(token, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "token", - class = "character"), - list(arg = "species", - class = c("character", - "numeric")), - list(arg = "sort_by", - class = "character", - val = c("NAME", - "TOTAL_ENTITIES", - "TOTAL_INTERACTORS", - "TOTAL_REACTIONS", - "FOUND_ENTITIES", - "FOUND_INTERACTORS", - "FOUND_REACTIONS", - "ENTITIES_RATIO", - "ENTITIES_PVALUE", - "ENTITIES_FDR", - "REACTIONS_RATIO")), - list(arg = "order", - class = "character", - val = c("ASC", - "DESC")), - list(arg = "resource", - class = "character", - val = c("TOTAL", - "UNIPROT", - "ENSEMBL", - "CHEBI", - "IUPHAR", - "MIRBASE", - "NCBI_PROTEIN", - "EMBL", - "COMPOUND", - "ENTITIES_FDR", - "PUBCHEM_COMPOUND")), - list(arg = "p_value", - class = "numeric"), - list(arg = "include_disease", - class = "logical"), - list(arg = "min", - class = "numeric"), - list(arg = "max", - class = "numeric"))) - - .msg("Retrieving Reactome analysis results with token %s.", token) + .rba_args( + cons = list( + list(arg = "token", class = "character"), + list(arg = "species", class = c("character", "numeric")), + list( + arg = "sort_by", + class = "character", + val = c("NAME", + "TOTAL_ENTITIES", + "TOTAL_INTERACTORS", + "TOTAL_REACTIONS", + "FOUND_ENTITIES", + "FOUND_INTERACTORS", + "FOUND_REACTIONS", + "ENTITIES_RATIO", + "ENTITIES_PVALUE", + "ENTITIES_FDR", + "REACTIONS_RATIO") + ), + list(arg = "order", class = "character", val = c("ASC", "DESC")), + list( + arg = "resource", + class = "character", + val = c("TOTAL", + "UNIPROT", + "ENSEMBL", + "CHEBI", + "IUPHAR", + "MIRBASE", + "NCBI_PROTEIN", + "EMBL", + "COMPOUND", + "ENTITIES_FDR", + "PUBCHEM_COMPOUND") + ), + list(arg = "p_value", class = "numeric"), + list(arg = "include_disease", class = "logical"), + list(arg = "min", class = "numeric"), + list(arg = "max", class = "numeric") + ) + ) + + .msg( + "Retrieving Reactome analysis results with token %s.", + token + ) ## Build POST API Request's query - call_query <- list("sortBy" = sort_by, - "order" = order, - "resource" = resource, - "includeDisease" = ifelse(include_disease, "true", "false")) - - call_query <- .rba_query(init = call_query, - list("pValue", - !is.null(p_value), - p_value), - list("min", - !is.null(min), - min), - list("max", - !is.null(max), - max)) + call_query <- .rba_query( + init = list( + "sortBy" = sort_by, + "order" = order, + "resource" = resource, + "includeDisease" = ifelse(include_disease, "true", "false") + ), + list("pValue", !is.null(p_value), p_value), + list("min", !is.null(min), min), + list("max", !is.null(max), max) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "analysis"), - "token/", - token), - query = call_query, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("reactome_analysis_token.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0(.rba_stg("reactome", "pth", "analysis"), "token/", token), + query = call_query, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("reactome_analysis_token.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/reactome_content.R b/R/reactome_content.R index 9b76c4a5..23975495 100644 --- a/R/reactome_content.R +++ b/R/reactome_content.R @@ -41,19 +41,26 @@ rba_reactome_version <- function(...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments .rba_args() - .msg("Retrieving Reactome Content Service's database version.") + .msg( + "Retrieving Reactome Content Service's database version." + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "data/database/version"), - accpet = "text/plain", - parser = "text->chr", - save_to = .rba_file("reactome_diseases.txt")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "data/database/version" + ), + accpet = "text/plain", + parser = "text->chr", + save_to = .rba_file("reactome_diseases.txt") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -113,34 +120,50 @@ rba_reactome_diseases <- function(doid = FALSE, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "doid", - class = "logical"))) + .rba_args( + cons = list( + list(arg = "doid", class = "logical") + ) + ) - .msg("Retrieving Reactome's diseases %s.", - ifelse(isTRUE(doid), yes = "DOID data", no = "annotations")) + .msg( + "Retrieving Reactome's diseases %s.", + ifelse(isTRUE(doid), yes = "DOID data", no = "annotations") + ) ## Build Function-Specific Call if (isFALSE(doid)) { - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - "data/diseases") + + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + "data/diseases" + ) accept_input <- "application/json" parser_input <- "json->df" file_ext <- "json" + } else { - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - "data/diseases/doid") + + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + "data/diseases/doid" + ) accept_input <- "text/plain" parser_input <- "text->df" file_ext <- "txt" + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accpet = accept_input, - parser = parser_input, - save_to = .rba_file(paste0("reactome_diseases.", - file_ext))) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accpet = accept_input, + parser = parser_input, + save_to = .rba_file(paste0("reactome_diseases.", file_ext)) + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -207,28 +230,39 @@ rba_reactome_complex_subunits <- function(complex_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "complex_id", - class = "character"), - list(arg = "exclude_structures", - class = "logical"))) + .rba_args( + cons = list( + list(arg = "complex_id", class = "character"), + list(arg = "exclude_structures", class = "logical") + ) + ) + + .msg( + "Recursively retrieving subunits of %s complex.", + complex_id + ) - .msg("Recursively retrieving subunits of %s complex.", complex_id) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("excludeStructures", - exclude_structures, - "true")) + call_query <- .rba_query( + init = list(), + list("excludeStructures", exclude_structures, "true") + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/complex/%s/subunits", - .rba_stg("reactome", "pth", "content"), - complex_id), - query = call_query, - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_complex_subunits.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/complex/%s/subunits", + .rba_stg("reactome", "pth", "content"), complex_id + ), + query = call_query, + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_complex_subunits.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -289,24 +323,32 @@ rba_reactome_complex_list <- function(id, ...) { ## Load Global Options .rba_ext_args(...) - ## Check User-input Arguments - .rba_args(cons = list(list(arg = "id", - class = "character"), - list(arg = "resource", - class = "character"))) - .msg("Retrieving complexes that contain a molecule with '%s ID: %s'.", - resource, id) + ## Check User-input Arguments + .rba_args( + cons = list( + list(arg = "id", class = "character"), + list(arg = "resource", class = "character") + ) + ) + + .msg( + "Retrieving complexes that contain a molecule with '%s ID: %s'.", + resource, id + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/complexes/%s/%s", - .rba_stg("reactome", "pth", "content"), - resource, id), - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_complex_list.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/complexes/%s/%s", + .rba_stg("reactome", "pth", "content"), resource, id + ), + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_complex_list.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -363,21 +405,33 @@ rba_reactome_participant_of <- function(entity_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "entity_id", - class = "character"))) + .rba_args( + cons = list( + list(arg = "entity_id", class = "character") + ) + ) + + .msg( + "Retrieving Reactome structures which have %s as a participant.", + entity_id + ) - .msg("Retrieving Reactome structures which have %s as a participant.", - entity_id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/entity/%s/componentOf", - .rba_stg("reactome", "pth", "content"), - entity_id), - accept = "application/json", - parser = "json->list", - save_to = .rba_file("rba_reactome_participant_of.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/entity/%s/componentOf", + .rba_stg("reactome", "pth", "content"), + entity_id + ), + accept = "application/json", + parser = "json->list", + save_to = .rba_file("rba_reactome_participant_of.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -433,20 +487,32 @@ rba_reactome_entity_other_forms <- function(entity_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "entity_id", - class = "character"))) + .rba_args( + cons = list( + list(arg = "entity_id", class = "character") + ) + ) + + .msg( + "Retrieving Other forms of Reactome's entity: %s", + entity_id + ) - .msg("Retrieving Other forms of Reactome's entity: %s", entity_id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/entity/%s/otherForms", - .rba_stg("reactome", "pth", "content"), - entity_id), - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_entity_other_forms.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/entity/%s/otherForms", + .rba_stg("reactome", "pth", "content"), + entity_id + ), + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_entity_other_forms.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -511,20 +577,32 @@ rba_reactome_event_ancestors <- function(event_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_id", - class = "character"))) + .rba_args( + cons = list( + list(arg = "event_id", class = "character") + ) + ) + + .msg( + "Retrieving the ancestors of event %s.", + event_id + ) - .msg("Retrieving the ancestors of event %s.", event_id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/event/%s/ancestors", - .rba_stg("reactome", "pth", "content"), - event_id), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("reactome_event_ancestors.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/event/%s/ancestors", + .rba_stg("reactome", "pth", "content"), + event_id + ), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("reactome_event_ancestors.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -595,22 +673,32 @@ rba_reactome_event_hierarchy <- function(species, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "species", - class = c("character", - "numeric")))) + .rba_args( + cons = list( + list(arg = "species", class = c("character", "numeric")) + ) + ) + + .msg( + "Retrieving the complete events hierarchy tree of the Specie %s.", + species + ) - .msg("Retrieving the complete events hierarchy tree of the Specie %s.", - species) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/eventsHierarchy/%s", - .rba_stg("reactome", "pth", "content"), - species), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("reactome_event_hierarchy.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/eventsHierarchy/%s", + .rba_stg("reactome", "pth", "content"), + species + ), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("reactome_event_hierarchy.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -757,132 +845,126 @@ rba_reactome_exporter_diagram <- function(event_id, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_id", - class = "character"), - list(arg = "save_to", - class = "character"), - list(arg = "document_level", - class = "numeric", - val = c(0,1)), - list(arg = "output_format", - class = "character", - val = c("png", - "jpeg", - "svg", - "gif")), - list(arg = "image_quality", - class = "numeric", - ran = c(1,10)), - list(arg = "flag_element", - class = "character"), - list(arg = "flg_interactors", - class = "logical"), - list(arg = "sel", - class = "character"), - list(arg = "title", - class = "logical"), - list(arg = "margin", - class = "numeric", - ran = c(0,20)), - list(arg = "ehld", - class = "logical"), - list(arg = "diagram_profile", - class = "character", - val = c("Modern", - "Standard")), - list(arg = "token", - class = "character"), - list(arg = "resource", - class = "character"), - list(arg = "analysis_profile", - class = "character", - val = c("Standard", - "Strosobar", - "Copper Plus")), - list(arg = "exp_column", - class = "numeric")), - cond = list(list(quote(!is.null(exp_column) && is.null(token)), - "You cannot specify expression column without providing a token."))) + .rba_args( + cons = list( + list(arg = "event_id", class = "character"), + list(arg = "save_to", class = "character"), + list(arg = "document_level", class = "numeric", val = c(0,1)), + list( + arg = "output_format", + class = "character", + val = c("png", "jpeg", "svg", "gif") + ), + list(arg = "image_quality", class = "numeric", ran = c(1,10)), + list(arg = "flag_element", class = "character"), + list(arg = "flg_interactors", class = "logical"), + list(arg = "sel", class = "character"), + list(arg = "title", class = "logical"), + list(arg = "margin", class = "numeric", ran = c(0,20)), + list(arg = "ehld", class = "logical"), + list( + arg = "diagram_profile", class = "character", + val = c("Modern", "Standard") + ), + list(arg = "token", class = "character"), + list(arg = "resource", class = "character"), + list( + arg = "analysis_profile", class = "character", + val = c("Standard", "Strosobar", "Copper Plus") + ), + list(arg = "exp_column", class = "numeric") + ), + cond = list( + list( + quote(!is.null(exp_column) && is.null(token)), + "You cannot specify expression column without providing a token." + ) + ) + ) ## Build Function-Specific Call - call_query <- .rba_query(init = list(), - list("resource", - resource != "TOTAL", - resource), - list("diagramProfile", - !is.null(diagram_profile), - diagram_profile), - list("analysisProfile", - !is.null(analysis_profile), - analysis_profile), - list("token", - !is.null(token), - token), - list("expColumn", - !is.null(exp_column), - exp_column)) + call_query <- .rba_query( + init = list(), + list("resource", resource != "TOTAL", resource), + list("diagramProfile", !is.null(diagram_profile), diagram_profile), + list("analysisProfile", !is.null(analysis_profile), analysis_profile), + list("token", !is.null(token), token), + list("expColumn", !is.null(exp_column), exp_column) + ) if (isTRUE(create_document)) { - .msg("Retrieving a PDF document of event %s details.", event_id) + + .msg( + "Retrieving a PDF document of event %s details.", + event_id + ) + ## Build Function-Specific Call - call_query <- .rba_query(init = call_query, - list("level", - document_level != 1, - document_level)) + call_query <- .rba_query( + init = call_query, + list("level", document_level != 1, document_level) + ) accept_input <- "application/pdf" output_format <- "pdf" - path_input <- sprintf("%sexporter/document/event/%s.pdf", - .rba_stg("reactome", "pth", "content"), - event_id) + path_input <- sprintf( + "%sexporter/document/event/%s.pdf", + .rba_stg("reactome", "pth", "content"), event_id) + } else { - .msg("Retrieving event %s diagram's image in %s format.", - event_id, output_format) + + .msg( + "Retrieving event %s diagram's image in %s format.", + event_id, output_format + ) + ## Build Function-Specific Call - call_query <- .rba_query(init = call_query, - list("quality", - image_quality != 5, - image_quality), - list("flg", - !is.null(flag_element), - flag_element), - list("flgInteractors", - !flg_interactors, - "false"), - list("sel", - !is.null(sel), - sel), - list("title", - !title, - "false"), - list("margin", - margin != 15, - as.integer(margin)), - list("ehld", - !ehld, - "false")) - - accept_input <- ifelse(output_format == "svg", - yes = "image/svg+xml", - no = paste0("image/", output_format)) - path_input <- sprintf("%sexporter/diagram/%s.%s", - .rba_stg("reactome", "pth", "content"), - event_id, output_format) + call_query <- .rba_query( + init = call_query, + list("quality", image_quality != 5, image_quality), + list("flg", !is.null(flag_element), flag_element), + list("flgInteractors", !flg_interactors, "false"), + list("sel", !is.null(sel), sel), + list("title", !title, "false"), + list("margin", margin != 15, as.integer(margin)), + list("ehld", !ehld, "false") + ) + + accept_input <- ifelse( + output_format == "svg", + yes = "image/svg+xml", + no = paste0("image/", output_format) + ) + + path_input <- sprintf( + "%sexporter/diagram/%s.%s", + .rba_stg("reactome", "pth", "content"), event_id, output_format + ) + } + # create file_path - save_to <- .rba_file(file = paste0(event_id, ".", output_format), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) + save_to <- .rba_file( + file = paste0(event_id, ".", output_format), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, no = save_to + ) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - query = call_query, - accpet = accept_input, - save_to = save_to, - parser = NULL) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + query = call_query, + accpet = accept_input, + save_to = save_to, + parser = NULL + ) + ## Call API invisible(.rba_skeleton(input_call)) } @@ -949,32 +1031,40 @@ rba_reactome_exporter_event <- function(event_id, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_id", - class = "character"), - list(arg = "output_format", - class = "character", - val = c("sbgn", - "sbml")), - list(arg = "save_to", - class = "character"))) - - .msg("Exporting event %s as a %s file.", - event_id, output_format) + .rba_args( + cons = list( + list(arg = "event_id", class = "character"), + list(arg = "output_format", class = "character", val = c("sbgn", "sbml")), + list(arg = "save_to", class = "character")) + ) + + .msg( + "Exporting event %s as a %s file.", + event_id, output_format + ) + ## Build Function-Specific Call # create file_path - save_to <- .rba_file(file = paste0(event_id, ".", output_format), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sexporter/event/%s.%s", - .rba_stg("reactome", "pth", "content"), - event_id, - output_format), - save_to = save_to, - parser = NULL) + save_to <- .rba_file( + file = paste0(event_id, ".", output_format), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, no = save_to + ) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sexporter/event/%s.%s", + .rba_stg("reactome", "pth", "content"), event_id, output_format + ), + save_to = save_to, + parser = NULL + ) ## Call API invisible(.rba_skeleton(input_call)) @@ -1078,88 +1168,65 @@ rba_reactome_exporter_overview <- function(species, ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "species", - class = c("character", - "numeric")), - list(arg = "output_format", - class = "character", - no_null = TRUE, - val = c("png", - "jpeg", - "svg", - "gif")), - list(arg = "save_to", - class = "character"), - list(arg = "quality", - class = "numeric", - ran = c(1,10)), - list(arg = "flg", - class = "character"), - list(arg = "flg_interactors", - class = "logical"), - list(arg = "sel", - class = "character"), - list(arg = "title", - class = "logical"), - list(arg = "margin", - class = "numeric", - ran = c(0,20)), - list(arg = "diagram_profile", - class = "character", - val = c("Copper", - "Copper Plus", - "Barium Lithium", - "calcium salts")), - list(arg = "token", - class = "character"), - list(arg = "resource", - class = "character"), - list(arg = "exp_column", - class = "character"), - list(arg = "coverage", - class = "logical")), - cond = list(list(quote(!is.null(exp_column) && is.null(token)), - "You cannot specify expression column without providing a token."))) - - .msg("Retrieving specie %s pathway overview image in %s format.", - species, output_format) + .rba_args( + cons = list( + list(arg = "species", class = c("character", "numeric")), + list( + arg = "output_format", class = "character", no_null = TRUE, + val = c("png", + "jpeg", + "svg", + "gif") + ), + list(arg = "save_to", class = "character"), + list(arg = "quality", class = "numeric", ran = c(1,10)), + list(arg = "flg", class = "character"), + list(arg = "flg_interactors", class = "logical"), + list(arg = "sel", class = "character"), + list(arg = "title", class = "logical"), + list(arg = "margin", class = "numeric", ran = c(0,20)), + list( + arg = "diagram_profile", class = "character", + val = c("Copper", + "Copper Plus", + "Barium Lithium", + "calcium salts") + ), + list(arg = "token", class = "character"), + list(arg = "resource", class = "character"), + list(arg = "exp_column", class = "character"), + list(arg = "coverage", class = "logical") + ), + cond = list( + list( + quote(!is.null(exp_column) && is.null(token)), + "You cannot specify expression column without providing a token." + ) + ) + ) + + .msg( + "Retrieving specie %s pathway overview image in %s format.", + species, output_format + ) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("quality", - image_quality != 5, - image_quality), - list("flg", - !is.null(flag_element), - flag_element), - list("flgInteractors", - !flg_interactors, - "false"), - list("sel", - !is.null(sel), - sel), - list("title", - !title, - "false"), - list("margin", - margin != 15, - as.integer(margin)), - list("diagramProfile", - diagram_profile != "Copper", - diagram_profile), - list("token", - !is.null(token), - token), - list("resource", - resource != "TOTAL", - resource), - list("expColumn", - !is.null(exp_column), - exp_column), - list("coverage", - coverage, - "true")) + call_query <- .rba_query( + init = list(), + list("quality", image_quality != 5, image_quality), + list("flg", !is.null(flag_element), flag_element), + list("flgInteractors", !flg_interactors, "false"), + list("sel", !is.null(sel), sel), + list("title", !title, "false"), + list("margin", margin != 15, as.integer(margin)), + list("diagramProfile", diagram_profile != "Copper", diagram_profile), + list("token", !is.null(token), token), + list("resource", resource != "TOTAL", resource), + list("expColumn", !is.null(exp_column), exp_column), + list("coverage", coverage, "true") + ) ## Build Function-Specific Call if (output_format == "svg") { @@ -1169,21 +1236,27 @@ rba_reactome_exporter_overview <- function(species, } # create file_path - save_to <- .rba_file(file = paste0(species, ".", output_format), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sexporter/fireworks/%s.%s", - .rba_stg("reactome", "pth", "content"), - gsub(" ", "%20",species), - output_format), - query = call_query, - accpet = accept_input, - save_to = save_to, - parser = NULL) + save_to <- .rba_file( + file = paste0(species, ".", output_format), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, no = save_to + ) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sexporter/fireworks/%s.%s", + .rba_stg("reactome", "pth", "content"), gsub(" ", "%20",species), output_format + ), + query = call_query, + accpet = accept_input, + save_to = save_to, + parser = NULL + ) + ## Call API invisible(.rba_skeleton(input_call)) } @@ -1289,88 +1362,61 @@ rba_reactome_exporter_reaction <- function(event_id, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_id", - class = "character"), - list(arg = "save_to", - class = "character"), - list(arg = "output_format", - no_null = TRUE, - class = "character", - val = c("png", - "jpeg", - "svg", - "gif")), - list(arg = "image_quality", - class = "numeric", - ran = c(1,10)), - list(arg = "flag_element", - class = "character"), - list(arg = "flg_interactors", - class = "logical"), - list(arg = "sel", - class = "character"), - list(arg = "title", - class = "logical"), - list(arg = "margin", - class = "numeric", - ran = c(0,20)), - list(arg = "diagram_profile", - class = "character", - val = c("Modern", - "Standard")), - list(arg = "token", - class = "character"), - list(arg = "resource", - class = "character"), - list(arg = "analysis_profile", - class = "character", - val = c("Standard", - "Strosobar", - "Copper Plus")), - list(arg = "exp_column", - class = "numeric")), - cond = list(list(quote(!is.null(exp_column) && is.null(token)), - "You cannot specify expression column without providing a token."))) - - .msg("Retrieving Reaction-like event %s image in %s format.", - event_id, output_format) + .rba_args( + cons = list( + list(arg = "event_id", class = "character"), + list(arg = "save_to", class = "character"), + list( + arg = "output_format", no_null = TRUE, class = "character", + val = c("png", "jpeg", "svg", "gif") + ), + list(arg = "image_quality", class = "numeric", ran = c(1,10)), + list(arg = "flag_element", class = "character"), + list(arg = "flg_interactors", class = "logical"), + list(arg = "sel", class = "character"), + list(arg = "title", class = "logical"), + list(arg = "margin", class = "numeric", ran = c(0,20)), + list( + arg = "diagram_profile", class = "character", + val = c("Modern", "Standard") + ), + list(arg = "token", class = "character"), + list(arg = "resource", class = "character"), + list( + arg = "analysis_profile", class = "character", + val = c("Standard", "Strosobar", "Copper Plus")), + list(arg = "exp_column", class = "numeric") + ), + cond = list( + list( + quote(!is.null(exp_column) && is.null(token)), + "You cannot specify expression column without providing a token." + ) + ) + ) + + .msg( + "Retrieving Reaction-like event %s image in %s format.", + event_id, output_format + ) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("quality", - image_quality != 5, - image_quality), - list("flg", - !is.null(flag_element), - flag_element), - list("flgInteractors", - !flg_interactors, - "false"), - list("sel", - !is.null(sel), - sel), - list("title", - !title, - "false"), - list("margin", - margin != 15, - as.integer(margin)), - list("diagramProfile", - diagram_profile != "Copper", - diagram_profile), - list("analysisProfile", - !is.null(analysis_profile), - analysis_profile), - list("token", - !is.null(token), - token), - list("resource", - resource != "TOTAL", - resource), - list("expColumn", - !is.null(exp_column), - exp_column)) + call_query <- .rba_query( + init = list(), + list("quality", image_quality != 5, image_quality), + list("flg", !is.null(flag_element), flag_element), + list("flgInteractors", !flg_interactors, "false"), + list("sel", !is.null(sel), sel), + list("title", !title, "false"), + list("margin", margin != 15, as.integer(margin)), + list("diagramProfile", diagram_profile != "Copper", diagram_profile), + list("analysisProfile", !is.null(analysis_profile), analysis_profile), + list("token", !is.null(token), token), + list("resource", resource != "TOTAL", resource), + list("expColumn", !is.null(exp_column), exp_column) + ) ## Build Function-Specific Call if (output_format == "svg") { @@ -1380,21 +1426,27 @@ rba_reactome_exporter_reaction <- function(event_id, } # create file_path - save_to <- .rba_file(file = paste0(event_id, ".", output_format), - save_to = ifelse(is.null(save_to) || is.na(save_to), - yes = TRUE, - no = save_to)) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sexporter/reaction/%s.%s", - .rba_stg("reactome", "pth", "content"), - event_id, - output_format), - query = call_query, - accpet = accept_input, - save_to = save_to, - parser = NULL) + save_to <- .rba_file( + file = paste0(event_id, ".", output_format), + save_to = ifelse( + is.null(save_to) || is.na(save_to), + yes = TRUE, + no = save_to + ) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sexporter/reaction/%s.%s", + .rba_stg("reactome", "pth", "content"), event_id, output_format + ), + query = call_query, + accpet = accept_input, + save_to = save_to, + parser = NULL) + ## Call API invisible(.rba_skeleton(input_call)) } @@ -1474,47 +1526,70 @@ rba_reactome_interactors_psicquic <- function(proteins = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "proteins", - class = c("character", - "numeric"), - max_len = 1000), - list(arg = "resource", - class = "character"), - list(arg = "details", - class = "logical")), - cond = list(list(quote(sum(!is.null(proteins), !is.null(resource))), - "You should supply 'proteins' and 'resource' togeather."))) + .rba_args( + cons = list( + list(arg = "proteins", class = c("character", "numeric"), max_len = 1000), + list(arg = "resource", class = "character"), + list(arg = "details", class = "logical") + ), + cond = list( + list( + quote(sum(!is.null(proteins), !is.null(resource))), + "You should supply 'proteins' and 'resource' togeather." + ) + ) + ) + if (!is.null(proteins)) { + details <- ifelse(isTRUE(details), yes = "details", no = "summary") - .msg("Retrieving %s of clustered interactions of %s ptoteins(s) from %s.", - details, - ifelse(length(proteins) == 1, - yes = proteins, no = length(proteins)), - resource) + + .msg( + "Retrieving %s of clustered interactions of %s ptoteins(s) from %s.", + details, + ifelse(length(proteins) == 1, yes = proteins, no = length(proteins)), + resource + ) + ## Build POST API Request's URL call_body <- paste(unique(proteins),collapse = "\n") - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = sprintf("%sinteractors/psicquic/molecules/%s/%s", - .rba_stg("reactome", "pth", "content"), - resource, details), - body = call_body, - accept = "application/json", - httr::content_type("text/plain"), - parser = "json->list", - save_to = .rba_file("reactome_interactors_psicquic.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sinteractors/psicquic/molecules/%s/%s", + .rba_stg("reactome", "pth", "content"), resource, details + ), + body = call_body, + accept = "application/json", + httr::content_type("text/plain"), + parser = "json->list", + save_to = .rba_file("reactome_interactors_psicquic.json") + ) + } else { - .msg("Retrieving a table of all Psicquic Registries services.") + + .msg( + "Retrieving a table of all Psicquic Registries services." + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "/interactors/psicquic/resources"), - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_interactors_psicquic.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "/interactors/psicquic/resources" + ), + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_interactors_psicquic.json") + ) + } + ## Call API final_output <- .rba_skeleton(input_call) @@ -1604,63 +1679,93 @@ rba_reactome_interactors_static <- function(proteins, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "proteins", - class = c("character", - "numeric"), - max_len = 1000), - list(arg = "endpoint", - class = "character", - val = c("details", - "summary", - "pathways")), - list(arg = "only_diagrammed", - class = "logical"), - list(arg = "species", - class = "character")), - cond = list(list(quote(endpoint == "pathways" && length(proteins) != 1), - "When 'endpoint = pathways', you can only supply one protein."), - list(quote(sum(!is.null(species), endpoint == "pathways") == 1), - "You should -and can only- supply species when endpoint is 'pathways'."))) + .rba_args( + cons = list( + list(arg = "proteins", class = c("character", "numeric"), max_len = 1000), + list( + arg = "endpoint", class = "character", + val = c("details", + "summary", + "pathways") + ), + list(arg = "only_diagrammed", class = "logical"), + list(arg = "species", class = "character") + ), + cond = list( + list( + quote(endpoint == "pathways" && length(proteins) != 1), + "When 'endpoint = pathways', you can only supply one protein." + ), + list( + quote(sum(!is.null(species), endpoint == "pathways") == 1), + "You should -and can only- supply species when endpoint is 'pathways'." + ) + ) + ) + if (endpoint == "pathways") { + .msg( + "Retrieving pathways with the Static(IntAct) Interactors of protein %s.", + proteins + ) + + call_query <- .rba_query( + init = list( + "onlyDiagrammed" = ifelse( + isTRUE(only_diagrammed), yes = "true", no = "false" + ) + ), + list("species", !is.null(species), species) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sinteractors/static/molecule/%s/pathways", + .rba_stg("reactome", "pth", "content"), proteins + ), + query = call_query, + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_interactors_static.json") + ) - if (endpoint == "pathways") { - .msg("Retrieving pathways with the Static(IntAct) Interactors of protein %s.", - proteins) - call_query <- .rba_query(init = list("onlyDiagrammed" = ifelse(isTRUE(only_diagrammed), - yes = "true", - no = "false")), - list("species", - !is.null(species), - species)) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sinteractors/static/molecule/%s/pathways", - .rba_stg("reactome", "pth", "content"), - proteins), - query = call_query, - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_interactors_static.json")) } else { + ## Build POST API Request's URL - .msg("Retrieving %s of Static(IntAct) Interactors of protein %s.", - endpoint, proteins) + .msg( + "Retrieving %s of Static(IntAct) Interactors of protein %s.", + endpoint, proteins + ) + call_body <- paste(unique(proteins),collapse = "\n") + ## Build Function-Specific Call - parser_input <- ifelse(endpoint == "details", - yes = "json->list", no = "json->list_simp") - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "interactors/static/molecules/", - endpoint), - body = call_body, - accept = "application/json", - httr::content_type("text/plain"), - parser = parser_input, - save_to = .rba_file("reactome_interactors_static.json")) + parser_input <- ifelse( + endpoint == "details", + yes = "json->list", + no = "json->list_simp" + ) + + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "interactors/static/molecules/", + endpoint + ), + body = call_body, + accept = "application/json", + httr::content_type("text/plain"), + parser = parser_input, + save_to = .rba_file("reactome_interactors_static.json") + ) + } ## Call API @@ -1733,39 +1838,42 @@ rba_reactome_mapping <- function(id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "id", - class = c("character", - "numeric")), - list(arg = "resource", - class = "character"), - list(arg = "species", - class = c("character", - "numeric")), - list(arg = "map_to", - class = "character", - val = c("pathways", - "reactions")))) - - .msg("Retrieving Reactome %s that contain %s from %s resource.", - map_to, id, resource) + .rba_args( + cons = list( + list(arg = "id", class = c("character", "numeric")), + list(arg = "resource", class = "character"), + list(arg = "species", class = c("character", "numeric")), + list(arg = "map_to", class = "character", val = c("pathways", "reactions")) + ) + ) + + .msg( + "Retrieving Reactome %s that contain %s from %s resource.", + map_to, id, resource + ) + ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("species", - !is.null(species), - species)) + call_query <- .rba_query( + init = list(), + list("species", !is.null(species), species) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = sprintf("%sdata/mapping/%s/%s/%s", - .rba_stg("reactome", "pth", "content"), - resource, - id, - map_to), - query = call_query, - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_mapping.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = sprintf( + "%sdata/mapping/%s/%s/%s", + .rba_stg("reactome", "pth", "content"), + resource, id, map_to + ), + query = call_query, + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_mapping.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1838,31 +1946,43 @@ rba_reactome_orthology <- function(event_ids, ...) { ## Load Global Options .rba_ext_args(...) - ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_ids", - class = "character"), - list(arg = "species_dbid", - class = "numeric"))) - .msg("Retrieving orthologous Events of '%s' in the specie with DbId '%s'.", - ifelse(length(event_ids) == 1, - yes = event_ids, no = paste0(length(event_ids), " input events")), - species_dbid) + ## Check User-input Arguments + .rba_args( + cons = list( + list(arg = "event_ids", class = "character"), + list(arg = "species_dbid", class = "numeric") + ) + ) + + .msg( + "Retrieving orthologous Events of '%s' in the specie with DbId '%s'.", + ifelse( + length(event_ids) == 1, + yes = event_ids, + no = paste0(length(event_ids), " input events") + ), + species_dbid + ) ## Build POST API Request's URL call_body <- paste(unique(event_ids),collapse = "\n") ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "data/orthologies/ids/species/", - species_dbid), - body = call_body, - accept = "application/json", - httr::content_type("text/plain"), - parser = "json->list_simp", - save_to = .rba_file("reactome_orthology.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "data/orthologies/ids/species/", + species_dbid + ), + body = call_body, + accept = "application/json", + httr::content_type("text/plain"), + parser = "json->list_simp", + save_to = .rba_file("reactome_orthology.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1957,44 +2077,63 @@ rba_reactome_participants <- function(event_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_id", - class = c("character", - "numeric")), - list(arg = "only_physical_entities", - class = "logical"), - list(arg = "only_reference_entities", - class = "logical")), - cond = list(list(quote(sum(only_physical_entities, only_reference_entities) == 2), - "You can only set either only_reference_entities or only_reference_entities to TRUE in one function call."))) - - .msg("Retrieving %sParticipants of Reactome event %s.", - ifelse(sum(only_physical_entities, only_reference_entities) == 0, - yes = "", - no = c("'Physical Entities' ", - "'Reference Entities' ")[c(only_physical_entities, - only_reference_entities)]), - event_id) + .rba_args( + cons = list( + list(arg = "event_id", class = c("character", "numeric")), + list(arg = "only_physical_entities", class = "logical"), + list(arg = "only_reference_entities", class = "logical") + ), + cond = list( + list( + quote(sum(only_physical_entities, only_reference_entities) == 2), + "You can only set either only_reference_entities or only_reference_entities to TRUE in one function call." + ) + ) + ) + + .msg( + "Retrieving %sParticipants of Reactome event %s.", + ifelse( + sum(only_physical_entities, only_reference_entities) == 0, + yes = "", + no = c("'Physical Entities' ", + "'Reference Entities' ")[c(only_physical_entities, + only_reference_entities)] + ), + event_id + ) ## Build Function-Specific Call - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - "data/participants/", - event_id) + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + "data/participants/", + event_id + ) + parser_input <- "json->list" + if (isTRUE(only_physical_entities)) { + path_input <- paste0(path_input, "/participatingPhysicalEntities") parser_input <- "json->df" + } else if (isTRUE(only_reference_entities)) { + path_input <- paste0(path_input, "/referenceEntities") parser_input <- "json->df" + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("reactome_participants.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("reactome_participants.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -2070,49 +2209,63 @@ rba_reactome_pathways_events <- function(event_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "event_id", - class = c("numeric", - "character")), - list(arg = "attribute_name", - class = "character"))) - - .msg("Retrieving %s contained events under the event %s.", - ifelse(is.null(attribute_name), - yes = "all", - no = sprintf("attribute '%s' of all", - attribute_name)), - event_id) + .rba_args( + cons = list( + list(arg = "event_id", class = c("numeric", "character")), + list(arg = "attribute_name", class = "character") + ) + ) + + .msg( + "Retrieving %s contained events under the event %s.", + ifelse( + is.null(attribute_name), + yes = "all", + no = sprintf("attribute '%s' of all", attribute_name) + ), + event_id + ) ## Build Function-Specific Call - path_input <- sprintf("%sdata/pathway/%s/containedEvents", - .rba_stg("reactome", "pth", "content"), - event_id) + path_input <- sprintf( + "%sdata/pathway/%s/containedEvents", + .rba_stg("reactome", "pth", "content"), + event_id + ) accept_input <- "application/json" parser_input <- "json->df" file_ext <- "json" if (!is.null(attribute_name)) { + path_input <- paste0(path_input, "/", attribute_name) accept_input <- "text/plain" parser_input <- function(x) { - unlist(strsplit(x = gsub(pattern = "\\[|\\]", - replacement = "", - x = httr::content(x, - as = "text", - encoding = "UTF-8")), - split = ", ")) + unlist( + strsplit( + x = gsub( + pattern = "\\[|\\]", + replacement = "", + x = httr::content(x, as = "text", encoding = "UTF-8") + ), + split = ", " + ) + ) } file_ext <- "txt" + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accpet = accept_input, - parser = parser_input, - save_to = .rba_file(paste0("reactome_pathways_participants", - ".", file_ext))) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accpet = accept_input, + parser = parser_input, + save_to = .rba_file(paste0("reactome_pathways_participants", ".", file_ext)) + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -2192,40 +2345,43 @@ rba_reactome_pathways_low <- function(entity_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "entity_id", - class = "character"), - list(arg = "all_forms", - class = "logical"), - list(arg = "with_diagram", - class = "logical"), - list(arg = "species", - class = c("character", - "numeric")))) - - .msg("Retrieving lower-level pathways that include %sentity %s%s.", - ifelse(isTRUE(all_forms), - yes = "any form of ", no = ""), - entity_id, - ifelse(isTRUE(with_diagram), - yes = " and have diagram", no = "")) + .rba_args( + cons = list( + list(arg = "entity_id", class = "character"), + list(arg = "all_forms", class = "logical"), + list(arg = "with_diagram", class = "logical"), + list(arg = "species", class = c("character", "numeric")) + ) + ) + + .msg( + "Retrieving lower-level pathways that include %sentity %s%s.", + ifelse(isTRUE(all_forms), yes = "any form of ", no = ""), + entity_id, + ifelse(isTRUE(with_diagram), yes = " and have diagram", no = "") + ) + ## Build Function-Specific Call - path_input <- sprintf("%sdata/pathways/%s/%s", - .rba_stg("reactome", "pth", "content"), - ifelse(isTRUE(with_diagram), - yes = "low/diagram/entity", - no = "low/entity"), - entity_id) + path_input <- sprintf( + "%sdata/pathways/%s/%s", + .rba_stg("reactome", "pth", "content"), + ifelse(isTRUE(with_diagram), yes = "low/diagram/entity", no = "low/entity"), + entity_id) + if (isTRUE(all_forms)) { - path_input <- paste0(path_input, - "/allForms") + path_input <- paste0(path_input, "/allForms") } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_pathways_low.json")) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_pathways_low.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -2292,27 +2448,39 @@ rba_reactome_pathways_top <- function(species, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "species", - class = c("character", - "numeric")))) + .rba_args( + cons = list( + list(arg = "species", class = c("character", "numeric")) + ) + ) + + .msg( + "Retrieving all Reactome top level pathways of species %s.", + species + ) - .msg("Retrieving all Reactome top level pathways of species %s.", species) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("species", - !is.null(species), - species)) + call_query <- .rba_query( + init = list(), + list("species", !is.null(species), species) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "data/pathways/top/", - species), - query = call_query, - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_pathways_top.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "data/pathways/top/", + species + ), + query = call_query, + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_pathways_top.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -2374,27 +2542,39 @@ rba_reactome_people_name <- function(person_name, ...) { ## Load Global Options .rba_ext_args(...) - ## Check User-input Arguments - .rba_args(cons = list(list(arg = "person_name", - class = "character"), - list(arg = "exact_match", - class = "logical"))) - .msg("Retreving the information of %s.", person_name) + ## Check User-input Arguments + .rba_args( + cons = list( + list(arg = "person_name", class = "character"), + list(arg = "exact_match", class = "logical") + ) + ) + + .msg( + "Retreving the information of %s.", + person_name + ) ## Build Function-Specific Call - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - "data/people/name/", - gsub(" ", "%20", person_name)) + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + "data/people/name/", + gsub(" ", "%20", person_name) + ) + if (isTRUE(exact_match)) { path_input <- paste0(path_input, "/exact") } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("reactome_people_name.json")) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("reactome_people_name.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -2457,48 +2637,65 @@ rba_reactome_people_id <- function(person_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "person_id", - class = "character"), - list(arg = "authored_pathways", - class = "logical"), - list(arg = "publications", - class = "logical"), - list(arg = "attribute_name", - class = "character")), - cond = list(list(quote(sum(!is.null(attribute_name), - isTRUE(authored_pathways), - isTRUE(publications)) > 1), - "You can only use either attribute_name, authored_pathways or publications function call."))) - - .msg("Retrieving information of person with id %s.", - person_id) + .rba_args( + cons = list( + list(arg = "person_id", class = "character"), + list(arg = "authored_pathways", class = "logical"), + list(arg = "publications", class = "logical"), + list(arg = "attribute_name", class = "character") + ), + cond = list( + list( + quote(sum(!is.null(attribute_name), isTRUE(authored_pathways), isTRUE(publications)) > 1), + "You can only use either attribute_name, authored_pathways or publications function call." + ) + ) + ) + + .msg( + "Retrieving information of person with id %s.", + person_id + ) ## Build Function-Specific Call - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - "data/person/", - person_id) + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + "data/person/", + person_id + ) + accept_input <- "application/json" parser_type_input <- "json->list" file_ext <- "json" + if (isTRUE(authored_pathways)) { + path_input <- paste0(path_input, "/authoredPathways") + } else if (isTRUE(publications)) { + path_input <- paste0(path_input, "/publications") + } else if (!is.null(attribute_name)) { + path_input <- paste0(path_input, "/", attribute_name) accept_input <- "text/plain" parser_type_input <- "text->chr" file_ext <- "txt" + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - accpet = accept_input, - parser = parser_type_input, - save_to = .rba_file(paste0("reactome_people_id", - ".", - file_ext))) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + accpet = accept_input, + parser = parser_type_input, + save_to = .rba_file(paste0("reactome_people_id", ".", file_ext)) + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -2575,67 +2772,87 @@ rba_reactome_query <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", - "numeric"), - max_len = 20), - list(arg = "enhanced", - class = "logical"), - list(arg = "map", - class = "logical"), - list(arg = "attribute_name", - class = "character")), - cond = list(list(quote(length(ids) > 1 && - (isTRUE(enhanced) | !is.null(attribute_name))), - "You can only use 'enhnaced' or 'attribute_name' with a single ID not multiple IDs."), - list(quote(!is.null(attribute_name) && isTRUE(enhanced)), - "You can only supply 'attribute_name' when enhanced is 'FALSE'."))) - - .msg("Querying Reactome knowledgebase with the supplied ID(s)") + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric"), max_len = 20), + list(arg = "enhanced", class = "logical"), + list(arg = "map", class = "logical"), + list(arg = "attribute_name", class = "character") + ), + cond = list( + list( + quote(length(ids) > 1 && (isTRUE(enhanced) | !is.null(attribute_name))), + "You can only use 'enhnaced' or 'attribute_name' with a single ID not multiple IDs." + ), + list( + quote(!is.null(attribute_name) && isTRUE(enhanced)), + "You can only supply 'attribute_name' when enhanced is 'FALSE'." + ) + ) + ) + + .msg( + "Querying Reactome knowledgebase with the supplied ID(s)" + ) if (length(ids) > 1) { + #### use POST ## Build POST API Request's URL call_body <- paste(unique(ids),collapse = ",") - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - ifelse(isTRUE(map), - yes = "data/query/ids/map", - no = "data/query/ids")) + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + ifelse(isTRUE(map), yes = "data/query/ids/map", no = "data/query/ids") + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("reactome", "url"), - path = path_input, - body = call_body, - parser = "json->list", - accept = "application/json", - httr::content_type("text/plain"), - save_to = .rba_file("reactome_query.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("reactome", "url"), + path = path_input, + body = call_body, + parser = "json->list", + accept = "application/json", + httr::content_type("text/plain"), + save_to = .rba_file("reactome_query.json") + ) + } else { + #### use GET ## Build Function-Specific Call - path_input <- paste0(.rba_stg("reactome", "pth", "content"), - "data/query/", - ids) + path_input <- paste0( + .rba_stg("reactome", "pth", "content"), + "data/query/", + ids + ) accept_input <- "application/json" parser_input <- "json->list" file_ext <- "json" + if (!is.null(attribute_name)) { + path_input <- paste0(path_input, "/", attribute_name) accept_input <- "text/plain" parser_input <- "text->chr" file_ext <- "txt" + } else if (isTRUE(enhanced)) { + path_input <- sub("/query/", "/query/enhanced/", path_input) + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = path_input, - parser = parser_input, - accept = accept_input, - save_to = .rba_file(paste0("reactome_query.", - file_ext))) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = path_input, + parser = parser_input, + accept = accept_input, + save_to = .rba_file(paste0("reactome_query.", file_ext)) + ) } ## Call API @@ -2702,23 +2919,32 @@ rba_reactome_xref <- function(xref_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "xref_id", - class = c("character", - "numeric")))) + .rba_args( + cons = list( + list(arg = "xref_id", class = c("character", "numeric")) + ) + ) - .msg("Retrieving Reactome's ReferenceEntity that have a cross-reference to %s.", - xref_id) + .msg( + "Retrieving Reactome's ReferenceEntity that have a cross-reference to %s.", + xref_id + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "references/mapping/", - xref_id), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("reactome_xref.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "references/mapping/", + xref_id + ), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("reactome_xref.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -2777,25 +3003,32 @@ rba_reactome_species <- function(only_main = FALSE, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "only_main", - class = "logical"))) + .rba_args( + cons = list( + list(arg = "only_main", class = "logical") + ) + ) - .msg("Retrieving %sspecies available in Reactome.", - ifelse(isTRUE(only_main), - yes = "main (i.e. with pathways) ", - no = "")) + .msg( + "Retrieving %sspecies available in Reactome.", + ifelse(isTRUE(only_main), yes = "main (i.e. with pathways) ", no = "") + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("reactome", "url"), - path = paste0(.rba_stg("reactome", "pth", "content"), - "data/species/", - ifelse(isTRUE(only_main), - yes = "main", no = "all")), - accept = "application/json", - parser = "json->df", - save_to = .rba_file("reactome_species.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("reactome", "url"), + path = paste0( + .rba_stg("reactome", "pth", "content"), + "data/species/", + ifelse(isTRUE(only_main), yes = "main", no = "all") + ), + accept = "application/json", + parser = "json->df", + save_to = .rba_file("reactome_species.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/stringdb.R b/R/stringdb.R index da499666..948f9522 100644 --- a/R/stringdb.R +++ b/R/stringdb.R @@ -51,45 +51,53 @@ rba_string_map_ids <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "echo_query", - class = "logical"), - list(arg = "limit", - class = "numeric")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - .msg("Mapping %s Input Identifiers to STRING Identifiers.", length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "echo_query", class = "logical"), + list(arg = "limit", class = "numeric") + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Mapping %s Input Identifiers to STRING Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("echo_query", - echo_query, - "1"), - list("limit", - !is.null(limit), - limit)) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species),species), + list("echo_query", echo_query, "1"), + list("limit", !is.null(limit), limit) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/resolve"), - body = call_body, - encode = "form", - accept = "application/json", - parser = "json->df", - save_to = .rba_file("string_map_ids.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/resolve"), + body = call_body, + encode = "form", + accept = "application/json", + parser = "json->df", + save_to = .rba_file("string_map_ids.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -216,123 +224,101 @@ rba_string_network_image <- function(ids, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "image_format", - class = "character", - val = c("image", "highres_image", "svg")), - list(arg = "save_image", - class = c("character", - "logical")), - list(arg = "add_color_nodes", - class = "numeric"), - list(arg = "add_white_nodes", - class = "numeric"), - list(arg = "required_score", - class = "numeric", - min_val = 0, - max_val = 1000), - list(arg = "network_flavor", - class = "character", - val = c("evidence", "confidence", "actions")), - list(arg = "network_type", - class = "character", - val = c("functional", "physical")), - list(arg = "hide_node_labels", - class = "logical"), - list(arg = "use_query_labels", - class = "logical"), - list(arg = "hide_disconnected_nodes", - class = "logical"), - list(arg = "hide_structure_pics", - class = "logical"), - list(arg = "flat_nodes", - class = "logical"), - list(arg = "node_labels_center", - class = "logical"), - list(arg = "node_labels_font_size", - class = "numeric", - min_val = 5, - max_val = 50)), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Retrieving STRING network image of %s Input Identifiers.", length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list( + arg = "image_format", class = "character", + val = c("image", "highres_image", "svg") + ), + list(arg = "save_image", class = c("character", "logical")), + list(arg = "add_color_nodes", class = "numeric"), + list(arg = "add_white_nodes", class = "numeric"), + list(arg = "required_score", class = "numeric", min_val = 0, max_val = 1000), + list( + arg = "network_flavor", class = "character", + val = c("evidence", "confidence", "actions") + ), + list(arg = "network_type", class = "character", val = c("functional", "physical")), + list(arg = "hide_node_labels", class = "logical"), + list(arg = "use_query_labels", class = "logical"), + list(arg = "hide_disconnected_nodes", class = "logical"), + list(arg = "hide_structure_pics", class = "logical"), + list(arg = "flat_nodes", class = "logical"), + list(arg = "node_labels_center", class = "logical"), + list(arg = "node_labels_font_size", class = "numeric", min_val = 5, max_val = 50) + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving STRING network image of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("add_color_nodes", - !is.null(add_color_nodes), - add_color_nodes), - list("add_white_nodes", - !is.null(add_white_nodes), - add_white_nodes), - list("required_score", - !is.null(required_score), - required_score), - list("network_flavor", - !is.null(network_flavor), - network_flavor), - list("network_type", - !is.null(network_type), - network_type), - list("hide_node_labels", - hide_node_labels, - "1"), - list("show_query_node_labels", - use_query_labels, - "1"), - list("hide_disconnected_nodes", - hide_disconnected_nodes, - "1"), - list("block_structure_pics_in_bubbles", - hide_structure_pics, - "1"), - list("flat_node_design", - flat_nodes, - "1"), - list("flat_node_design", - flat_nodes, - "1"), - list("center_node_labels", - node_labels_center, - "1"), - list("custom_label_font_size", - node_labels_font_size != 12, - node_labels_font_size)) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("add_color_nodes", !is.null(add_color_nodes), add_color_nodes), + list("add_white_nodes", !is.null(add_white_nodes), add_white_nodes), + list("required_score", !is.null(required_score), required_score), + list("network_flavor", !is.null(network_flavor), network_flavor), + list("network_type", !is.null(network_type), network_type), + list("hide_node_labels", hide_node_labels, "1"), + list("show_query_node_labels", use_query_labels, "1"), + list("hide_disconnected_nodes", hide_disconnected_nodes, "1"), + list("block_structure_pics_in_bubbles", hide_structure_pics, "1"), + list("flat_node_design", flat_nodes, "1"), + list("flat_node_design", flat_nodes, "1"), + list("center_node_labels", node_labels_center, "1"), + list("custom_label_font_size", node_labels_font_size != 12, node_labels_font_size) + ) ## make file path if (image_format == "svg") { + ext_input <- "svg" accept_input <- "image/svg+xml" - parser_input <- function(x) {httr::content(x)} + parser_input <- function(x) { httr::content(x) } + } else { + ext_input <- "png" accept_input <- "image/png" - parser_input <- function(x) {httr::content(x, type = "image/png")} + parser_input <- function(x) { httr::content(x, type = "image/png") } + } - save_image <- .rba_file(file = paste0("string_network_image.", ext_input), - save_to = save_image) + + save_image <- .rba_file( + file = paste0("string_network_image.", ext_input), + save_to = save_image + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "image/network"), - accept = accept_input, - parser = parser_input, - body = call_body, - save_to = save_image) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "image/network"), + accept = accept_input, + parser = parser_input, + body = call_body, + save_to = save_image + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -440,61 +426,56 @@ rba_string_interactions_network <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "required_score", - class = "numeric", - min_val = 0, - max_val = 1000), - list(arg = "add_nodes", - class = "numeric", - min_val = 0), - list(arg = "network_type", - class = "character", - val = c("functional", "physical")), - list(arg = "use_query_labels", - class = "logical")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Retrieving STRING Network interaction of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "required_score", class = "numeric", min_val = 0, max_val = 1000), + list(arg = "add_nodes", class = "numeric", min_val = 0), + list(arg = "network_type", class = "character", val = c("functional", "physical")), + list(arg = "use_query_labels", class = "logical")), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving STRING Network interaction of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("required_score", - !is.null(required_score), - required_score), - list("add_nodes", - !is.null(add_nodes), - add_nodes), - list("network_type", - !is.null(network_type), - network_type), - list("show_query_node_labels", - use_query_labels, - "1")) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("required_score", !is.null(required_score), required_score), + list("add_nodes", !is.null(add_nodes), add_nodes), + list("network_type", !is.null(network_type), network_type), + list("show_query_node_labels", use_query_labels, "1") + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/network"), - body = call_body, - encode = "form", - accept = "application/json", - parser = "json->df", - save_to = .rba_file("rba_string_interactions_network.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/network"), + body = call_body, + encode = "form", + accept = "application/json", + parser = "json->df", + save_to = .rba_file("rba_string_interactions_network.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -578,56 +559,55 @@ rba_string_interaction_partners <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "required_score", - class = "numeric", - min_val = 0, - max_val = 1000), - list(arg = "network_type", - class = "character", - val = c("functional", "physical")), - list(arg = "limit", - class = "numeric", - min_val = 1)), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Retrieving Interacting partners of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "required_score", class = "numeric", min_val = 0, max_val = 1000), + list(arg = "network_type", class = "character", val = c("functional", "physical")), + list(arg = "limit", class = "numeric", min_val = 1) + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving Interacting partners of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("limit", - !is.null(limit), - limit), - list("required_score", - !is.null(required_score), - required_score), - list("network_type", - !is.null(network_type), - network_type)) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("limit", !is.null(limit), limit), + list("required_score", !is.null(required_score), required_score), + list("network_type", !is.null(network_type), network_type) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "/json/interaction_partners"), - body = call_body, - encode = "form", - accept = "application/json", - parser = "json->df", - save_to = .rba_file("string_interaction_partners.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "/json/interaction_partners"), + body = call_body, + encode = "form", + accept = "application/json", + parser = "json->df", + save_to = .rba_file("string_interaction_partners.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -693,37 +673,49 @@ rba_string_homology_intra <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Retrieving similarity scores of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric") + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving similarity scores of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species)) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/homology"), - body = call_body, - encode = "form", - accept = "application/json", - parser = "json->df", - save_to = .rba_file("string_homology.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/homology"), + body = call_body, + encode = "form", + accept = "application/json", + parser = "json->df", + save_to = .rba_file("string_homology.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -798,41 +790,51 @@ rba_string_homology_inter <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "species_b", - class = "numeric")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - .msg("Retrieving Best similarity scores hits of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "species_b", class = "numeric") + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving Best similarity scores hits of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("species_b", - !is.null(species_b), - paste(unique(species_b),collapse = "%0d"))) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("species_b", !is.null(species_b), paste(unique(species_b),collapse = "%0d")) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/homology_best"), - body = call_body, - encode = "form", - accept = "application/json", - parser = "json->df", - save_to = .rba_file("string_homology_best.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/homology_best"), + body = call_body, + encode = "form", + accept = "application/json", + parser = "json->df", + save_to = .rba_file("string_homology_best.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -916,57 +918,63 @@ rba_string_enrichment <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "background", - class = "character"), - list(arg = "split_df", - class = "logical")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - .msg("Performing functional enrichment of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "background", class = "character"), + list(arg = "split_df", class = "logical") + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Performing functional enrichment of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("background_string_identifiers", - !is.null(background), - paste(unique(background), - collapse = "%0d"))) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("background_string_identifiers", !is.null(background), paste(unique(background), collapse = "%0d")) + ) ## Build Function-Specific Call if (isTRUE(split_df)) { - parser_input <- list("json->df", - function(x) { - if (utils::hasName(x, "category")) { - split(x, x$category) - } else { - x - } - }) + parser_input <- list( + "json->df", + function(x) { + if (utils::hasName(x, "category")) { split(x, x$category) } else { x } + } + ) } else { parser_input <- "json->df" } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/enrichment"), - body = call_body, - encode = "form", - accept = "application/json", - parser = parser_input, - save_to = .rba_file("string_enrichment.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/enrichment"), + body = call_body, + encode = "form", + accept = "application/json", + parser = parser_input, + save_to = .rba_file("string_enrichment.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1043,51 +1051,61 @@ rba_string_annotations <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "allow_pubmed", - class = "logical"), - list(arg = "split_df", - class = "logical")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Retrieving functional annotations of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "allow_pubmed", class = "logical"), + list(arg = "split_df", class = "logical") + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving functional annotations of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("allow_pubmed", - allow_pubmed, - 1)) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("allow_pubmed", allow_pubmed, 1) + ) ## Build Function-Specific Call if (isTRUE(split_df)) { - parser_input <- list("json->df", - function(x) { split(x, x$category) }) + parser_input <- list( + "json->df", + function(x) { split(x, x$category) } + ) } else { parser_input <- "json->df" } - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/functional_annotation"), - body = call_body, - encode = "form", - accept = "application/json", - parser = parser_input, - save_to = .rba_file("string_functional_annotation.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/functional_annotation"), + body = call_body, + encode = "form", + accept = "application/json", + parser = parser_input, + save_to = .rba_file("string_functional_annotation.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1153,50 +1171,54 @@ rba_string_enrichment_ppi <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "required_score", - class = "numeric", - min_val = 0, - max_val = 1000), - list(arg = "background", - class = "character")), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Performing PPI Enrichment of %s Input Identifiers.", - length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list(arg = "required_score", class = "numeric", min_val = 0, max_val = 1000), + list(arg = "background", class = "character") + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Performing PPI Enrichment of %s Input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "caller_identity" = getOption("rba_user_agent")), - list("species", - !is.null(species), - species), - list("required_score", - !is.null(required_score), - required_score), - list("background_string_identifiers", - !is.null(background), - paste(unique(background), - collapse = "%0d"))) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "caller_identity" = getOption("rba_user_agent") + ), + list("species", !is.null(species), species), + list("required_score", !is.null(required_score), required_score), + list("background_string_identifiers", !is.null(background), paste(unique(background), collapse = "%0d")) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/ppi_enrichment"), - body = call_body, - encode = "form", - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("string_ppi_enrichment.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/ppi_enrichment"), + body = call_body, + encode = "form", + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("string_ppi_enrichment.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -1244,23 +1266,28 @@ rba_string_enrichment_ppi <- function(ids, rba_string_version <- function(...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments .rba_args() - .msg("Retrieving the STRING database version and address used by rbioapi.") + + .msg( + "Retrieving the STRING database version and address used by rbioapi." + ) ## Build POST API Request's body call_query <- list("format" = "text") ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - "json/version"), - body = call_query, - encode = "form", - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("string_version.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), "json/version"), + body = call_query, + encode = "form", + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("string_version.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1398,86 +1425,96 @@ rba_string_enrichment_image <- function(ids, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = c("character", "numeric")), - list(arg = "species", - class = "numeric"), - list(arg = "category", - class = "character", - val = c("Process", "Function", "Component", - "Keyword", "KEGG", "RCTM", - "HPO", "MPO", "DPO", "WPO", "ZPO", "FYPO", - "Pfam", "SMART", "InterPro", - "PMID", "NetworkNeighborAL", - "COMPARTMENTS", "TISSUES", "DISEASES", - "WikiPathways")), - list(arg = "image_format", - class = "character", - val = c("image", "highres_image", "svg")), - list(arg = "save_image", - class = c("character", - "logical")), - list(arg = "group_by_similarity", - class = "numeric", - val = seq(0.1, 1, by = 0.1)), - list(arg = "color_palette", - class = "character", - val = c("mint_blue", "lime_emerald", "green_blue", - "peach_purple", "straw_navy", "yellow_pink")), - list(arg = "number_of_term_shown", - class = "numeric", - min_val = 1), - list(arg = "x_axis", - class = "character", - val = c("signal", "strength", "FDR", "gene_count"))), - cond = list(list(quote(length(ids) > 100 && is.null(species)), - sprintf("You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", - length(ids))) - )) - - .msg("Retrieving STRING enrichment plot of %s input Identifiers.", length(ids)) + .rba_args( + cons = list( + list(arg = "ids", class = c("character", "numeric")), + list(arg = "species", class = "numeric"), + list( + arg = "category", class = "character", + val = c("Process", "Function", "Component", + "Keyword", "KEGG", "RCTM", + "HPO", "MPO", "DPO", "WPO", "ZPO", "FYPO", + "Pfam", "SMART", "InterPro", + "PMID", "NetworkNeighborAL", + "COMPARTMENTS", "TISSUES", "DISEASES", + "WikiPathways") + ), + list( + arg = "image_format", class = "character", + val = c("image", "highres_image", "svg") + ), + list(arg = "save_image", class = c("character", "logical")), + list(arg = "group_by_similarity", class = "numeric", val = seq(0.1, 1, by = 0.1)), + list( + arg = "color_palette", class = "character", + val = c("mint_blue", "lime_emerald", "green_blue", "peach_purple", "straw_navy", "yellow_pink") + ), + list(arg = "number_of_term_shown", class = "numeric", min_val = 1), + list( + arg = "x_axis", class = "character", val = c("signal", "strength", "FDR", "gene_count") + ) + ), + cond = list( + list( + quote(length(ids) > 100 && is.null(species)), + sprintf( + "You supplied %s IDs. Please Specify the species (Homo Sapiens NCBI taxonomy ID is 9606).", + length(ids) + ) + ) + ) + ) + + .msg( + "Retrieving STRING enrichment plot of %s input Identifiers.", + length(ids) + ) ## Build POST API Request's body - call_body <- .rba_query(init = list("identifiers" = paste(unique(ids), - collapse = "%0d"), - "species" = species, - "category" = category, - "color_palette" = color_palette, - "caller_identity" = getOption("rba_user_agent")), - list("group_by_similarity", - !is.null(group_by_similarity), - group_by_similarity), - list("number_of_term_shown", - number_of_term_shown != 10, - as.integer(number_of_term_shown)), - list("x_axis", - x_axis != "signal", - x_axis)) + call_body <- .rba_query( + init = list( + "identifiers" = paste(unique(ids), collapse = "%0d"), + "species" = species, + "category" = category, + "color_palette" = color_palette, + "caller_identity" = getOption("rba_user_agent") + ), + list("group_by_similarity", !is.null(group_by_similarity), group_by_similarity), + list("number_of_term_shown", number_of_term_shown != 10, as.integer(number_of_term_shown)), + list("x_axis", x_axis != "signal", x_axis) + ) ## make file path if (image_format == "svg") { + ext_input <- "svg" accept_input <- "image/svg+xml" - parser_input <- function(x) {httr::content(x)} + parser_input <- function(x) { httr::content(x) } + } else { + ext_input <- "png" accept_input <- "image/png" - parser_input <- function(x) {httr::content(x, type = "image/png")} + parser_input <- function(x) { httr::content(x, type = "image/png") } + } - save_image <- .rba_file(file = paste0("string_network_image.", ext_input), - save_to = save_image) + + save_image <- .rba_file( + file = paste0("string_network_image.", ext_input), + save_to = save_image + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("string", "url"), - path = paste0(.rba_stg("string", "pth"), - image_format, - "/enrichmentfigure"), - accept = accept_input, - parser = parser_input, - body = call_body, - save_to = save_image) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("string", "url"), + path = paste0(.rba_stg("string", "pth"), image_format, "/enrichmentfigure"), + accept = accept_input, + parser = parser_input, + body = call_body, + save_to = save_image) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/uniprot_coordinates.R b/R/uniprot_coordinates.R index 18bc1387..99780a10 100644 --- a/R/uniprot_coordinates.R +++ b/R/uniprot_coordinates.R @@ -70,69 +70,48 @@ rba_uniprot_coordinates_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "chromosome", - class = c("character", - "numeric"), - max_len = 20), - list(arg = "ensembl_id", - class = "character", - max_len = 20), - list(arg = "gene", - class = "character", - max_len = 20), - list(arg = "protein", - class = "character"), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "location", - class = "character"))) - - .msg("Searching UniProt and retrieving Coordinates of proteins that match your supplied inputs.") + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "chromosome", class = c("character", "numeric"), max_len = 20), + list(arg = "ensembl_id", class = "character", max_len = 20), + list(arg = "gene", class = "character", max_len = 20), + list(arg = "protein", class = "character"), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "location", class = "character") + ) + ) + + .msg( + "Searching UniProt and retrieving Coordinates of proteins that match your supplied inputs." + ) + ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("chromosome", - !is.null(chromosome), - paste0(chromosome, - collapse = ",")), - list("ensembl_id", - !is.null(ensembl_id), - paste0(ensembl_id, - collapse = ",")), - list("gene", - !is.null(gene), - paste0(gene, - collapse = ",")), - list("protein", - !is.null(protein), - protein), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("location", - !is.null(location), - location)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("chromosome", !is.null(chromosome), paste0(chromosome, collapse = ",")), + list("ensembl_id", !is.null(ensembl_id), paste0(ensembl_id, collapse = ",")), + list("gene", !is.null(gene), paste0(gene, collapse = ",")), + list("protein", !is.null(protein), protein), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("location", !is.null(location), location) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "coordinates"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_coordinates_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "coordinates"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_coordinates_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -201,40 +180,46 @@ rba_uniprot_coordinates_location_protein <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character"), - list(arg = "p_position", - class = "numeric"), - list(arg = "p_start", - class = "numeric"), - list(arg = "p_end", - class = "numeric")), - cond = list(list(quote(any(sum(!is.null(p_position), !is.null(p_start), !is.null(p_end)) == 3, - sum(!is.null(p_position), !is.null(p_start), !is.null(p_end)) == 0, - sum(!is.null(p_start), !is.null(p_end)) == 1)), - "You should supply either 'p_position' alone or 'p_start' and 'p_end' together.") - )) - - .msg("Retrieving genome coordinates of protein %s in sequence position %s.", - accession, - ifelse(is.null(p_position), - yes = paste(p_start, p_end, sep = " to "), no = p_position)) + .rba_args( + cons = list( + list(arg = "accession", class = "character"), + list(arg = "p_position", class = "numeric"), + list(arg = "p_start", class = "numeric"), + list(arg = "p_end", class = "numeric")), + cond = list( + list( + quote(any(sum(!is.null(p_position), !is.null(p_start), !is.null(p_end)) == 3, + sum(!is.null(p_position), !is.null(p_start), !is.null(p_end)) == 0, + sum(!is.null(p_start), !is.null(p_end)) == 1)), + "You should supply either 'p_position' alone or 'p_start' and 'p_end' together." + ) + ) + ) + + .msg( + "Retrieving genome coordinates of protein %s in sequence position %s.", + accession, + ifelse(is.null(p_position), yes = paste(p_start, p_end, sep = " to "), no = p_position) + ) ## Build Function-Specific Call - path_input <- sprintf("%scoordinates/location/%s:%s", - .rba_stg("uniprot", "pth"), - accession, - ifelse(!is.null(p_position), - yes = p_position, - no = paste0(p_start, "-", p_end))) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("uniprot_coordinates_location.json")) + path_input <- sprintf( + "%scoordinates/location/%s:%s", + .rba_stg("uniprot", "pth"), + accession, + ifelse(!is.null(p_position), yes = p_position, no = paste0(p_start, "-", p_end)) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("uniprot_coordinates_location.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -300,43 +285,55 @@ rba_uniprot_coordinates <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character"), - list(arg = "db_type", - class = "character", - val = c("Ensembl", - "CCDC", - "HGNC", - "RefSeq")), - list(arg = "db_id", - class = "character")), - cond = list(list(quote(any(sum(!is.null(accession), !is.null(db_type), !is.null(db_id)) == 3, - sum(!is.null(accession), !is.null(db_type), !is.null(db_id)) == 0, - sum(!is.null(db_type), !is.null(db_id)) == 1)), - "You should supply either 'accession' alone or 'db_type' and 'db_id' together.") - )) - - .msg("Retrieving genome coordinates of protein with ID: %s", - ifelse(is.null(accession), - yes = sprintf("%s in %s database", db_id, db_type), - no = accession)) + .rba_args( + cons = list( + list(arg = "accession", class = "character"), + list( + arg = "db_type", class = "character", + val = c("Ensembl", "CCDC", "HGNC", "RefSeq") + ), + list(arg = "db_id", class = "character") + ), + cond = list( + list( + quote(any(sum(!is.null(accession), !is.null(db_type), !is.null(db_id)) == 3, + sum(!is.null(accession), !is.null(db_type), !is.null(db_id)) == 0, + sum(!is.null(db_type), !is.null(db_id)) == 1)), + "You should supply either 'accession' alone or 'db_type' and 'db_id' together." + ) + ) + ) + + .msg( + "Retrieving genome coordinates of protein with ID: %s", + ifelse( + is.null(accession), + yes = sprintf("%s in %s database", db_id, db_type), + no = accession + ) + ) + ## Build GET API Request's query call_query <- list("size" = "-1") + ## Build Function-Specific Call - path_input <- sprintf("%scoordinates/%s", - .rba_stg("uniprot", "pth"), - ifelse(!is.null(accession), - yes = accession, - no = paste0(db_type, ":", db_id))) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_coordinates.json")) + path_input <- sprintf( + "%scoordinates/%s", + .rba_stg("uniprot", "pth"), + ifelse(!is.null(accession), yes = accession, no = paste0(db_type, ":", db_id)) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_coordinates.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -404,38 +401,49 @@ rba_uniprot_coordinates_location <- function(taxid, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "taxid", - class = "numeric"), - list(arg = "locations", - class = "character"), - list(arg = "in_range", - class = "logical"), - list(arg = "feature", - class = "logical")) + .rba_args( + cons = list( + list(arg = "taxid", class = "numeric"), + list(arg = "locations", class = "character"), + list(arg = "in_range", class = "logical"), + list(arg = "feature", class = "logical") + ) + ) + + .msg( + "Retrieving UniProt entries in location %s of taxon %s.", + locations, taxid ) - .msg("Retrieving UniProt entries in location %s of taxon %s.", - locations, taxid) ## Build GET API Request's query - call_query <- list("size" = "-1", - "in_range" = ifelse(in_range, "true", "false")) + call_query <- list( + "size" = "-1", + "in_range" = ifelse(in_range, "true", "false") + ) ## Build Function-Specific Call - path_input <- sprintf("%scoordinates/%s/%s", - .rba_stg("uniprot", "pth"), - taxid, - locations) + path_input <- sprintf( + "%scoordinates/%s/%s", + .rba_stg("uniprot", "pth"), + taxid, + locations + ) + if (isTRUE(feature)) { path_input <- paste0(path_input, "/feature") } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("rba_uniprot_coordinates_location.json")) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("rba_uniprot_coordinates_location.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -503,43 +511,56 @@ rba_uniprot_coordinates_location_genome <- function(taxid, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "taxid", - class = "numeric"), - list(arg = "chromosome", - class = c("numeric", - "character")), - list(arg = "g_position", - class = "numeric"), - list(arg = "g_start", - class = "numeric"), - list(arg = "g_end", - class = "numeric")), - cond = list(list(quote(any(sum(!is.null(g_position), !is.null(g_start), !is.null(g_end)) == 3, - sum(!is.null(g_position), !is.null(g_start), !is.null(g_end)) == 0, - sum(!is.null(g_start), !is.null(g_end)) == 1)), - "You should supply either 'g_position' alone or 'g_start' and 'g_end' together.") - )) - - .msg("Retrieving genome coordinates of proteins in taxon %s, Chromosome %s, Genome location %s.", - taxid, chromosome, - ifelse(is.null(g_position), - yes = paste(g_start, g_end, sep = " to "), no = g_position)) + .rba_args( + cons = list( + list(arg = "taxid", class = "numeric"), + list(arg = "chromosome", class = c("numeric", "character")), + list(arg = "g_position", class = "numeric"), + list(arg = "g_start", class = "numeric"), + list(arg = "g_end", class = "numeric") + ), + cond = list( + list( + quote(any(sum(!is.null(g_position), !is.null(g_start), !is.null(g_end)) == 3, + sum(!is.null(g_position), !is.null(g_start), !is.null(g_end)) == 0, + sum(!is.null(g_start), !is.null(g_end)) == 1)), + "You should supply either 'g_position' alone or 'g_start' and 'g_end' together." + ) + ) + ) + + .msg( + "Retrieving genome coordinates of proteins in taxon %s, Chromosome %s, Genome location %s.", + taxid, chromosome, + ifelse( + is.null(g_position), + yes = paste(g_start, g_end, sep = " to "), + no = g_position + ) + ) ## Build Function-Specific Call - path_input <- sprintf("%scoordinates/glocation/%s/%s:%s", - .rba_stg("uniprot", "pth"), - taxid, chromosome, - ifelse(!is.null(g_position), - yes = g_position, - no = paste0(g_start, "-", g_end))) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("uniprot_coordinates_glocation.json")) + path_input <- sprintf( + "%scoordinates/glocation/%s/%s:%s", + .rba_stg("uniprot", "pth"), + taxid, chromosome, + ifelse( + !is.null(g_position), + yes = g_position, + no = paste0(g_start, "-", g_end) + ) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("uniprot_coordinates_glocation.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/uniprot_proteins.R b/R/uniprot_proteins.R index 462ce8d7..45a88b83 100644 --- a/R/uniprot_proteins.R +++ b/R/uniprot_proteins.R @@ -146,109 +146,62 @@ rba_uniprot_proteins_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "reviewed", - class = "logical"), - list(arg = "isoform", - class = "numeric", - val = c(0, 1, 2)), - list(arg = "go_term", - class = "character"), - list(arg = "keyword", - class = "character"), - list(arg = "ec", - class = "character", - max_len = 20), - list(arg = "gene", - class = "character", - max_len = 20), - list(arg = "exact_gene", - class = "character", - max_len = 20), - list(arg = "protein", - class = "character"), - list(arg = "organism", - class = "character"), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "pubmed", - class = "character", - max_len = 20), - list(arg = "seq_length", - class = c("numeric", - "character")), - list(arg = "md5", - class = "character"))) - - .msg("Searching UniProt and retrieving proteins that match your supplied inputs.") + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "reviewed", class = "logical"), + list(arg = "isoform", class = "numeric", val = c(0, 1, 2)), + list(arg = "go_term", class = "character"), + list(arg = "keyword", class = "character"), + list(arg = "ec", class = "character", max_len = 20), + list(arg = "gene", class = "character", max_len = 20), + list(arg = "exact_gene", class = "character", max_len = 20), + list(arg = "protein", class = "character"), + list(arg = "organism", class = "character"), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "pubmed", class = "character", max_len = 20), + list(arg = "seq_length", class = c("numeric", "character")), + list(arg = "md5", class = "character") + ) + ) + + .msg( + "Searching UniProt and retrieving proteins that match your supplied inputs." + ) + ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("reviewed", - !is.null(reviewed), - ifelse(reviewed, - "true", - "false")), - list("isoform", - !is.null(isoform), - isoform), - list("goterms", - !is.null(go_term), - go_term), - list("keywords", - !is.null(keyword), - keyword), - list("ec", - !is.null(ec), - paste0(ec, - collapse = ",")), - list("gene", - !is.null(gene), - paste0(gene, - collapse = ",")), - list("exact_gene", - !is.null(exact_gene), - paste0(exact_gene, - collapse = ",")), - list("protein", - !is.null(protein), - protein), - list("organism", - !is.null(organism), - organism), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("pubmed", - !is.null(pubmed), - paste0(pubmed, - collapse = ",")), - list("seq_length", - !is.null(seq_length), - seq_length), - list("md5", - !is.null(md5), - md5)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("reviewed", !is.null(reviewed), ifelse(reviewed, "true", "false")), + list("isoform", !is.null(isoform), isoform), + list("goterms", !is.null(go_term), go_term), + list("keywords", !is.null(keyword), keyword), + list("ec", !is.null(ec), paste0(ec, collapse = ",")), + list("gene", !is.null(gene), paste0(gene, collapse = ",")), + list("exact_gene", !is.null(exact_gene), paste0(exact_gene, collapse = ",")), + list("protein", !is.null(protein), protein), + list("organism", !is.null(organism), organism), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("pubmed", !is.null(pubmed), paste0(pubmed, collapse = ",")), + list("seq_length", !is.null(seq_length), seq_length), + list("md5", !is.null(md5), md5) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteins"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_proteins_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteins"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_proteins_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -316,41 +269,57 @@ rba_uniprot_proteins <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character"), - list(arg = "interaction", - class = "logical"), - list(arg = "isoforms", - class = "logical")), - cond = list(list(quote(sum(interaction, isoforms) == 2), - "You can only set only one of interaction or isoform as TRUE in one function call."))) - - .msg("Retrieving %sUniProt Entity with accession number %s.", - if (isTRUE(interaction)) { - "Interactions of "} else if (isTRUE(isoforms)) { - "isoforms of "} else { - ""}, - accession) + .rba_args( + cons = list( + list(arg = "accession", class = "character"), + list(arg = "interaction", class = "logical"), + list(arg = "isoforms", class = "logical") + ), + cond = list( + list( + quote(sum(interaction, isoforms) == 2), + "You can only set only one of interaction or isoform as TRUE in one function call.") + ) + ) + + .msg( + "Retrieving %sUniProt Entity with accession number %s.", + if (isTRUE(interaction)) { + "Interactions of " + } else if (isTRUE(isoforms)) { + "isoforms of " + } else { + ""}, + accession + ) + ## Build Function-Specific Call - path_input <- sprintf("%s%s/%s", - .rba_stg("uniprot", "pth"), - ifelse(isTRUE(interaction), - yes = "proteins/interaction", - no = "proteins"), - accession) + path_input <- sprintf( + "%s%s/%s", + .rba_stg("uniprot", "pth"), + ifelse(isTRUE(interaction), yes = "proteins/interaction", no = "proteins"), + accession) + if (isTRUE(isoforms)) { path_input <- paste0(path_input, "/isoforms") } - parser_input <- ifelse(isTRUE(interaction) | isTRUE(isoforms), - yes = "json->list", - no = "json->list_simp") - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_proteins.json")) + + parser_input <- ifelse( + isTRUE(interaction) | isTRUE(isoforms), + yes = "json->list", + no = "json->list_simp" + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_proteins.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -419,39 +388,45 @@ rba_uniprot_proteins_crossref <- function(db_id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "db_name", - class = "character"), - list(arg = "db_id", - class = "character"), - list(arg = "reviewed", - class = "logical"), - list(arg = "isoform", - class = "numeric", - val = c(0, 1, 2)))) - .msg("Retrieving UniProt entities that correspond to ID %s in database %s.", - db_id, db_name) + .rba_args( + cons = list( + list(arg = "db_name", + class = "character"), + list(arg = "db_id", + class = "character"), + list(arg = "reviewed", + class = "logical"), + list(arg = "isoform", + class = "numeric", + val = c(0, 1, 2)) + ) + ) + + .msg( + "Retrieving UniProt entities that correspond to ID %s in database %s.", + db_id, db_name + ) + ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("reviewed", - !is.null(reviewed), - ifelse(reviewed, - "true", - "false")), - list("isoform", - !is.null(isoform), - isoform)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("reviewed", !is.null(reviewed), ifelse(reviewed, "true", "false")), + list("isoform", !is.null(isoform), isoform) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = sprintf("%sproteins/%s:%s", - .rba_stg("uniprot", "pth"), - db_name, - db_id), - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_proteins_crossref.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = sprintf("%sproteins/%s:%s", .rba_stg("uniprot", "pth"), db_name, db_id), + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_proteins_crossref.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -567,131 +542,103 @@ rba_uniprot_features_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "gene", - class = "character", - max_len = 20), - list(arg = "exact_gene", - class = "character", - max_len = 20), - list(arg = "protein", - class = "character"), - list(arg = "reviewed", - class = "logical"), - list(arg = "organism", - class = "character"), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "categories", - class = "character", - val = c("MOLECULE_PROCESSING", - "TOPOLOGY", - "SEQUENCE_INFORMATION", - "STRUCTURAL", - "DOMAINS_AND_SITES", - "PTM", - "VARIANTS", - "MUTAGENESIS"), - max_len = 8), - list(arg = "types", - class = "character", - max_len = 20, - val = c("INIT_MET", - "SIGNAL", - "PROPEP", - "TRANSIT", - "CHAIN", - "PEPTIDE", - "TOPO_DOM", - "TRANSMEM", - "DOMAIN", - "REPEAT", - "CA_BIND", - "ZN_FING", - "DNA_BIND", - "NP_BIND", - "REGION", - "COILED", - "MOTIF", - "COMPBIAS", - "ACT_SITE", - "METAL", - "BINDING", - "SITE", - "NON_STD", - "MOD_RES", - "LIPID", - "CARBOHYD", - "DISULFID", - "CROSSLNK", - "VAR_SEQ", - "VARIANT", - "MUTAGEN", - "UNSURE", - "CONFLICT", - "NON_CONS", - "NON_TER", - "HELIX", - "TURN", - "STRAND", - "INTRAMEM") - )) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "gene", class = "character", max_len = 20), + list(arg = "exact_gene", class = "character", max_len = 20), + list(arg = "protein", class = "character"), + list(arg = "reviewed", class = "logical"), + list(arg = "organism", class = "character"), + list(arg = "taxid", class = "numeric", max_len = 20), + list( + arg = "categories", class = "character", max_len = 8, + val = c("MOLECULE_PROCESSING", + "TOPOLOGY", + "SEQUENCE_INFORMATION", + "STRUCTURAL", + "DOMAINS_AND_SITES", + "PTM", + "VARIANTS", + "MUTAGENESIS") + ), + list( + arg = "types", class = "character", max_len = 20, + val = c("INIT_MET", + "SIGNAL", + "PROPEP", + "TRANSIT", + "CHAIN", + "PEPTIDE", + "TOPO_DOM", + "TRANSMEM", + "DOMAIN", + "REPEAT", + "CA_BIND", + "ZN_FING", + "DNA_BIND", + "NP_BIND", + "REGION", + "COILED", + "MOTIF", + "COMPBIAS", + "ACT_SITE", + "METAL", + "BINDING", + "SITE", + "NON_STD", + "MOD_RES", + "LIPID", + "CARBOHYD", + "DISULFID", + "CROSSLNK", + "VAR_SEQ", + "VARIANT", + "MUTAGEN", + "UNSURE", + "CONFLICT", + "NON_CONS", + "NON_TER", + "HELIX", + "TURN", + "STRAND", + "INTRAMEM") + ) + ) + ) + + .msg( + "Searching UniProt and retrieving sequence annotations (features) of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving sequence annotations (features) of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("gene", - !is.null(gene), - paste0(gene, - collapse = ",")), - list("exact_gene", - !is.null(exact_gene), - paste0(exact_gene, - collapse = ",")), - list("protein", - !is.null(protein), - protein), - list("reviewed", - !is.null(reviewed), - ifelse(reviewed, - "true", - "false")), - list("organism", - !is.null(organism), - organism), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("categories", - !is.null(categories), - paste0(categories, - collapse = ",")), - list("types", - !is.null(types), - paste0(types, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("gene", !is.null(gene), paste0(gene, collapse = ",")), + list("exact_gene", !is.null(exact_gene), paste0(exact_gene, collapse = ",")), + list("protein", !is.null(protein), protein), + list("reviewed", !is.null(reviewed), ifelse(reviewed, "true", "false")), + list("organism", !is.null(organism), organism), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("categories", !is.null(categories), paste0(categories, collapse = ",")), + list("types", !is.null(types), paste0(types, collapse = ",")) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "features"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_features_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "features"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_features_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -735,92 +682,93 @@ rba_uniprot_features_search <- function(accession = NULL, # #' @family "UniProt - Features" # #' @export # rba_uniprot_features_type <- function(terms, -# type, -# categories = NULL, -# ...) { +# type, +# categories = NULL, +# ...) { # ## Load Global Options # .rba_ext_args(...) +# # ## Check User-input Arguments -# .rba_args(cons = list(list(arg = "terms", -# class = "character", -# max_len = 20), -# list(arg = "type", -# class = "character", -# len = 1, -# val = c("INIT_MET", -# "SIGNAL", -# "PROPEP", -# "TRANSIT", -# "CHAIN", -# "PEPTIDE", -# "TOPO_DOM", -# "TRANSMEM", -# "DOMAIN", -# "REPEAT", -# "CA_BIND", -# "ZN_FING", -# "DNA_BIND", -# "NP_BIND", -# "REGION", -# "COILED", -# "MOTIF", -# "COMPBIAS", -# "ACT_SITE", -# "METAL", -# "BINDING", -# "SITE", -# "NON_STD", -# "MOD_RES", -# "LIPID", -# "CARBOHYD", -# "DISULFID", -# "CROSSLNK", -# "VAR_SEQ", -# "VARIANT", -# "MUTAGEN", -# "UNSURE", -# "CONFLICT", -# "NON_CONS", -# "NON_TER", -# "HELIX", -# "TURN", -# "STRAND", -# "INTRAMEM")), -# list(arg = "categories", -# class = "character", -# val = c("MOLECULE_PROCESSING", -# "TOPOLOGY", -# "SEQUENCE_INFORMATION", -# "STRUCTURAL", -# "DOMAINS_AND_SITES", -# "PTM", -# "VARIANTS", -# "MUTAGENESIS."), -# max_len = 8) +# .rba_args( +# cons = list( +# list(arg = "terms", class = "character", max_len = 20), +# list( +# arg = "type", class = "character", len = 1, +# val = c("INIT_MET", +# "SIGNAL", +# "PROPEP", +# "TRANSIT", +# "CHAIN", +# "PEPTIDE", +# "TOPO_DOM", +# "TRANSMEM", +# "DOMAIN", +# "REPEAT", +# "CA_BIND", +# "ZN_FING", +# "DNA_BIND", +# "NP_BIND", +# "REGION", +# "COILED", +# "MOTIF", +# "COMPBIAS", +# "ACT_SITE", +# "METAL", +# "BINDING", +# "SITE", +# "NON_STD", +# "MOD_RES", +# "LIPID", +# "CARBOHYD", +# "DISULFID", +# "CROSSLNK", +# "VAR_SEQ", +# "VARIANT", +# "MUTAGEN", +# "UNSURE", +# "CONFLICT", +# "NON_CONS", +# "NON_TER", +# "HELIX", +# "TURN", +# "STRAND", +# "INTRAMEM") +# ), +# list( +# arg = "categories", class = "character", max_len = 8, +# val = c("MOLECULE_PROCESSING", +# "TOPOLOGY", +# "SEQUENCE_INFORMATION", +# "STRUCTURAL", +# "DOMAINS_AND_SITES", +# "PTM", +# "VARIANTS", +# "MUTAGENESIS.") +# ) +# ) # ) +# +# .msg( +# "get /features/type/{type} Search protein sequence features of a given type in UniProt" # ) # -# .msg("get /features/type/{type} Search protein sequence features of a given type in UniProt") # ## Build GET API Request's query -# call_query <- .rba_query(init = list("size" = "-1"), -# list("categories", -# !is.null(categories), -# paste0(categories, -# collapse = ",")), -# list("terms", -# !is.null(terms), -# paste0(terms, -# collapse = ","))) +# call_query <- .rba_query( +# init = list("size" = "-1"), +# list("categories", !is.null(categories), paste0(categories, collapse = ",")), +# list("terms", !is.null(terms), paste0(terms, collapse = ",")) +# ) +# # ## Build Function-Specific Call -# input_call <- .rba_httr(httr = "get", -# url = .rba_stg("uniprot", "url"), -# path = paste0(.rba_stg("uniprot", "pth"), -# "features/type/", -# type), -# query = call_query, -# accept = "application/json", -# parser = "json->list", -# save_to = .rba_file("uniprot_features_type.json")) +# input_call <- .rba_httr( +# httr = "get", +# url = .rba_stg("uniprot", "url"), +# path = paste0(.rba_stg("uniprot", "pth"), "features/type/", type), +# query = call_query, +# accept = "application/json", +# parser = "json->list", +# save_to = .rba_file("uniprot_features_type.json") +# ) # # ## Call API # final_output <- .rba_skeleton(input_call) @@ -892,94 +840,91 @@ rba_uniprot_features <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character"), - list(arg = "types", - class = "character", - len = 1, - val = c("INIT_MET", - "SIGNAL", - "PROPEP", - "TRANSIT", - "CHAIN", - "PEPTIDE", - "TOPO_DOM", - "TRANSMEM", - "DOMAIN", - "REPEAT", - "CA_BIND", - "ZN_FING", - "DNA_BIND", - "NP_BIND", - "REGION", - "COILED", - "MOTIF", - "COMPBIAS", - "ACT_SITE", - "METAL", - "BINDING", - "SITE", - "NON_STD", - "MOD_RES", - "LIPID", - "CARBOHYD", - "DISULFID", - "CROSSLNK", - "VAR_SEQ", - "VARIANT", - "MUTAGEN", - "UNSURE", - "CONFLICT", - "NON_CONS", - "NON_TER", - "HELIX", - "TURN", - "STRAND", - "INTRAMEM")), - list(arg = "categories", - class = "character", - val = c("MOLECULE_PROCESSING", - "TOPOLOGY", - "SEQUENCE_INFORMATION", - "STRUCTURAL", - "DOMAINS_AND_SITES", - "PTM", - "VARIANTS", - "MUTAGENESIS."), - max_len = 8), - list(arg = "location", - class = "character", - regex = "^\\d+\\-\\d+$", - len = 1) + .rba_args( + cons = list( + list(arg = "accession", class = "character"), + list( + arg = "types", class = "character", len = 1, + val = c("INIT_MET", + "SIGNAL", + "PROPEP", + "TRANSIT", + "CHAIN", + "PEPTIDE", + "TOPO_DOM", + "TRANSMEM", + "DOMAIN", + "REPEAT", + "CA_BIND", + "ZN_FING", + "DNA_BIND", + "NP_BIND", + "REGION", + "COILED", + "MOTIF", + "COMPBIAS", + "ACT_SITE", + "METAL", + "BINDING", + "SITE", + "NON_STD", + "MOD_RES", + "LIPID", + "CARBOHYD", + "DISULFID", + "CROSSLNK", + "VAR_SEQ", + "VARIANT", + "MUTAGEN", + "UNSURE", + "CONFLICT", + "NON_CONS", + "NON_TER", + "HELIX", + "TURN", + "STRAND", + "INTRAMEM") + ), + list( + arg = "categories", class = "character", max_len = 8, + val = c("MOLECULE_PROCESSING", + "TOPOLOGY", + "SEQUENCE_INFORMATION", + "STRUCTURAL", + "DOMAINS_AND_SITES", + "PTM", + "VARIANTS", + "MUTAGENESIS.") + ), + list(arg = "location", class = "character", regex = "^\\d+\\-\\d+$", len = 1) + ) ) + + .msg( + "Retrieving sequence annotations (features) of protein %s.", + accession ) - .msg("Retrieving sequence annotations (features) of protein %s.", accession) ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("categories", - !is.null(categories), - paste0(categories, - collapse = ",")), - list("types", - !is.null(types), - paste0(types, - collapse = ",")), - list("location", - !is.null(location), - location)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("categories", !is.null(categories), paste0(categories, collapse = ",")), + list("types", !is.null(types), paste0(types, collapse = ",")), + list("location", !is.null(location), location) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "features/", - accession), - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_features.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "features/", accession), + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_features.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1097,125 +1042,84 @@ rba_uniprot_variation_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "source_type", - class = "character", - val = c("uniprot", - "large scale study", - "mixed"), - max_len = 2), - list(arg = "consequence_type", - class = "character", - val = c("missense", - "stop gained", - "stop lost")), - list(arg = "wild_type", - class = "character", - max_len = 20), - list(arg = "alternative_sequence", - class = "character", - max_len = 20), - list(arg = "location", - class = "character", - regex = "^\\d+\\-\\d+$", - len = 1), - list(arg = "disease", - class = "character"), - list(arg = "omim", - class = "character", - max_len = 20), - list(arg = "evidence", - class = "numeric", - max_len = 20), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "db_type", - class = "character", - max_len = 2), - list(arg = "db_id", - class = "character", - max_len = 20), - list(arg = "save_peff", - class = c("logical", - "character"))), - cond = list(list(quote(all(is.null(accession), is.null(disease), - is.null(omim), is.null(evidence), - is.null(taxid), is.null(db_type), - is.null(db_id))), - "You should supply at least one of: accession, disease, omim, evidence, taxid, db_type or db_id")) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list( + arg = "source_type", class = "character", max_len = 2, + val = c("uniprot", "large scale study", "mixed") + ), + list( + arg = "consequence_type", class = "character", + val = c("missense", "stop gained", "stop lost") + ), + list(arg = "wild_type", class = "character", max_len = 20), + list(arg = "alternative_sequence", class = "character", max_len = 20), + list(arg = "location", class = "character", regex = "^\\d+\\-\\d+$", len = 1), + list(arg = "disease", class = "character"), + list(arg = "omim", class = "character", max_len = 20), + list(arg = "evidence", class = "numeric", max_len = 20), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "db_type", class = "character", max_len = 2), + list(arg = "db_id", class = "character", max_len = 20), + list(arg = "save_peff", class = c("logical", "character")) + ), + cond = list( + list( + quote(all(is.null(accession), is.null(disease), + is.null(omim), is.null(evidence), + is.null(taxid), is.null(db_type), + is.null(db_id))), + "You should supply at least one of: accession, disease, omim, evidence, taxid, db_type or db_id" + ) + ) + ) + + .msg( + "Searching UniProt and retrieving natural variations of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving natural variations of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("sourcetype", - !is.null(source_type), - paste0(source_type, - collapse = ",")), - list("consequencetype", - !is.null(consequence_type), - paste0(consequence_type, - collapse = ",")), - list("wildtype", - !is.null(wild_type), - paste0(wild_type, - collapse = ",")), - list("alternativesequence", - !is.null(alternative_sequence), - paste0(alternative_sequence, - collapse = ",")), - list("location", - !is.null(location), - location), - list("disease", - !is.null(disease), - disease), - list("omim", - !is.null(omim), - paste0(omim, - collapse = ",")), - list("evidence", - !is.null(evidence), - paste0(evidence, - collapse = ",")), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("dbtype", - !is.null(db_type), - paste0(db_type, - collapse = ",")), - list("dbid", - !is.null(db_id), - paste0(db_type, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("sourcetype", !is.null(source_type), paste0(source_type, collapse = ",")), + list("consequencetype", !is.null(consequence_type), paste0(consequence_type, collapse = ",")), + list("wildtype", !is.null(wild_type), paste0(wild_type, collapse = ",")), + list("alternativesequence", !is.null(alternative_sequence), paste0(alternative_sequence, collapse = ",")), + list("location", !is.null(location), location), + list("disease", !is.null(disease), disease), + list("omim", !is.null(omim), paste0(omim, collapse = ",")), + list("evidence", !is.null(evidence), paste0(evidence, collapse = ",")), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("dbtype", !is.null(db_type), paste0(db_type, collapse = ",")), + list("dbid", !is.null(db_id), paste0(db_type, collapse = ",")) + ) + ## Build Function-Specific Call - save_to <- ifelse(isFALSE(save_peff), - yes = .rba_file(file = "uniprot_variation.json"), - no = .rba_file(file = "uniprot_variation.peff", - save_to = save_peff)) - obj_parser_input <- list("json->list", - .rba_uniprot_search_namer) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "variation"), - query = call_query, - save_to = save_to, - file_accept = "text/x-peff", - file_parser = "text->chr", - obj_accept = "application/json", - obj_parser = obj_parser_input) + save_to <- ifelse( + isFALSE(save_peff), + yes = .rba_file(file = "uniprot_variation.json"), + no = .rba_file(file = "uniprot_variation.peff", + save_to = save_peff) + ) + + obj_parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "variation"), + query = call_query, + save_to = save_to, + file_accept = "text/x-peff", + file_parser = "text->chr", + obj_accept = "application/json", + obj_parser = obj_parser_input + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) @@ -1301,87 +1205,79 @@ rba_uniprot_variation <- function(id, ...) { ## Load Global Options .rba_ext_args(..., ignore_save = TRUE) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "id", - class = "character"), - list(arg = "id_type", - class = "character", - val = c("uniprot", - "dbsnp", - "hgvs")), - list(arg = "source_type", - class = "character", - val = c("uniprot", - "large scale study", - "mixed"), - max_len = 2), - list(arg = "consequence_type", - class = "character", - val = c("missense", - "stop gained", - "stop lost"), - max_len = 2), - list(arg = "wild_type", - class = "character", - max_len = 20), - list(arg = "alternative_sequence", - class = "character", - max_len = 20), - list(arg = "location", - class = "character"), - list(arg = "save_peff", - class = c("logical", - "character")))) - - .msg("Retrieving Natural variant of %s.", - ifelse(id_type == "uniprot", - yes = paste0("UniProt protein ", id), - no = paste0(id_type, " id ", id))) + .rba_args( + cons = list( + list(arg = "id", class = "character"), + list( + arg = "id_type", class = "character", + val = c("uniprot", "dbsnp", "hgvs") + ), + list( + arg = "source_type", class = "character", max_len = 2, + val = c("uniprot", "large scale study", "mixed") + ), + list( + arg = "consequence_type", class = "character", max_len = 2, + val = c("missense", "stop gained", "stop lost") + ), + list(arg = "wild_type", class = "character", max_len = 20), + list(arg = "alternative_sequence", class = "character", max_len = 20), + list(arg = "location", class = "character"), + list(arg = "save_peff", class = c("logical", "character")) + ) + ) + + .msg( + "Retrieving Natural variant of %s.", + ifelse( + id_type == "uniprot", + yes = paste0("UniProt protein ", id), + no = paste0(id_type, " id ", id) + ) + ) + ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("sourcetype", - !is.null(source_type), - paste0(source_type, - collapse = ",")), - list("consequencetype", - !is.null(consequence_type), - paste0(consequence_type, - collapse = ",")), - list("wildtype", - !is.null(wild_type), - paste0(wild_type, - collapse = ",")), - list("alternativesequence", - !is.null(alternative_sequence), - paste0(alternative_sequence, - collapse = ",")), - list("location", - !is.null(location), - location)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("sourcetype", !is.null(source_type), paste0(source_type, collapse = ",")), + list("consequencetype", !is.null(consequence_type), paste0(consequence_type, collapse = ",")), + list("wildtype", !is.null(wild_type), paste0(wild_type, collapse = ",")), + list("alternativesequence", !is.null(alternative_sequence), paste0(alternative_sequence, collapse = ",")), + list("location", !is.null(location), location) + ) + ## Build Function-Specific Call - file_name <- sprintf("uniprot_variation_%s.%s", - id_type, ifelse(isFALSE(save_peff), "json", "peff")) - save_to <- ifelse(isFALSE(save_peff), - yes = .rba_file(file = file_name), - no = .rba_file(file = file_name, - save_to = save_peff)) - path_input <- switch(id_type, - "uniprot" = paste0(.rba_stg("uniprot", "pth"), - "variation/", id), - "hgvs" = paste0(.rba_stg("uniprot", "pth"), - "variation/hgvs/", id), - "dbsnp" = paste0(.rba_stg("uniprot", "pth"), - "variation/dbsnp/", id)) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - save_to = save_to, - file_accept = "text/x-peff", - file_parser = "text->chr", - obj_accept = "application/json", - obj_parser = "json->list") + file_name <- sprintf( + "uniprot_variation_%s.%s", + id_type, ifelse(isFALSE(save_peff), "json", "peff") + ) + + save_to <- ifelse( + isFALSE(save_peff), + yes = .rba_file(file = file_name), + no = .rba_file(file = file_name, save_to = save_peff) + ) + + path_input <- switch( + id_type, + "uniprot" = paste0(.rba_stg("uniprot", "pth"), "variation/", id), + "hgvs" = paste0(.rba_stg("uniprot", "pth"), "variation/hgvs/", id), + "dbsnp" = paste0(.rba_stg("uniprot", "pth"), "variation/dbsnp/", id) + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + save_to = save_to, + file_accept = "text/x-peff", + file_parser = "text->chr", + obj_accept = "application/json", + obj_parser = "json->list" + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1451,55 +1347,44 @@ rba_uniprot_antigens_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "antigen_sequence", - class = "character"), - list(arg = "antigen_id", - class = "character", - max_len = 20), - list(arg = "ensembl_id", - class = "character", - max_len = 20), - list(arg = "match_score", - class = "numeric")) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "antigen_sequence", class = "character"), + list(arg = "antigen_id", class = "character", max_len = 20), + list(arg = "ensembl_id", class = "character", max_len = 20), + list(arg = "match_score", class = "numeric") + ) + ) + + .msg( + "Searching UniProt and retrieving antigenic features of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving antigenic features of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("antigen_sequence", - !is.null(antigen_sequence), - antigen_sequence), - list("antigen_id", - !is.null(antigen_id), - paste0(antigen_id, - collapse = ",")), - list("ensembl_id", - !is.null(ensembl_id), - paste0(ensembl_id, - collapse = ",")), - list("match_score", - !is.null(match_score), - match_score)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("antigen_sequence", !is.null(antigen_sequence), antigen_sequence), + list("antigen_id", !is.null(antigen_id), paste0(antigen_id, collapse = ",")), + list("ensembl_id", !is.null(ensembl_id), paste0(ensembl_id, collapse = ",")), + list("match_score", !is.null(match_score), match_score) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "antigen"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_antigen_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "antigen"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_antigen_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1549,23 +1434,28 @@ rba_uniprot_antigens <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - len = 1)) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1) + ) + ) + + .msg( + "Retrieving Antigenic features mapped to the sequence of protein %s.", + accession ) - .msg("Retrieving Antigenic features mapped to the sequence of protein %s.", - accession) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "antigen/", - accession), - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_antigen.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "antigen/", accession), + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_antigen.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1629,7 +1519,9 @@ rba_uniprot_epitope_search <- function(accession = NULL, ) ) - .msg("Searching UniProt for epitopes matching the supplied criteria.") + .msg( + "Searching UniProt for epitopes matching the supplied criteria." + ) ## Build GET API Request's query call_query <- .rba_query( @@ -1685,11 +1577,16 @@ rba_uniprot_epitope <- function(accession, ...) { .rba_ext_args(...) ## Check User-input Arguments - .rba_args(cons = list( - list(arg = "accession", class = "character", len = 1) - )) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1) + ) + ) - .msg("Retrieving epitope information for accession %s.", accession) + .msg( + "Retrieving epitope information for accession %s.", + accession + ) ## Build Function-Specific Call parser_input <- "json->list" @@ -1764,50 +1661,45 @@ rba_uniprot_epitope <- function(accession, ...) { #' @family "UniProt - Mutagenesis" #' @export rba_uniprot_mutagenesis_search <- function(accession = NULL, - taxid = NULL, - db_id = NULL, - ...) { + taxid = NULL, + db_id = NULL, + ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "db_id", - class = "character", - max_len = 20)) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "db_id", class = "character", max_len = 20) + ) + ) + + .msg( + "Searching UniProt and retrieving mutagenesis description of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving mutagenesis description of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("db_id", - !is.null(db_id), - paste0(db_id, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("db_id", !is.null(db_id), paste0(db_id, collapse = ",")) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "mutagenesis"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_mutagenesis_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "mutagenesis"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_mutagenesis_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1862,33 +1754,36 @@ rba_uniprot_mutagenesis <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - len = 1), - list(arg = "location", - class = "character", - regex = "^\\d+\\-\\d+$", - len = 1)) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1), + list(arg = "location", class = "character", regex = "^\\d+\\-\\d+$", len = 1) + ) + ) + + .msg( + "Retrieving mutagenesis description mapped to the sequence of protein %s.", + accession ) - .msg("Retrieving mutagenesis description mapped to the sequence of protein %s.", - accession) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("location", - !is.null(location), - location)) + call_query <- .rba_query( + init = list(), + list("location", !is.null(location), location) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "mutagenesis/", - accession), - accept = "application/json", - parser = "json->list", - query = call_query, - save_to = .rba_file("uniprot_mutagenesis.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "mutagenesis/", accession), + accept = "application/json", + parser = "json->list", + query = call_query, + save_to = .rba_file("uniprot_mutagenesis.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -1936,13 +1831,17 @@ rba_uniprot_rna_edit_search <- function(accession = NULL, .rba_ext_args(...) ## Check User-input Arguments - .rba_args(cons = list( - list(arg = "accession", class = "character", max_len = 100), - list(arg = "taxid", class = "numeric", max_len = 20), - list(arg = "variantlocation", class = "character", max_len = 4) - )) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "variantlocation", class = "character", max_len = 4) + ) + ) - .msg("Searching UniProt for RNA editing records matching the supplied criteria.") + .msg( + "Searching UniProt for RNA editing records matching the supplied criteria." + ) ## Build GET API Request's query call_query <- .rba_query( @@ -1954,6 +1853,7 @@ rba_uniprot_rna_edit_search <- function(accession = NULL, ## Build Function-Specific Call parser_input <- list("json->list", .rba_uniprot_search_namer) + input_call <- .rba_httr( httr = "get", url = .rba_stg("uniprot", "url"), @@ -1999,20 +1899,24 @@ rba_uniprot_rna_edit <- function(accession, ...) { .rba_ext_args(...) ## Check User-input Arguments - .rba_args(cons = list( - list(arg = "accession", class = "character", len = 1) - )) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1) + ) + ) - .msg("Retrieving RNA-editing information for accession %s.", accession) + .msg( + "Retrieving RNA-editing information for accession %s.", + accession + ) ## Build Function-Specific Call - parser_input <- "json->list" input_call <- .rba_httr( httr = "get", url = .rba_stg("uniprot", "url"), path = paste0(.rba_stg("uniprot", "pth"), "rna-editing/", accession), accept = "application/json", - parser = parser_input, + parser = "json->list", save_to = .rba_file("uniprot_rna_edit.json") ) diff --git a/R/uniprot_proteomes.R b/R/uniprot_proteomes.R index 6f250091..5f5202c9 100644 --- a/R/uniprot_proteomes.R +++ b/R/uniprot_proteomes.R @@ -83,83 +83,61 @@ rba_uniprot_proteomes_search <- function(name = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "upid", - class = "character", - max_len = 100), - list(arg = "name", - class = "character"), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "keyword", - class = "character"), - list(arg = "xref", - class = "character", - max_len = 20), - list(arg = "genome_acc", - class = "character", - max_len = 20), - list(arg = "is_ref_proteome", - class = "logical"), - list(arg = "is_redundant", - class = "logical")) + .rba_args( + cons = list( + list(arg = "upid", class = "character", max_len = 100), + list(arg = "name", class = "character"), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "keyword", class = "character"), + list(arg = "xref", class = "character", max_len = 20), + list(arg = "genome_acc", class = "character", max_len = 20), + list(arg = "is_ref_proteome", class = "logical"), + list(arg = "is_redundant", class = "logical") + ) + ) + + .msg( + "Searching UniProt and retrieving proteoms that match your supplied inputs." ) - .msg("Searching UniProt and retrieving proteoms that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("name", - !is.null(name), - name), - list("upid", - !is.null(upid), - paste0(upid, - collapse = ",")), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("keyword", - !is.null(keyword), - keyword), - list("xref", - !is.null(xref), - paste0(xref, - collapse = ",")), - list("genome_acc", - !is.null(genome_acc), - paste0(genome_acc, - collapse = ",")), - list("is_ref_proteome", - !is.null(is_ref_proteome), - ifelse(is_ref_proteome, - "true", - "false")), - list("is_redundant", - !is.null(is_redundant), - ifelse(is_redundant, - "true", - "false"))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("name", !is.null(name), name), + list("upid", !is.null(upid), paste0(upid, collapse = ",")), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("keyword", !is.null(keyword), keyword), + list("xref", !is.null(xref), paste0(xref, collapse = ",")), + list("genome_acc", !is.null(genome_acc), paste0(genome_acc, collapse = ",")), + list("is_ref_proteome", !is.null(is_ref_proteome), ifelse(is_ref_proteome, "true", "false")), + list("is_redundant", !is.null(is_redundant), ifelse(is_redundant, "true", "false")) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - function(x) { - x_names <- vapply(X = x, - FUN = function(x) { - x$upid - }, - FUN.VALUE = character(1)) - names(x) <- x_names - return(x)}) + parser_input <- list( + "json->list", + function(x) { + x_names <- vapply(X = x, + FUN = function(x) { + x$upid + }, + FUN.VALUE = character(1)) + names(x) <- x_names + return(x) + } + ) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomes"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_proteomes_search.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomes"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_proteomes_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -224,54 +202,69 @@ rba_uniprot_proteomes <- function(upid, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "upid", - class = "character"), - list(arg = "get_proteins", - class = "logical"), - list(arg = "reviewed", - class = "logical")), - cond = list(list(quote(isFALSE(get_proteins) && !is.null(reviewed)), - "'reviewed' argument is ignored because you supplied 'get_proteins' as FALSE.")), - cond_warning = TRUE + .rba_args( + cons = list( + list( + arg = "upid", class = "character"), + list(arg = "get_proteins", class = "logical"), + list(arg = "reviewed", class = "logical") + ), + cond = list( + list( + quote(isFALSE(get_proteins) && !is.null(reviewed)), + "'reviewed' argument is ignored because you supplied 'get_proteins' as FALSE." + ) + ), + cond_warning = TRUE + ) + + .msg( + "Retrieving proteome %s (%s).", + upid, + ifelse( + isTRUE(get_proteins), + yes = sprintf("With %s proteins", + ifelse( + test = is.null(reviewed), + yes = "", + no = ifelse( + test = reviewed, + yes = "only UniProtKB/Swiss-Prot", + no = "only TrEMBL") + ) + ), + no = "Excluding proteins") ) - .msg("Retrieving proteome %s (%s).", - upid, - ifelse(isTRUE(get_proteins), - yes = sprintf("With %s proteins", - ifelse(test = is.null(reviewed), - yes = "", - no = ifelse(test = reviewed, - yes = "only UniProtKB/Swiss-Prot", - no = "only TrEMBL"))), - no = "Excluding proteins")) ## Build Function-Specific Call if (isTRUE(get_proteins)) { + ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("reviewed", - !is.null(reviewed), - ifelse(reviewed, - "true", - "false"))) - path_input <- paste0(.rba_stg("uniprot", "pth"), - "proteomes/proteins/", - upid) + call_query <- .rba_query( + init = list(), + list("reviewed", !is.null(reviewed), ifelse(reviewed, "true", "false")) + ) + + path_input <- paste0(.rba_stg("uniprot", "pth"), "proteomes/proteins/", upid) + } else { + call_query <- NULL - path_input <- paste0(.rba_stg("uniprot", "pth"), - "proteomes/", - upid) + path_input <- paste0(.rba_stg("uniprot", "pth"), "proteomes/", upid) + } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_proteomes.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_proteomes.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -346,42 +339,38 @@ rba_uniprot_genecentric_search <- function(upid = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "upid", - class = "character", - max_len = 100), - list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "gene", - class = "character", - max_len = 20)) + .rba_args( + cons = list( + list(arg = "upid", class = "character", max_len = 100), + list(arg = "accession", class = "character", max_len = 100), + list(arg = "gene", class = "character", max_len = 20) + ) + ) + + .msg( + "Searching UniProt and retrieving Gene-Centric Proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving Gene-Centric Proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("upid", - !is.null(upid), - paste0(upid, - collapse = ",")), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("gene", - !is.null(gene), - paste0(gene, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("upid", !is.null(upid), paste0(upid, collapse = ",")), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("gene", !is.null(gene), paste0(gene, collapse = ",")) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "genecentric"), - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_genecentric_search.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "genecentric"), + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_genecentric_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -433,21 +422,26 @@ rba_uniprot_genecentric <- function(accession, ## Load Global Options .rba_ext_args(...) ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character")) + .rba_args( + cons = list( + list(arg = "accession", class = "character") + ) + ) + + .msg( + "Retrieving Gene-Centric proteins by UniProt Accession %s.", + accession ) - .msg("Retrieving Gene-Centric proteins by UniProt Accession %s.", - accession) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "genecentric/", - accession), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("uniprot_genecentric.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "genecentric/", accession), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("uniprot_genecentric.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/uniprot_proteomics.R b/R/uniprot_proteomics.R index 931e866a..c4733a0c 100644 --- a/R/uniprot_proteomics.R +++ b/R/uniprot_proteomics.R @@ -46,19 +46,23 @@ rba_uniprot_proteomics_species <- function(...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments .rba_args() - .msg("Retrieving Unipropt Proteomics metadata") + .msg( + "Retrieving Unipropt Proteomics metadata" + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/species"), - accept = "application/json", - parser = "json->df", - save_to = .rba_file("uniprot_species.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/species"), + accept = "application/json", + parser = "json->df", + save_to = .rba_file("uniprot_species.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -146,67 +150,49 @@ rba_uniprot_proteomics_non_ptm_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "upid", - class = "character", - max_len = 100), - list(arg = "data_source", - class = "character", - max_len = 2, - val = c("MaxQB", - "PeptideAtlas", - "EPD", - "ProteomicsDB")), - list(arg = "peptide", - class = "character", - max_len = 20), - list(arg = "unique", - class = "logical")) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "upid", class = "character", max_len = 100), + list( + arg = "data_source", class = "character", max_len = 2, + val = c("MaxQB", "PeptideAtlas", "EPD", "ProteomicsDB") + ), + list(arg = "peptide", class = "character", max_len = 20), + list(arg = "unique", class = "logical") + ) + ) + + .msg( + "Searching UniProt and retrieving proteomics nonPTM features of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving proteomics nonPTM features of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("upid", - !is.null(upid), - paste0(upid, - collapse = ",")), - list("data_source", - !is.null(data_source), - paste0(data_source, - collapse = ",")), - list("peptide", - !is.null(peptide), - paste0(peptide, - collapse = ",")), - list("unique", - !is.null(unique), - ifelse(unique, "true", "false"))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("upid", !is.null(upid), paste0(upid, collapse = ",")), + list("data_source", !is.null(data_source), paste0(data_source, collapse = ",")), + list("peptide", !is.null(peptide), paste0(peptide, collapse = ",")), + list("unique", !is.null(unique), ifelse(unique, "true", "false")) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/nonPtm"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_proteomics_non_ptm_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/nonPtm"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_proteomics_non_ptm_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -262,24 +248,28 @@ rba_uniprot_proteomics_non_ptm <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - len = 1)) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1) + ) ) - .msg("Retrieving proteomics Proteomics nonPTM features mapped to the sequence of protein %s.", - accession) + .msg( + "Retrieving proteomics Proteomics nonPTM features mapped to the sequence of protein %s.", + accession + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/ptm/", - accession), - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_proteomics_non_ptm.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/ptm/", accession), + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_proteomics_non_ptm.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -391,119 +381,97 @@ rba_uniprot_proteomics_ptm_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "ptm", - class = "character", - len = 1, - val = c("Acetylation", - "ADP-ribosylation", - "Amidation", - "Autocatalytic cleavage", - "Bromination", - "Citrullination", - "Cleavage on pair of basic residues", - "Covalent protein-DNA linkage", - "Covalent protein-RNA linkage", - "CTQ", - "D-amino acid", - "Disulfide bond", - "Formylation", - "Gamma-carboxyglutamic acid", - "Glutathionylation", - "Glycoprotein", - "Lipoprotein", - "Hydroxylation", - "Hypusine", - "Iodination", - "Isopeptide bond", - "LTQ", - "Methylation", - "Nitration", - "Organic radical", - "Oxidation", - "Peptidoglycan-anchor", - "Phosphopantetheine", - "Phosphoprotein", - "Pyrrolidone carboxylic acid", - "Quinone", - "S-nitrosylation", - "Sulfation", - "Thioester bond", - "Thioether bond", - "TPQ", - "TTQ", - "Ubl conjugation", - "Zymogen")), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "upid", - class = "character", - max_len = 100), - list(arg = "data_source", - class = "character", - max_len = 2, - val = c("PRIDE", - "PTMExchange")), - list(arg = "peptide", - class = "character", - max_len = 20), - list(arg = "unique", - class = "logical"), - list(arg = "confidence_score", - class = "character", - max_len = 1, - val = c("Bronze", - "Silver", - "Gold"))) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list( + arg = "ptm", class = "character", len = 1, + val = c("Acetylation", + "ADP-ribosylation", + "Amidation", + "Autocatalytic cleavage", + "Bromination", + "Citrullination", + "Cleavage on pair of basic residues", + "Covalent protein-DNA linkage", + "Covalent protein-RNA linkage", + "CTQ", + "D-amino acid", + "Disulfide bond", + "Formylation", + "Gamma-carboxyglutamic acid", + "Glutathionylation", + "Glycoprotein", + "Lipoprotein", + "Hydroxylation", + "Hypusine", + "Iodination", + "Isopeptide bond", + "LTQ", + "Methylation", + "Nitration", + "Organic radical", + "Oxidation", + "Peptidoglycan-anchor", + "Phosphopantetheine", + "Phosphoprotein", + "Pyrrolidone carboxylic acid", + "Quinone", + "S-nitrosylation", + "Sulfation", + "Thioester bond", + "Thioether bond", + "TPQ", + "TTQ", + "Ubl conjugation", + "Zymogen") + ), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "upid", class = "character", max_len = 100), + list( + arg = "data_source", class = "character", max_len = 2, + val = c("PRIDE", "PTMExchange") + ), + list(arg = "peptide", class = "character", max_len = 20), + list(arg = "unique", class = "logical"), + list( + arg = "confidence_score", class = "character", max_len = 1, + val = c("Bronze", "Silver", "Gold") + ) + ) + ) + + .msg( + "Searching UniProt and retrieving proteomics Post-translational modification features of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving proteomics Post-translational modification features of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("ptm", - !is.null(ptm), - ptm), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("upid", - !is.null(upid), - paste0(upid, - collapse = ",")), - list("data_source", - !is.null(data_source), - paste0(data_source, - collapse = ",")), - list("peptide", - !is.null(peptide), - paste0(peptide, - collapse = ",")), - list("unique", - !is.null(unique), - ifelse(unique, "true", "false")), - list("confidence_score", - !is.null(confidence_score), - confidence_score)) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("ptm", !is.null(ptm), ptm), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("upid", !is.null(upid), paste0(upid, collapse = ",")), + list("data_source", !is.null(data_source), paste0(data_source, collapse = ",")), + list("peptide", !is.null(peptide), paste0(peptide, collapse = ",")), + list("unique", !is.null(unique), ifelse(unique, "true", "false")), + list("confidence_score", !is.null(confidence_score), confidence_score) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/ptm"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_proteomics_ptm_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/ptm"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_proteomics_ptm_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -570,36 +538,38 @@ rba_uniprot_proteomics_ptm <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - len = 1)) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1) + ) ) - .msg("Retrieving proteomics post-translational modification features mapped to the sequence of protein %s.", - accession) + .msg( + "Retrieving proteomics post-translational modification features mapped to the sequence of protein %s.", + accession + ) ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("confidence_score", - !is.null(confidence_score), - confidence_score), - list(arg = "confidence_score", - class = "character", - max_len = 1, - val = c("Bronze", - "Silver", - "Gold"))) + call_query <- .rba_query( + init = list(), + list("confidence_score", !is.null(confidence_score), confidence_score), + list( + arg = "confidence_score", class = "character", max_len = 1, + val = c("Bronze", "Silver", "Gold") + ) + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/ptm/", - accession), - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_proteomics_ptm.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/ptm/", accession), + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_proteomics_ptm.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -684,67 +654,49 @@ rba_uniprot_proteomics_hpp_search <- function(accession = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "taxid", - class = "numeric", - max_len = 20), - list(arg = "upid", - class = "character", - max_len = 100), - list(arg = "data_source", - class = "character", - max_len = 2, - val = c("MaxQB", - "PeptideAtlas", - "EPD", - "ProteomicsDB")), - list(arg = "peptide", - class = "character", - max_len = 20), - list(arg = "unique", - class = "logical")) + .rba_args( + cons = list( + list(arg = "accession", class = "character", max_len = 100), + list(arg = "taxid", class = "numeric", max_len = 20), + list(arg = "upid", class = "character", max_len = 100), + list( + arg = "data_source", class = "character", max_len = 2, + val = c("MaxQB", "PeptideAtlas", "EPD", "ProteomicsDB") + ), + list(arg = "peptide", class = "character", max_len = 20), + list(arg = "unique", class = "logical") + ) + ) + + .msg( + "Searching UniProt and retrieving proteomics HPP features of proteins that match your supplied inputs." ) - .msg("Searching UniProt and retrieving proteomics HPP features of proteins that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("upid", - !is.null(upid), - paste0(upid, - collapse = ",")), - list("data_source", - !is.null(data_source), - paste0(data_source, - collapse = ",")), - list("peptide", - !is.null(peptide), - paste0(peptide, - collapse = ",")), - list("unique", - !is.null(unique), - ifelse(unique, "true", "false"))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("upid", !is.null(upid), paste0(upid, collapse = ",")), + list("data_source", !is.null(data_source), paste0(data_source, collapse = ",")), + list("peptide", !is.null(peptide), paste0(peptide, collapse = ",")), + list("unique", !is.null(unique), ifelse(unique, "true", "false")) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/hpp"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_hpp_search.json")) + parser_input <- list("json->list", .rba_uniprot_search_namer) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/hpp"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_hpp_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -800,24 +752,28 @@ rba_uniprot_proteomics_hpp <- function(accession, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character", - len = 1)) + .rba_args( + cons = list( + list(arg = "accession", class = "character", len = 1) + ) ) - .msg("Retrieving proteomics Proteomics features mapped to the sequence of protein %s.", - accession) + .msg( + "Retrieving proteomics Proteomics features mapped to the sequence of protein %s.", + accession + ) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "proteomics/hpp/", - accession), - accept = "application/json", - parser = "json->df", - save_to = .rba_file("uniprot_hpp.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "proteomics/hpp/", accession), + accept = "application/json", + parser = "json->df", + save_to = .rba_file("uniprot_hpp.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/uniprot_taxonomy.R b/R/uniprot_taxonomy.R index d559f6c6..5a57061a 100644 --- a/R/uniprot_taxonomy.R +++ b/R/uniprot_taxonomy.R @@ -44,21 +44,27 @@ rba_uniprot_taxonomy_lca <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = "numeric", - min_len = 2)) + .rba_args( + cons = list( + list(arg = "ids", class = "numeric", min_len = 2) + ) + ) + + .msg( + "Retrieving LCA of ", .paste2(ids, sep = ", ", last = " and ") ) - .msg("Retrieving LCA of ", .paste2(ids, sep = ", ", last = " and ")) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "taxonomy/ancestor/", - paste0(ids, collapse = ",")), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("uniprot_taxonomy_lca.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "taxonomy/ancestor/", paste0(ids, collapse = ",")), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("uniprot_taxonomy_lca.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -138,63 +144,74 @@ rba_uniprot_taxonomy <- function(ids, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "ids", - class = "numeric"), - list(arg = "hierarchy", - class = "character", - val = c("children", - "parent", - "siblings")), - list(arg = "node_only", - class = "logical"), - list(arg = "page_size", - class = "numeric", - ran = c(1,200)), - list(arg = "page_number", - class = "numeric")), - cond = list(list(quote(length(ids) > 1 && !is.null(hierarchy)), - "you cannot specify 'hierarchy' when providing more than 1 ids."), - list(quote(is.null(hierarchy) && (page_size != 200 | page_number != 1)), - "Because hierarchy argument was not supplied, page_size and page_number were ignored.", - warn = TRUE)) + .rba_args( + cons = list( + list(arg = "ids", class = "numeric"), + list( + arg = "hierarchy", class = "character", + val = c("children", "parent", "siblings") + ), + list(arg = "node_only", class = "logical"), + list(arg = "page_size", class = "numeric", ran = c(1,200)), + list(arg = "page_number", class = "numeric") + ), + cond = list( + list( + quote(length(ids) > 1 && !is.null(hierarchy)), + "you cannot specify 'hierarchy' when providing more than 1 ids." + ), + list( + quote(is.null(hierarchy) && (page_size != 200 | page_number != 1)), + "Because hierarchy argument was not supplied, page_size and page_number were ignored.", + warn = TRUE + ) + ) + ) + + .msg( + "Retrieving %snodes information of %s.", + ifelse(!is.null(hierarchy), yes = hierarchy, no = ""), + .paste2(ids, sep = ", ", last = " and ") ) - .msg("Retrieving %snodes information of %s.", - ifelse(!is.null(hierarchy), - yes = hierarchy, - no = ""), - .paste2(ids, sep = ", ", last = " and ")) ## Build GET API Request's query call_query <- list() + ## Build Function-Specific Call - path_input <- sprintf("%staxonomy/%s/%s", - .rba_stg("uniprot", "pth"), - ifelse(length(ids) > 1, - yes = "ids", - no = "id"), - paste0(ids, collapse = ",") + path_input <- sprintf( + "%staxonomy/%s/%s", + .rba_stg("uniprot", "pth"), + ifelse(length(ids) > 1, yes = "ids", no = "id"), + paste0(ids, collapse = ",") ) + if (!is.null(hierarchy)) { path_input <- paste0(path_input, "/", hierarchy) ## Build GET API Request's query - call_query <- list("pageSize" = page_size, - "pageNumber" = page_number) + call_query <- list("pageSize" = page_size, "pageNumber" = page_number) } + if (isTRUE(node_only)) { path_input <- paste0(path_input, "/node") } - parser_input <- ifelse(isTRUE(node_only), - yes = "json->list_simp", - no = "json->list") - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_taxonomy.json")) + parser_input <- ifelse( + isTRUE(node_only), + yes = "json->list_simp", + no = "json->list" + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_taxonomy.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -245,20 +262,28 @@ rba_uniprot_taxonomy_lineage <- function(id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "id", - class = "numeric"))) + .rba_args( + cons = list( + list(arg = "id", class = "numeric") + ) + ) + + .msg( + "Retrieving Taxonomic Lineage of node %s.", + id + ) - .msg("Retrieving Taxonomic Lineage of node %s.", id) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "taxonomy/lineage/", - id), - accept = "application/json", - parser = "json->list_simp", - save_to = .rba_file("rba_uniprot_taxonomy_lineage.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "taxonomy/lineage/", id), + accept = "application/json", + parser = "json->list_simp", + save_to = .rba_file("rba_uniprot_taxonomy_lineage.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -330,61 +355,76 @@ rba_uniprot_taxonomy_name <- function(name, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "name", - class = "character"), - list(arg = "field", - class = "character", - val = c("scientific", - "common", - "mnemonic")), - list(arg = "search_type", - class = "character", - val = c("equal_to", - "start_with", - "end_with", - "contain")), - list(arg = "node_only", - class = "logical"), - list(arg = "page_size", - class = "numeric", - ran = c(1,200)), - list(arg = "page_number", - class = "numeric"))) - - .msg("Retrieving taxonomic nodes that their %s name field %s %s (page %s).", - field, search_type, name, page_number) + .rba_args( + cons = list( + list(arg = "name", class = "character"), + list( + arg = "field", class = "character", + val = c("scientific", "common", "mnemonic") + ), + list( + arg = "search_type", class = "character", + val = c("equal_to", "start_with", "end_with", "contain") + ), + list(arg = "node_only", class = "logical"), + list(arg = "page_size", class = "numeric", ran = c(1,200)), + list(arg = "page_number", class = "numeric") + ) + ) + + .msg( + "Retrieving taxonomic nodes that their %s name field %s %s (page %s).", + field, search_type, name, page_number + ) + ## Build GET API Request's query - call_query <- list("name" = name, - "fieldName" = switch(field, - "scientific" = "SCIENTIFICNAME", - "common" = "COMMONNAME", - "mnemonic" = "MNEMONIC"), - "searchType" = switch(search_type, - "equal_to" = "EQUALSTO", - "start_with" = "STARTSWITH", - "end_with" = "ENDSWITH", - "contain" = "CONTAINS"), - pageSize = page_size, - pageNumber = page_number) + call_query <- list( + "name" = name, + "fieldName" = switch( + field, + "scientific" = "SCIENTIFICNAME", + "common" = "COMMONNAME", + "mnemonic" = "MNEMONIC" + ), + "searchType" = switch( + search_type, + "equal_to" = "EQUALSTO", + "start_with" = "STARTSWITH", + "end_with" = "ENDSWITH", + "contain" = "CONTAINS" + ), + pageSize = page_size, + pageNumber = page_number + ) + ## Build Function-Specific Call - path_input <- sprintf("%staxonomy/name/%s", - .rba_stg("uniprot", "pth"), - name) + path_input <- sprintf( + "%staxonomy/name/%s", + .rba_stg("uniprot", "pth"), + name + ) + if (isTRUE(node_only)) { path_input <- paste0(path_input, "/node") } - parser_input <- ifelse(node_only, - yes = "json->list_simp", - no = "json->list") - - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_taxonomy_name.json")) + + parser_input <- ifelse( + node_only, + yes = "json->list_simp", + no = "json->list" + ) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_taxonomy_name.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -443,34 +483,34 @@ rba_uniprot_taxonomy_path <- function(id, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "id", - class = "numeric"), - list(arg = "direction", - class = "character", - val = c("TOP", - "BOTTOM")), - list(arg = "depth", - class = "numeric", - ran = c(1,5)))) - - .msg("Retrieving the %s steps of nodes that are in the %s of %s node.", - depth, direction, id) + .rba_args( + cons = list( + list(arg = "id", class = "numeric"), + list(arg = "direction", class = "character", val = c("TOP", "BOTTOM")), + list(arg = "depth", class = "numeric", ran = c(1,5)) + ) + ) + + .msg( + "Retrieving the %s steps of nodes that are in the %s of %s node.", + depth, direction, id + ) ## Build GET API Request's query - call_query <- list("id" = id, - "direction" = direction, - "depth" = depth) + call_query <- list("id" = id, "direction" = direction, "depth" = depth) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "taxonomy/path"), - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_taxonomy_path.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "taxonomy/path"), + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_taxonomy_path.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -523,29 +563,33 @@ rba_uniprot_taxonomy_relationship <- function(from, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "from", - class = "numeric"), - list(arg = "to", - class = "numeric")) + .rba_args( + cons = list( + list(arg = "from", class = "numeric"), + list(arg = "to", class = "numeric") + ) ) - .msg("Retrieving the shortest path on the toxonomy tree from node %s to %s.", - from, to) + .msg( + "Retrieving the shortest path on the toxonomy tree from node %s to %s.", + from, to + ) ## Build GET API Request's query - call_query <- list("from" = from, - "to" = to) + call_query <- list("from" = from, "to" = to) ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "taxonomy/relationship"), - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_taxonomy_relationship.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "taxonomy/relationship"), + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_taxonomy_relationship.json") + ) ## Call API final_output <- .rba_skeleton(input_call) diff --git a/R/uniprot_uniparc.R b/R/uniprot_uniparc.R index f1ae3f56..afdeff9f 100644 --- a/R/uniprot_uniparc.R +++ b/R/uniprot_uniparc.R @@ -115,134 +115,69 @@ rba_uniprot_uniparc_search <- function(upi = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "upi", - class = "character", - max_len = 100), - list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "db_type", - class = "character"), - list(arg = "db_id", - class = "character"), - list(arg = "gene", - class = "character", - max_len = 20), - list(arg = "protein", - class = "character", - len = 1), - list(arg = "taxid", - class = "character", - max_len = 20), - list(arg = "organism", - class = "character"), - list(arg = "sequence_checksum", - class = "character"), - list(arg = "ipr", - class = "character", - max_len = 100), - list(arg = "signature_db", - class = "character", - max_len = 13), - list(arg = "upid", - class = "character", - max_len = 100), - list(arg = "seq_length", - class = "character"), - list(arg = "rf_dd_type", - class = "character"), - list(arg = "rf_db_id", - class = "character"), - list(arg = "rf_active", - class = "logical"), - list(arg = "rf_tax_id", - class = "character")) + .rba_args( + cons = list( + list(arg = "upi", class = "character", max_len = 100), + list(arg = "accession", class = "character", max_len = 100), + list(arg = "db_type", class = "character"), + list(arg = "db_id", class = "character"), + list(arg = "gene", class = "character", max_len = 20), + list(arg = "protein", class = "character", len = 1), + list(arg = "taxid", class = "character", max_len = 20), + list(arg = "organism", class = "character"), + list(arg = "sequence_checksum", class = "character"), + list(arg = "ipr", class = "character", max_len = 100), + list(arg = "signature_db", class = "character", max_len = 13), + list(arg = "upid", class = "character", max_len = 100), + list(arg = "seq_length", class = "character"), + list(arg = "rf_dd_type", class = "character"), + list(arg = "rf_db_id", class = "character"), + list(arg = "rf_active", class = "logical"), + list(arg = "rf_tax_id", class = "character") + ) + ) + + .msg( + "Searching UniParc and retrieving entries that match your supplied inputs." ) - .msg("Searching UniParc and retrieving entries that match your supplied inputs.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("upi", - !is.null(upi), - paste0(upi, - collapse = ",")), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("dbtype", - !is.null(db_type), - db_type), - list("dbid", - !is.null(db_id), - paste0(db_id, - collapse = ",")), - list("gene", - !is.null(gene), - paste0(gene, - collapse = ",")), - list("protein", - !is.null(protein), - protein), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ",")), - list("organism", - !is.null(organism), - organism), - list("sequencechecksum", - !is.null(sequence_checksum), - sequence_checksum), - list("ipr", - !is.null(ipr), - paste0(ipr, - collapse = ",")), - list("signaturetype", - !is.null(signature_db), - paste0(signature_db, - collapse = ",")), - list("signatureid", - !is.null(signature_id), - paste0(signature_id, - collapse = ",")), - list("upid", - !is.null(upid), - paste0(upid, - collapse = ",")), - list("seqLength", - !is.null(seq_length), - seq_length), - list("rfDdtype", - !is.null(rf_dd_type), - paste0(rf_dd_type, - collapse = ",")), - list("rfDbid", - !is.null(rf_db_id), - paste0(rf_db_id, - collapse = ",")), - list("rfActive", - !is.null(rf_active), - ifelse(rf_active, - "true", - "false")), - list("rfTaxId", - !is.null(rf_tax_id), - paste0(rf_tax_id, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("upi", !is.null(upi), paste0(upi, collapse = ",")), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("dbtype", !is.null(db_type), db_type), + list("dbid", !is.null(db_id), paste0(db_id, collapse = ",")), + list("gene", !is.null(gene), paste0(gene, collapse = ",")), + list("protein", !is.null(protein), protein), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")), + list("organism", !is.null(organism), organism), + list("sequencechecksum", !is.null(sequence_checksum), sequence_checksum), + list("ipr", !is.null(ipr), paste0(ipr, collapse = ",")), + list("signaturetype", !is.null(signature_db), paste0(signature_db, collapse = ",")), + list("signatureid", !is.null(signature_id), paste0(signature_id, collapse = ",")), + list("upid", !is.null(upid), paste0(upid, collapse = ",")), + list("seqLength", !is.null(seq_length), seq_length), + list("rfDdtype", !is.null(rf_dd_type), paste0(rf_dd_type, collapse = ",")), + list("rfDbid", !is.null(rf_db_id), paste0(rf_db_id, collapse = ",")), + list("rfActive", !is.null(rf_active), ifelse(rf_active, "true", "false")), + list("rfTaxId", !is.null(rf_tax_id), paste0(rf_tax_id, collapse = ",")) + ) + ## Build Function-Specific Call - parser_input <- list("json->list", - .rba_uniprot_search_namer) + parser_input <- list("json->list", .rba_uniprot_search_namer) - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "uniparc"), - query = call_query, - accept = "application/json", - parser = parser_input, - save_to = .rba_file("uniprot_uniparc_search.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "uniparc"), + query = call_query, + accept = "application/json", + parser = parser_input, + save_to = .rba_file("uniprot_uniparc_search.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -326,77 +261,68 @@ rba_uniprot_uniparc <- function(upi = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "accession", - class = "character"), - list(arg = "db_id", - class = "character"), - list(arg = "upid", - class = "character"), - list(arg = "upi", - class = "character"), - list(arg = "rf_dd_type", - class = "character"), - list(arg = "rf_db_id", - class = "character"), - list(arg = "rf_active", - class = "logical"), - list(arg = "rf_tax_id", - class = "character")), - cond = list(list(quote(sum(!is.null(accession), !is.null(db_id), !is.null(upid), !is.null(upi)) != 1), - "Please supply -only- one of the arguments 'accession', 'db_id', 'upid' or 'upi'.")) + .rba_args( + cons = list( + list(arg = "accession", class = "character"), + list(arg = "db_id", class = "character"), + list(arg = "upid", class = "character"), + list(arg = "upi", class = "character"), + list(arg = "rf_dd_type", class = "character"), + list(arg = "rf_db_id", class = "character"), + list(arg = "rf_active", class = "logical"), + list(arg = "rf_tax_id", class = "character") + ), + cond = list( + list( + quote(sum(!is.null(accession), !is.null(db_id), !is.null(upid), !is.null(upi)) != 1), + "Please supply -only- one of the arguments 'accession', 'db_id', 'upid' or 'upi'." + ) + ) ) - .msg("Retriving UniParc entry with %s.", - if (!is.null(accession)) {paste0("UniProt accession ", accession) - } else if (!is.null(db_id)) { - path_input <- paste0("cross-reference database ID ", accession) - } else if (!is.null(upid)) { - path_input <- paste0("UniProt Proteome ID ", accession) - } else if (!is.null(upi)) { - path_input <- paste0("UniParc ID ", accession) - }) + .msg( + "Retriving UniParc entry with %s.", + if (!is.null(accession)) {paste0("UniProt accession ", accession) + } else if (!is.null(db_id)) { + path_input <- paste0("cross-reference database ID ", accession) + } else if (!is.null(upid)) { + path_input <- paste0("UniProt Proteome ID ", accession) + } else if (!is.null(upi)) { + path_input <- paste0("UniParc ID ", accession) + } + ) ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("rfDdtype", - !is.null(rf_dd_type), - paste0(rf_dd_type, - collapse = ",")), - list("rfDbid", - !is.null(rf_db_id), - paste0(rf_db_id, - collapse = ",")), - list("rfActive", - !is.null(rf_active), - ifelse(rf_active, - "true", - "false")), - list("rfTaxId", - !is.null(rf_tax_id), - paste0(rf_tax_id, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("rfDdtype", !is.null(rf_dd_type), paste0(rf_dd_type, collapse = ",")), + list("rfDbid", !is.null(rf_db_id), paste0(rf_db_id, collapse = ",")), + list("rfActive", !is.null(rf_active), ifelse(rf_active, "true", "false")), + list("rfTaxId", !is.null(rf_tax_id), paste0(rf_tax_id, collapse = ",")) + ) + ## Build Function-Specific Call if (!is.null(accession)) { - path_input <- paste0(.rba_stg("uniprot", "pth"), - "uniparc/accession/", accession) + path_input <- paste0(.rba_stg("uniprot", "pth"), "uniparc/accession/", accession) } else if (!is.null(db_id)) { - path_input <- paste0(.rba_stg("uniprot", "pth"), - "uniparc/dbreference/", db_id) + path_input <- paste0(.rba_stg("uniprot", "pth"), "uniparc/dbreference/", db_id) } else if (!is.null(upid)) { - path_input <- paste0(.rba_stg("uniprot", "pth"), - "uniparc/proteome/", upid) + path_input <- paste0(.rba_stg("uniprot", "pth"),"uniparc/proteome/", upid) } else if (!is.null(upi)) { - path_input <- paste0(.rba_stg("uniprot", "pth"), - "uniparc/upi/", upi) + path_input <- paste0(.rba_stg("uniprot", "pth"), "uniparc/upi/", upi) } - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = path_input, - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_uniparc.json")) + + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = path_input, + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_uniparc.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -459,55 +385,42 @@ rba_uniprot_uniparc_bestguess <- function(upi = NULL, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "upi", - class = "character", - max_len = 100), - list(arg = "accession", - class = "character", - max_len = 100), - list(arg = "db_id", - class = "character"), - list(arg = "gene", - class = "character", - max_len = 20), - list(arg = "taxid", - class = "character", - max_len = 20)) + .rba_args( + cons = list( + list(arg = "upi", class = "character", max_len = 100), + list(arg = "accession", class = "character", max_len = 100), + list(arg = "db_id", class = "character"), + list(arg = "gene", class = "character", max_len = 20), + list(arg = "taxid", class = "character", max_len = 20) + ) + ) + + .msg( + "Retrieving UniParc longest Sequence." ) - .msg("Retrieving UniParc longest Sequence.") ## Build GET API Request's query - call_query <- .rba_query(init = list("size" = "-1"), - list("upi", - !is.null(upi), - paste0(upi, - collapse = ",")), - list("accession", - !is.null(accession), - paste0(accession, - collapse = ",")), - list("dbid", - !is.null(db_id), - paste0(db_id, - collapse = ",")), - list("gene", - !is.null(gene), - paste0(gene, - collapse = ",")), - list("taxid", - !is.null(taxid), - paste0(taxid, - collapse = ","))) + call_query <- .rba_query( + init = list("size" = "-1"), + list("upi", !is.null(upi), paste0(upi, collapse = ",")), + list("accession", !is.null(accession), paste0(accession, collapse = ",")), + list("dbid", !is.null(db_id), paste0(db_id, collapse = ",")), + list("gene", !is.null(gene), paste0(gene, collapse = ",")), + list("taxid", !is.null(taxid), paste0(taxid, collapse = ",")) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "get", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "uniparc/bestguess"), - query = call_query, - accept = "application/json", - parser = "json->list", - save_to = .rba_file("uniprot_uniparc_bestguess.json")) + input_call <- .rba_httr( + httr = "get", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "uniparc/bestguess"), + query = call_query, + accept = "application/json", + parser = "json->list", + save_to = .rba_file("uniprot_uniparc_bestguess.json") + ) ## Call API final_output <- .rba_skeleton(input_call) @@ -574,47 +487,43 @@ rba_uniprot_uniparc_sequence <- function(sequence, ...) { ## Load Global Options .rba_ext_args(...) + ## Check User-input Arguments - .rba_args(cons = list(list(arg = "rf_dd_type", - class = "character"), - list(arg = "rf_db_id", - class = "character"), - list(arg = "rf_active", - class = "logical"), - list(arg = "rf_tax_id", - class = "character"))) + .rba_args( + cons = list( + list(arg = "rf_dd_type", class = "character"), + list(arg = "rf_db_id", class = "character"), + list(arg = "rf_active", class = "logical"), + list(arg = "rf_tax_id", class = "character") + ) + ) + + .msg( + "Retrieving UniParc entry that corresspond to your procided sequence." + ) - .msg("Retrieving UniParc entry that corresspond to your procided sequence.") ## Build GET API Request's query - call_query <- .rba_query(init = list(), - list("rfDdtype", - !is.null(rf_dd_type), - paste0(rf_dd_type, - collapse = ",")), - list("rfDbid", - !is.null(rf_db_id), - paste0(rf_db_id, - collapse = ",")), - list("rfActive", - !is.null(rf_active), - ifelse(rf_active, - "true", - "false")), - list("rfTaxId", - !is.null(rf_tax_id), - paste0(rf_tax_id, - collapse = ","))) + call_query <- .rba_query( + init = list(), + list("rfDdtype", !is.null(rf_dd_type), paste0(rf_dd_type, collapse = ",")), + list("rfDbid", !is.null(rf_db_id), paste0(rf_db_id, collapse = ",")), + list("rfActive", !is.null(rf_active), ifelse(rf_active, "true", "false")), + list("rfTaxId", !is.null(rf_tax_id), paste0(rf_tax_id, collapse = ",")) + ) + ## Build Function-Specific Call - input_call <- .rba_httr(httr = "post", - url = .rba_stg("uniprot", "url"), - path = paste0(.rba_stg("uniprot", "pth"), - "uniparc/sequence"), - query = call_query, - body = sequence, - accept = "application/json", - httr::content_type("text/plain"), - parser = "json->list", - save_to = .rba_file("uniprot_uniparc_sequence.json")) + input_call <- .rba_httr( + httr = "post", + url = .rba_stg("uniprot", "url"), + path = paste0(.rba_stg("uniprot", "pth"), "uniparc/sequence"), + query = call_query, + body = sequence, + accept = "application/json", + httr::content_type("text/plain"), + parser = "json->list", + save_to = .rba_file("uniprot_uniparc_sequence.json") + ) + ## Call API final_output <- .rba_skeleton(input_call) return(final_output) diff --git a/R/zzz.R b/R/zzz.R index a77c9ed7..c0e96bdb 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -15,34 +15,39 @@ "_PACKAGE" .onLoad <- function(libname, pkgname) { - options(rba_timeout = 90, - rba_dir_name = "rbioapi", - rba_diagnostics = FALSE, - rba_retry_max = 0, - rba_progress = FALSE, - rba_save_file = FALSE, - rba_skip_error = !interactive(), - rba_user_agent = "rbioapi_R_package_", - rba_verbose = TRUE, - rba_retry_wait = 10, - rba_user_options = c(rba_diagnostics = "diagnostics", - rba_dir_name = "dir_name", - rba_progress = "progress", - rba_retry_max = "retry_max", - rba_retry_wait = "retry_wait", - rba_save_file = "save_file", - rba_skip_error = "skip_error", - rba_timeout = "timeout", - rba_verbose = "verbose"), - rba_user_options_allowed = c(rba_diagnostics = "Logical (TRUE/FALSE)", - rba_dir_name = "Character", - rba_progress = "Logical (TRUE/FALSE)", - rba_retry_max = "Numeric (0 or greater)", - rba_retry_wait = "Numeric (0 or greater)", - rba_save_file = "Logical (TRUE/FALSE)", - rba_skip_error = "Logical (TRUE/FALSE)", - rba_timeout = "Numeric (0.1 or greater)", - rba_verbose = "Logical (TRUE/FALSE)") + options( + rba_timeout = 90, + rba_dir_name = "rbioapi", + rba_diagnostics = FALSE, + rba_retry_max = 0, + rba_progress = FALSE, + rba_save_file = FALSE, + rba_skip_error = !interactive(), + rba_user_agent = "rbioapi_R_package_", + rba_verbose = TRUE, + rba_retry_wait = 10, + rba_user_options = c( + rba_diagnostics = "diagnostics", + rba_dir_name = "dir_name", + rba_progress = "progress", + rba_retry_max = "retry_max", + rba_retry_wait = "retry_wait", + rba_save_file = "save_file", + rba_skip_error = "skip_error", + rba_timeout = "timeout", + rba_verbose = "verbose" + ), + rba_user_options_allowed = c( + rba_diagnostics = "Logical (TRUE/FALSE)", + rba_dir_name = "Character", + rba_progress = "Logical (TRUE/FALSE)", + rba_retry_max = "Numeric (0 or greater)", + rba_retry_wait = "Numeric (0 or greater)", + rba_save_file = "Logical (TRUE/FALSE)", + rba_skip_error = "Logical (TRUE/FALSE)", + rba_timeout = "Numeric (0.1 or greater)", + rba_verbose = "Logical (TRUE/FALSE)" + ) ) invisible() } diff --git a/tests/testthat/helper_expects.R b/tests/testthat/helper_expects.R index a3749c0e..4aaaee97 100644 --- a/tests/testthat/helper_expects.R +++ b/tests/testthat/helper_expects.R @@ -1,17 +1,23 @@ expect_list_classes <- function(obj, classes) { stopifnot(inherits(obj, "list")) - obj_classes <- vapply(X = obj, - FUN = function(x) {class(x)}, - FUN.VALUE = character(1), - USE.NAMES = FALSE) + obj_classes <- vapply( + X = obj, + FUN = function(x) { + class(x) + }, + FUN.VALUE = character(1), + USE.NAMES = FALSE + ) if (identical(obj_classes, classes)) { testthat::succeed() return(invisible(obj_classes)) } else { - testthat::fail(sprintf("objects elements' classes are: %s but expected classes are: %s", - paste0(obj_classes, collapse = ", "), paste0(classes, collapse = ", "))) + testthat::fail(sprintf( + "objects elements' classes are: %s but expected classes are: %s", + paste0(obj_classes, collapse = ", "), paste0(classes, collapse = ", ") + )) } } @@ -24,40 +30,47 @@ expect_call_regex <- function(obj, pattern, ...) { testthat::succeed() return(invisible(out)) } else { - testthat::fail(sprintf("The regex pattern \"%s\" did not match the call object:\n \"%s\"", - pattern, obj)) + testthat::fail(sprintf( + "The regex pattern \"%s\" did not match the call object:\n \"%s\"", + pattern, obj + )) } - } expect_regex <- function(obj, pattern, invert = FALSE, ...) { - out <- vapply(X = obj, - FUN = function(x,...) { - grepl(pattern = pattern, x = x, ...)}, - FUN.VALUE = logical(1), - USE.NAMES = FALSE, - ...) - if (invert) {out <- !out} + out <- vapply( + X = obj, + FUN = function(x, ...) { + grepl(pattern = pattern, x = x, ...) + }, + FUN.VALUE = logical(1), + USE.NAMES = FALSE, + ... + ) + if (invert) { + out <- !out + } if (all(out)) { testthat::succeed() return(invisible(out)) } else { - testthat::fail(sprintf("The regex pattern \"%s\" did not match the string vector:\n \"%s\"", - pattern, paste0(obj, collapse = ", "))) + testthat::fail(sprintf( + "The regex pattern \"%s\" did not match the string vector:\n \"%s\"", + pattern, paste0(obj, collapse = ", ") + )) } - } expect_class <- function(obj, expected, ...) { - if (inherits(obj, expected)) { testthat::succeed() return(invisible(class(obj))) } else { - testthat::fail(sprintf("Your object's class is `%s`` but `%s`` is expected.", - class(obj), expected)) + testthat::fail(sprintf( + "Your object's class is `%s`` but `%s`` is expected.", + class(obj), expected + )) } - } expect_has_names <- function(obj, expected) { @@ -67,49 +80,53 @@ expect_has_names <- function(obj, expected) { testthat::succeed() return(invisible(expected)) } else { - testthat::fail(sprintf("The names does not match:\n names in object but not expected: %s\n expected name not in object: %s", - paste0(in_obj_not_expected, collapse = ", "), - paste0(in_expected_not_obj, collapse = ", "))) + testthat::fail(sprintf( + "The names does not match:\n names in object but not expected: %s\n expected name not in object: %s", + paste0(in_obj_not_expected, collapse = ", "), + paste0(in_expected_not_obj, collapse = ", ") + )) } - } expect_na <- function(obj) { - if (all(is.na(obj))) { testthat::succeed() return(invisible(TRUE)) } else { testthat::fail("The object contain non-NA elements..") } - } expect_error2 <- function(obj, pattern = NULL, invert = FALSE, ...) { obj <- try(obj, - silent = TRUE) + silent = TRUE + ) if (inherits(obj, "try-error")) { if (is.null(pattern)) { testthat::succeed() return(invisible(TRUE)) } else { - out <- vapply(X = pattern, - FUN = function(patt) { - grepl(pattern = patt, x = obj, ...) - }, - FUN.VALUE = logical(1)) - if (invert) {out <- !out} + out <- vapply( + X = pattern, + FUN = function(patt) { + grepl(pattern = patt, x = obj, ...) + }, + FUN.VALUE = logical(1) + ) + if (invert) { + out <- !out + } if (all(out)) { testthat::succeed() return(invisible(out)) } else { - testthat::fail(sprintf("Error was prodced but the regex pattern(s) %s didn't match.", - which(!out))) + testthat::fail(sprintf( + "Error was prodced but the regex pattern(s) %s didn't match.", + which(!out) + )) } } - } else { testthat::fail("obj runs with no error.") } - } diff --git a/tests/testthat/test-api_calls_rba_httr.R b/tests/testthat/test-api_calls_rba_httr.R index 02de9ab8..0ef69ce0 100644 --- a/tests/testthat/test-api_calls_rba_httr.R +++ b/tests/testthat/test-api_calls_rba_httr.R @@ -1,28 +1,24 @@ test_that(".rba_httr return output currectly", { + # Output structure is correct - base_output <- .rba_httr(httr = "get", - url = "url_value", - path = "path_value", - accept = "accept_vale", - save_to = "save_to_value") + base_output <- .rba_httr( + httr = "get", + url = "url_value", + path = "path_value", + accept = "accept_vale", + save_to = "save_to_value" + ) + + expect_named(object = base_output, expected = c("call", "parser")) - expect_named(object = base_output, - expected = c("call", "parser")) + expect_list_classes(obj = base_output, classes = c("call", "function")) - expect_list_classes(obj = base_output, - classes = c("call", "function")) # Call is correct - expect_call_regex(obj = base_output$call, - pattern = "^httr::(GET|POST|HEAD)") - expect_call_regex(obj = base_output$call, - pattern = "url\\s*=\\s*\"url_value\"") - expect_call_regex(obj = base_output$call, - pattern = "path\\s*=\\s*\"path_value\"") - expect_call_regex(obj = base_output$call, - pattern = "httr::timeout\\(timeout\\)") - expect_call_regex(obj = base_output$call, - pattern = "httr::accept\\(\"accept_vale\"\\)") - expect_call_regex(obj = base_output$call, - pattern = "httr::write_disk\\(\"save_to_value\".*\\)") + expect_call_regex(obj = base_output$call, pattern = "^httr::(GET|POST|HEAD)") + expect_call_regex(obj = base_output$call, pattern = "url\\s*=\\s*\"url_value\"") + expect_call_regex(obj = base_output$call, pattern = "path\\s*=\\s*\"path_value\"") + expect_call_regex(obj = base_output$call, pattern = "httr::timeout\\(timeout\\)") + expect_call_regex(obj = base_output$call, pattern = "httr::accept\\(\"accept_vale\"\\)") + expect_call_regex(obj = base_output$call, pattern = "httr::write_disk\\(\"save_to_value\".*\\)") }) diff --git a/tests/testthat/test-api_calls_rba_query.R b/tests/testthat/test-api_calls_rba_query.R index 49e00299..25847205 100644 --- a/tests/testthat/test-api_calls_rba_query.R +++ b/tests/testthat/test-api_calls_rba_query.R @@ -1,33 +1,38 @@ test_that(".rba_query works", { + # Init properly - expect_identical(object = .rba_query(init = list()), - expected = list()) + expect_identical( + object = .rba_query(init = list()), + expected = list() + ) - expect_named(object = .rba_query(init = list(), - list("par3", - TRUE, - 1)), - expected = "par3") + expect_named( + object = .rba_query(init = list(), list("par3", TRUE, 1)), + expected = "par3" + ) # Add properly - init_input <- list(par1 = 1, - par2 = "second_parameter") + init_input <- list(par1 = 1, par2 = "second_parameter") + + expect_identical( + object = .rba_query(init = init_input), + expected = init_input + ) - expect_identical(object = .rba_query(init = init_input), - expected = init_input) + expect_named( + object = .rba_query( + init = init_input, + list("par3", FALSE, 1), + list("par4", TRUE, 1) + ), + expected = c("par1", "par2", "par4") + ) - expect_named(object = .rba_query(init = init_input, - list("par3", - FALSE, - 1), - list("par4", - TRUE, - 1)), - expected = c("par1", "par2", "par4")) + expect_identical( + object = .rba_query( + init = list(), + list("par3", TRUE, 1))[["par3"]], + expected = 1 + ) - expect_identical(object = .rba_query(init = list(), - list("par3", - TRUE, - 1))[["par3"]], - expected = 1) }) diff --git a/tests/testthat/test-arguments_check_rba_args.R b/tests/testthat/test-arguments_check_rba_args.R index 8e04c5bb..45ed8ebe 100644 --- a/tests/testthat/test-arguments_check_rba_args.R +++ b/tests/testthat/test-arguments_check_rba_args.R @@ -1,4 +1,5 @@ test_that(".rba_args works", { + .rba_args_nested <- function(cons = NULL, cond = NULL, cond_warning = FALSE, @@ -8,82 +9,111 @@ test_that(".rba_args works", { assign(x = names(ext_args)[[i]], value = ext_args[[i]]) } - .rba_args(cons = cons, cond = cond, cond_warning = cond_warning)} + .rba_args(cons = cons, cond = cond, cond_warning = cond_warning) + } + + cons_correct <- list( + list(arg = "arg1", class = "numeric"), + list(arg = "arg2", class = "logical") + ) - cons_correct <- list(list(arg = "arg1", - class = "numeric"), - list(arg = "arg2", - class = "logical")) - cons_incorrect <- list(list(arg = "arg1", - class = "logical"), - list(arg = "arg2", - class = "logical")) - cond_input <- list(list(quote(bg < sml), - "bigger < smaller")) + cons_incorrect <- list( + list(arg = "arg1", class = "logical"), + list(arg = "arg2", class = "logical") + ) + cond_input <- list( + list(quote(bg < sml), "bigger < smaller") + ) # Runs without any side effects if no argument error was found expect_invisible(call = .rba_args_nested()) - expect_invisible(call = .rba_args_nested(cons = cons_correct, - arg1 = 1, - arg2 = TRUE)) - expect_invisible(call = .rba_args_nested(cond = cond_input, - bg = 2, - sml = 1)) + expect_invisible( + call = .rba_args_nested(cons = cons_correct, arg1 = 1, arg2 = TRUE) + ) + expect_invisible( + call = .rba_args_nested(cond = cond_input, bg = 2, sml = 1) + ) # Detects the errors - expect_error(object = .rba_args_nested(cons = cons_incorrect, - arg1 = 1, - arg2 = TRUE)) - expect_error(object = .rba_args_nested(cond = cond_input, - bg = 1, - sml = 2)) + expect_error( + object = .rba_args_nested(cons = cons_incorrect, arg1 = 1, arg2 = TRUE) + ) + expect_error( + object = .rba_args_nested(cond = cond_input, bg = 1, sml = 2) + ) # Options appended correctly - expect_error(object = .rba_args_nested(cons = cons_correct, - arg1 = 1, - arg2 = TRUE, - verbose = 123), - regexp = "verbose") - expect_error(object = .rba_args_nested(cons = cons_correct, - arg1 = 1, - arg2 = TRUE, - save_file = "qwerty"), - regexp = "save_file") + expect_error( + object = .rba_args_nested( + cons = cons_correct, + arg1 = 1, + arg2 = TRUE, + verbose = 123 + ), + regexp = "verbose" + ) + expect_error( + object = .rba_args_nested(cons = cons_correct, + arg1 = 1, + arg2 = TRUE, + save_file = "qwerty" + ), + regexp = "save_file" + ) # Create error if arg does not exist - expect_error(object = .rba_args_nested(cons = list(list(arg = "arg22", - class = "logical"))), - regexp = "arg22") + expect_error( + object = .rba_args_nested( + cons = list( + list(arg = "arg22", class = "logical") + ) + ), + regexp = "arg22" + ) # Drops the argument if class is not correct - expect_error2(obj = .rba_args_nested(cons = list(list(arg = "arg1", - class = "character", - regex = "^222$")), - arg1 = 111), - pattern = "222", invert = TRUE) + expect_error2( + obj = .rba_args_nested( + cons = list( + list(arg = "arg1", class = "character", regex = "^222$") + ), + arg1 = 111 + ), + pattern = "222", + invert = TRUE + ) # Collects every error and issues them at once - expect_error2(obj = .rba_args_nested(cons = list(list(arg = "arg1", - class = "character"), - list(arg = "arg2", - class = "numeric", - min_val = 100), - list(arg = "arg_missing", - class = "numeric")), - arg1 = 10, - arg2 = 50), - pattern = c("arg1", "arg2", "arg_missing")) + expect_error2( + obj = .rba_args_nested( + cons = list( + list(arg = "arg1", class = "character"), + list(arg = "arg2", class = "numeric", min_val = 100), + list(arg = "arg_missing", class = "numeric") + ), + arg1 = 10, + arg2 = 50 + ), + pattern = c("arg1", "arg2", "arg_missing") + ) # Warnings are respected - expect_warning(object = .rba_args_nested(cond = cond_input, - cond_warning = TRUE, - bg = 1, - sml = 2)) - cond_input <- list(list(quote(bg < sml), - "bigger < smaller", - warn = TRUE)) - expect_warning(object = .rba_args_nested(cond = cond_input, - bg = 1, - sml = 2)) + expect_warning( + object = .rba_args_nested( + cond = cond_input, + cond_warning = TRUE, + bg = 1, + sml = 2 + ) + ) + cond_input <- list( + list( + quote(bg < sml), + "bigger < smaller", + warn = TRUE) + ) + expect_warning( + object = .rba_args_nested(cond = cond_input, bg = 1, sml = 2) + ) }) diff --git a/tests/testthat/test-arguments_check_rba_args_cond.R b/tests/testthat/test-arguments_check_rba_args_cond.R index de917c71..18def07d 100644 --- a/tests/testthat/test-arguments_check_rba_args_cond.R +++ b/tests/testthat/test-arguments_check_rba_args_cond.R @@ -1,4 +1,5 @@ test_that(".rba_args_cond works", { + .rba_args_cond_nested <- function(...) { x <- 1 y <- 2 @@ -10,39 +11,47 @@ test_that(".rba_args_cond works", { } .rba_args_cond_nested2(...) } + # The the format is checked: - expect_error(object = .rba_args_cond_nested(cond_i = list(TRUE))) - expect_error(object = .rba_args_cond_nested(cond_i = list(quote(x < y), - "sfsdf", - TRUE, - "dsf"))) - expect_list_classes(obj = .rba_args_cond_nested(cond_i = list(quote(x < y))), - classes = c("character", "logical")) - expect_list_classes(obj = .rba_args_cond_nested(cond_i = list("x < y")), - classes = c("character", "logical")) + expect_error( + object = .rba_args_cond_nested(cond_i = list(TRUE)) + ) + + expect_error( + object = .rba_args_cond_nested( + cond_i = list(quote(x < y), "sfsdf", TRUE, "dsf") + ) + ) + + expect_list_classes( + obj = .rba_args_cond_nested(cond_i = list(quote(x < y))), + classes = c("character", "logical") + ) + expect_list_classes( + obj = .rba_args_cond_nested(cond_i = list("x < y")), + classes = c("character", "logical") + ) ## Different cond_i types work # Condition with length 1 (checked above) # Condition with length 2, second element is message - cond_i_l2_msg <- .rba_args_cond_nested(cond_i = list(quote(x < y), - "error_msg") ) + cond_i_l2_msg <- .rba_args_cond_nested( + cond_i = list(quote(x < y), "error_msg") + ) + expect_list_classes(obj = cond_i_l2_msg, classes = c("character", "logical")) expect_regex(obj = cond_i_l2_msg[[1]], pattern = "error_msg") expect_false(object = cond_i_l2_msg[[2]]) # Condition with length 2, second element is warning switch - cond_i_l2_warn <- .rba_args_cond_nested(cond_i = list(quote(x < y), - TRUE)) + cond_i_l2_warn <- .rba_args_cond_nested(cond_i = list(quote(x < y), TRUE)) expect_list_classes(obj = cond_i_l2_warn, classes = c("character", "logical")) expect_true(object = cond_i_l2_warn[[2]]) # Condition with length 3 - cond_i_l3 <- .rba_args_cond_nested(cond_i = list(quote(x < y), - "error_msg", - TRUE)) + cond_i_l3 <- .rba_args_cond_nested(cond_i = list(quote(x < y), "error_msg", TRUE)) expect_list_classes(obj = cond_i_l3, classes = c("character", "logical")) expect_regex(obj = cond_i_l3[[1]], pattern = "error_msg") expect_true(object = cond_i_l3[[2]]) - }) diff --git a/tests/testthat/test-arguments_check_rba_args_cons_chk.R b/tests/testthat/test-arguments_check_rba_args_cons_chk.R index 7bf07d9a..e1671e29 100644 --- a/tests/testthat/test-arguments_check_rba_args_cons_chk.R +++ b/tests/testthat/test-arguments_check_rba_args_cons_chk.R @@ -1,48 +1,64 @@ test_that(".rba_args_cons_chk works", { + # Skip NULL args - expect_true(object = .rba_args_cons_chk(cons_i = list(evl_arg = NULL), - what = "class")) + expect_true( + object = .rba_args_cons_chk(cons_i = list(evl_arg = NULL), what = "class") + ) # Produce error for wrong constrains - expect_error(object = .rba_args_cons_chk(cons_i = list(evl_arg = "string"), - what = "qwer")) + expect_error( + object = .rba_args_cons_chk(cons_i = list(evl_arg = "string"), what = "qwer") + ) # Detect correct values - cons_i_correct <- list(arg = "arg_X", - evl_arg = 111, - class = "numeric", - val = c(111, 222, 333), - ran = c(110,112), - len = 1, - min_len = 1, - max_len = 1, - min_val = 111, - max_val = 111, - regex = "^111$") + cons_i_correct <- list( + arg = "arg_X", + evl_arg = 111, + class = "numeric", + val = c(111, 222, 333), + ran = c(110,112), + len = 1, + min_len = 1, + max_len = 1, + min_val = 111, + max_val = 111, + regex = "^111$" + ) - expect_true(object = all(vapply(X = names(cons_i_correct)[3:length(cons_i_correct)], - FUN = function(x) { - .rba_args_cons_chk(cons_i = cons_i_correct, - what = x) - }, - FUN.VALUE = logical(1)))) + expect_true(object = all( + vapply( + X = names(cons_i_correct)[3:length(cons_i_correct)], + FUN = function(x) { + .rba_args_cons_chk(cons_i = cons_i_correct, + what = x) + }, + FUN.VALUE = logical(1) + ) + )) # Detect incorrect values - cons_i_incorrect <- list(arg = "arg_X", - evl_arg = 111, - class = "character", - val = c(222, 333), - ran = c(112,113), - len = 3, - min_len = 2, - max_len = 0, - min_val = 112, - max_val = 110, - regex = "^$") + cons_i_incorrect <- list( + arg = "arg_X", + evl_arg = 111, + class = "character", + val = c(222, 333), + ran = c(112,113), + len = 3, + min_len = 2, + max_len = 0, + min_val = 112, + max_val = 110, + regex = "^$" + ) + + expect_true(object = all( + !vapply( + X = names(cons_i_incorrect)[3:length(cons_i_incorrect)], + FUN = function(x) { + .rba_args_cons_chk(cons_i = cons_i_incorrect, + what = x) + }, + FUN.VALUE = logical(1) + ) + )) - expect_true(object = all(!vapply(X = names(cons_i_incorrect)[3:length(cons_i_incorrect)], - FUN = function(x) { - .rba_args_cons_chk(cons_i = cons_i_incorrect, - what = x) - }, - FUN.VALUE = logical(1)))) }) diff --git a/tests/testthat/test-arguments_check_rba_args_cons_msg.R b/tests/testthat/test-arguments_check_rba_args_cons_msg.R index 1031af5d..e94a18ca 100644 --- a/tests/testthat/test-arguments_check_rba_args_cons_msg.R +++ b/tests/testthat/test-arguments_check_rba_args_cons_msg.R @@ -1,22 +1,27 @@ test_that(".rba_args_cons_msg works", { + # Create messages for incorrect constrains - cons_i_incorrect <- list(arg = "arg_X", - evl_arg = 111, - class = "character", - val = c(222, 333), - ran = c(112,113), - len = 3, - min_len = 2, - max_len = 0, - min_val = 112, - max_val = 110, - regex = "^$") + cons_i_incorrect <- list( + arg = "arg_X", + evl_arg = 111, + class = "character", + val = c(222, 333), + ran = c(112,113), + len = 3, + min_len = 2, + max_len = 0, + min_val = 112, + max_val = 110, + regex = "^$" + ) + + expect_regex(obj = vapply( + X = c("no_null", names(cons_i_incorrect)[3:length(cons_i_incorrect)]), + FUN = function(x) { + .rba_args_cons_msg(cons_i = cons_i_incorrect, what = x) + }, + FUN.VALUE = character(1) + ), + pattern = "arg_X") - expect_regex(obj = vapply(X = c("no_null", names(cons_i_incorrect)[3:length(cons_i_incorrect)]), - FUN = function(x) { - .rba_args_cons_msg(cons_i = cons_i_incorrect, - what = x) - }, - FUN.VALUE = character(1)), - pattern = "arg_X") }) diff --git a/tests/testthat/test-arguments_check_rba_args_cons_wrp.R b/tests/testthat/test-arguments_check_rba_args_cons_wrp.R index 1f587b0e..dc4153c8 100644 --- a/tests/testthat/test-arguments_check_rba_args_cons_wrp.R +++ b/tests/testthat/test-arguments_check_rba_args_cons_wrp.R @@ -1,43 +1,55 @@ test_that(".rba_args_cons_wrp works", { + # Optional NULL values are ignored - cons_i_NULL <- list(arg = "arg_X", - evl_arg = NULL) + cons_i_NULL <- list(arg = "arg_X", evl_arg = NULL) expect_na(obj = .rba_args_cons_wrp(cons_i = cons_i_NULL)) # Required NULL values are not ignored - cons_i_no_NULL <- list(arg = "arg_X", - no_null = TRUE, - evl_arg = NULL) - expect_regex(obj = .rba_args_cons_wrp(cons_i = cons_i_no_NULL), - pattern = "NULL") + cons_i_no_NULL <- list( + arg = "arg_X", + no_null = TRUE, + evl_arg = NULL + ) + expect_regex( + obj = .rba_args_cons_wrp(cons_i = cons_i_no_NULL), + pattern = "NULL" + ) # Correct values are ignored - cons_i_correct <- list(arg = "arg_X", - evl_arg = 111, - class = "numeric", - val = c(111, 222, 333), - ran = c(110,112), - len = 1, - min_len = 1, - max_len = 1, - min_val = 111, - max_val = 111, - regex = "^111$") + cons_i_correct <- list( + arg = "arg_X", + evl_arg = 111, + class = "numeric", + val = c(111, 222, 333), + ran = c(110,112), + len = 1, + min_len = 1, + max_len = 1, + min_val = 111, + max_val = 111, + regex = "^111$" + ) + expect_na(obj = .rba_args_cons_wrp(cons_i_correct)) # All errors are translated into messages - cons_i_incorrect <- list(arg = "arg_X", - evl_arg = 111, - class = "character", - val = c(222, 333), - ran = c(112,113), - len = 3, - min_len = 2, - max_len = 0, - min_val = 112, - max_val = 110, - regex = "^$") - expect_length(object = .rba_args_cons_wrp(cons_i_incorrect), - n = length(setdiff(names(cons_i_incorrect), c("arg", "class", "evl_arg", "no_null")))) + cons_i_incorrect <- list( + arg = "arg_X", + evl_arg = 111, + class = "character", + val = c(222, 333), + ran = c(112,113), + len = 3, + min_len = 2, + max_len = 0, + min_val = 112, + max_val = 110, + regex = "^$" + ) + + expect_length( + object = .rba_args_cons_wrp(cons_i_incorrect), + n = length(setdiff(names(cons_i_incorrect), c("arg", "class", "evl_arg", "no_null"))) + ) }) diff --git a/tests/testthat/test-arguments_check_rba_args_opts.R b/tests/testthat/test-arguments_check_rba_args_opts.R index 06e88eec..77cfc3d1 100644 --- a/tests/testthat/test-arguments_check_rba_args_opts.R +++ b/tests/testthat/test-arguments_check_rba_args_opts.R @@ -1,4 +1,5 @@ test_that(".rba_args_opts works", { + .rba_args_opts_nested <- function(...) { dir_name <- "test" save_file <- TRUE @@ -7,8 +8,14 @@ test_that(".rba_args_opts works", { } .rba_args_opts_nested2(...) } - expect_has_names(obj = .rba_args_opts_nested(what = "cons"), - expected = c("dir_name", "save_file")) - expect_has_names(obj = .rba_args_opts_nested(what = "cond"), - expected = c("dir_name", "save_file")) + + expect_has_names( + obj = .rba_args_opts_nested(what = "cons"), + expected = c("dir_name", "save_file") + ) + expect_has_names( + obj = .rba_args_opts_nested(what = "cond"), + expected = c("dir_name", "save_file") + ) + }) diff --git a/tests/testthat/test-data_containers.R b/tests/testthat/test-data_containers.R index f1036bf7..b3669a96 100644 --- a/tests/testthat/test-data_containers.R +++ b/tests/testthat/test-data_containers.R @@ -1,9 +1,18 @@ test_that(".rba_stg works", { - expect_error(object = .rba_stg("qwerty"), regexp = NULL) - expect_type(object = .rba_stg("reactome", "pth", "analysis"), - type = "character") + expect_error( + object = .rba_stg("qwerty"), + regexp = NULL + ) + + expect_type( + object = .rba_stg("reactome", "pth", "analysis"), + type = "character" + ) + + expect_type( + object = .rba_stg("reactome", "err_prs")[[2]], + type = "closure" + ) - expect_type(object = .rba_stg("reactome", "err_prs")[[2]], - type = "closure") }) diff --git a/tests/testthat/test-elper_functions.R b/tests/testthat/test-elper_functions.R index e9e719e7..13ab677a 100644 --- a/tests/testthat/test-elper_functions.R +++ b/tests/testthat/test-elper_functions.R @@ -1,16 +1,15 @@ test_that("rba_options works", { + # Return data frame when called empty - expect_class(obj = rba_options(), - expected = "data.frame") + expect_class(obj = rba_options(),expected = "data.frame") + # Changes option rba_options(timeout = 91) expect_true(object = (getOption("rba_timeout") == 91)) # Checks arguments - expect_error(object = rba_options(verbose = 123), - regexp = "logical") - expect_error(object = rba_options(save_file = "test.txt"), - regexp = "logical") + expect_error(object = rba_options(verbose = 123), regexp = "logical") + expect_error(object = rba_options(save_file = "test.txt"), regexp = "logical") }) @@ -22,15 +21,27 @@ test_that("rba_pages works", { paste0(LETTERS[[x]], "!", collapse = "") } } + # Detects errors - expect_error(object = rba_pages(input_call = Sys.sleep(0)), - regexp = "qoute") - expect_error(object = rba_pages(input_call = quote(Sys.sleep(0))), - regexp = "rbioapi") - expect_error(object = rba_pages(input_call = quote(rba_test(3))), - regexp = "pages") - expect_error(object = rba_pages(input_call = quote(rba_test(3))), - regexp = "pages") - expect_error(object = rba_pages(input_call = quote(rba_test("pages:1:999"))), - regexp = "100") + expect_error( + object = rba_pages(input_call = Sys.sleep(0)), + regexp = "qoute" + ) + expect_error( + object = rba_pages(input_call = quote(Sys.sleep(0))), + regexp = "rbioapi" + ) + expect_error( + object = rba_pages(input_call = quote(rba_test(3))), + regexp = "pages" + ) + expect_error( + object = rba_pages(input_call = quote(rba_test(3))), + regexp = "pages" + ) + expect_error( + object = rba_pages(input_call = quote(rba_test("pages:1:999"))), + regexp = "100" + ) + }) diff --git a/tests/testthat/test-internet_connectivity.R b/tests/testthat/test-internet_connectivity.R index 5e5fc956..f11c9731 100644 --- a/tests/testthat/test-internet_connectivity.R +++ b/tests/testthat/test-internet_connectivity.R @@ -1,7 +1,16 @@ test_that(".rba_http_status works", { - expect_type(object = .rba_http_status("200", verbose = TRUE), - type = "character") - expect_regex(obj = .rba_http_status("599", verbose = TRUE), - pattern = "redirection", ignore.case = TRUE) - expect_error(object = .rba_http_status("999999", verbose = TRUE)) + + expect_type( + object = .rba_http_status("200", verbose = TRUE), + type = "character" + ) + expect_regex( + obj = .rba_http_status("599", verbose = TRUE), + pattern = "redirection", + ignore.case = TRUE + ) + expect_error( + object = .rba_http_status("999999", verbose = TRUE) + ) + }) diff --git a/tests/testthat/test-misc_msg.R b/tests/testthat/test-misc_msg.R index 3588ebef..cdcde6e2 100644 --- a/tests/testthat/test-misc_msg.R +++ b/tests/testthat/test-misc_msg.R @@ -1,4 +1,5 @@ test_that(".msg works", { + # basics verbose <- FALSE expect_silent(.msg("test")) @@ -7,13 +8,13 @@ test_that(".msg works", { verbose2 <- FALSE expect_silent(.msg("test", cond = "verbose2")) # use paste - expect_message(object = .msg("1", "2", "3"), - regexp = "123") + expect_message(object = .msg("1", "2", "3"), regexp = "123") #use sprintf - expect_message(object = .msg("1%s%s", "2", "3"), - regexp = "123") + expect_message(object = .msg("1%s%s", "2", "3"), regexp = "123") #force paste - expect_message(object = .msg("1%s%s", "2", "3", sprintf = FALSE), - regexp = "1%s%s23") + expect_message( + object = .msg("1%s%s", "2", "3", sprintf = FALSE), + regexp = "1%s%s23" + ) }) diff --git a/tests/testthat/test-misc_paste2.R b/tests/testthat/test-misc_paste2.R index fd60b495..0b857eb3 100644 --- a/tests/testthat/test-misc_paste2.R +++ b/tests/testthat/test-misc_paste2.R @@ -1,25 +1,36 @@ test_that(".paste2 works", { - expect_identical(object = .paste2(c("first", "second", "third")), - expected = "first, second and third") - expect_identical(object = .paste2(c("first", "second", "third"), - last = " or "), - expected = "first, second or third") - expect_identical(object = .paste2(c("first", "second", "third"), - sep = " + "), - expected = "first + second and third") - expect_identical(object = .paste2(c("first", "second", "third"), - quote = "`"), - expected = "`first`, `second` and `third`") - expect_identical(object = .paste2(c("first", "second", "third"), - quote_all = "`"), - expected = "`first, second and third`") + expect_identical( + object = .paste2(c("first", "second", "third")), + expected = "first, second and third" + ) - expect_identical(object = .paste2(c("first", "second", "third"), - last = " or ", - sep = " + ", - quote = "-", - quote_all = "_"), - expected = "_-first- + -second- or -third-_") + expect_identical( + object = .paste2(c("first", "second", "third"), last = " or "), + expected = "first, second or third" + ) + expect_identical( + object = .paste2(c("first", "second", "third"), sep = " + "), + expected = "first + second and third" + ) + expect_identical( + object = .paste2(c("first", "second", "third"), quote = "`"), + expected = "`first`, `second` and `third`" + ) + expect_identical( + object = .paste2(c("first", "second", "third"), quote_all = "`"), + expected = "`first, second and third`" + ) + + expect_identical( + object = .paste2( + c("first", "second", "third"), + last = " or ", + sep = " + ", + quote = "-", + quote_all = "_" + ), + expected = "_-first- + -second- or -third-_" + ) }) diff --git a/tests/testthat/test-misc_rba_ext_args.R b/tests/testthat/test-misc_rba_ext_args.R index a5b1a457..1e106eea 100644 --- a/tests/testthat/test-misc_rba_ext_args.R +++ b/tests/testthat/test-misc_rba_ext_args.R @@ -1,4 +1,5 @@ test_that(".rba_ext_args works", { + ## adds option to the environment opts <- getOption("rba_user_options") expect_false(object = length(setdiff(opts, ls())) == 0) @@ -19,8 +20,10 @@ test_that(".rba_ext_args works", { rm(list = opts) ## ignore save_file option - expect_warning(object = .rba_ext_args(save_file = TRUE, - ignore_save = TRUE), - regexp = "save_file") + expect_warning( + object = .rba_ext_args(save_file = TRUE, ignore_save = TRUE), + regexp = "save_file" + ) expect_false(object = exists("save_file")) + }) diff --git a/tests/testthat/test-misc_rba_file.R b/tests/testthat/test-misc_rba_file.R index a38c0816..a7fae7dc 100644 --- a/tests/testthat/test-misc_rba_file.R +++ b/tests/testthat/test-misc_rba_file.R @@ -1,62 +1,69 @@ test_that(".rba_file works", { + # basics - expect_false(object = .rba_file(file = "test.txt", - save_to = FALSE)) - expect_message(object = .rba_file(file = "test.txt", - save_to = TRUE), - regexp = "test\\.txt") + expect_false(object = .rba_file(file = "test.txt",save_to = FALSE)) + expect_message( + object = .rba_file(file = "test.txt", save_to = TRUE), + regexp = "test\\.txt" + ) verbose <- FALSE - expect_identical(object = .rba_file(file = "test.txt", - save_to = TRUE, - dir_name = "rbioapi_test"), - expected = file.path(getwd(), - "rbioapi_test", - "test.txt")) - ## accepts different kind of inputs - # only file name - expect_identical(object = .rba_file(file = "test.txt", - save_to = TRUE), - expected = file.path(getwd(), - getOption("rba_dir_name"), - "test.txt")) - # full path - expect_identical(object = .rba_file(file = "test.txt", - save_to = "c:/rbioapi/file.txt"), - expected = "c:/rbioapi/file.txt") - # directory path - expect_identical(object = .rba_file(file = "test.txt", - save_to = "c:/rbioapi/"), - expected = "c:/rbioapi/test.txt") + expect_identical( + object = .rba_file( + file = "test.txt", + save_to = TRUE, + dir_name = "rbioapi_test" + ), + expected = file.path(getwd(), "rbioapi_test", "test.txt") + ) + + # accepts different kind of inputs + ## only file name + expect_identical( + object = .rba_file(file = "test.txt", save_to = TRUE), + expected = file.path(getwd(), getOption("rba_dir_name"), "test.txt") + ) + ## full path + expect_identical( + object = .rba_file(file = "test.txt", save_to = "c:/rbioapi/file.txt"), + expected = "c:/rbioapi/file.txt" + ) + ## directory path + expect_identical( + object = .rba_file(file = "test.txt", save_to = "c:/rbioapi/"), + expected = "c:/rbioapi/test.txt" + ) - ## detects non_valid file paths - expect_warning(object = .rba_file(file = "test.txt", - save_to = "qwerty"), - regexp = "qwerty") - expect_warning(object = .rba_file(file = "test.txt", - save_to = "qwerty"), - regexp = "qwerty") - expect_identical(object = suppressWarnings(.rba_file(file = "test.txt", - save_to = "qwerty")), - expected = file.path(getwd(), - getOption("rba_dir_name"), - "test.txt")) - ## detects saving in wrong file extension - expect_warning(object = .rba_file(file = "test.txt", - save_to = "test.json"), - regexp = "txt") - ## increments existing file names + # detects invalid file paths + expect_warning( + object = .rba_file(file = "test.txt", save_to = "qwerty"), + regexp = "qwerty" + ) + expect_warning( + object = .rba_file(file = "test.txt", save_to = "qwerty"), + regexp = "qwerty" + ) + expect_identical( + object = suppressWarnings(.rba_file(file = "test.txt", save_to = "qwerty")), + expected = file.path(getwd(), getOption("rba_dir_name"), "test.txt") + ) + # detects saving in wrong file extension + expect_warning( + object = .rba_file(file = "test.txt", save_to = "test.json"), + regexp = "txt" + ) + + # increments existing file names dir.create(getwd(), "rbioapi_test") - writeLines(text = "111", con = file.path("rbioapi_test", - "test.txt")) - expect_identical(object = .rba_file(file = "test.txt", - save_to = TRUE, - dir_name = "rbioapi_test"), - expected = file.path(getwd(), - "rbioapi_test", - "test_1.txt")) - unlink(file.path(getwd(), "rbioapi_test"), - recursive = TRUE) - unlink(file.path(getwd(), "rbioapi"), - recursive = TRUE) + writeLines( + text = "111", + con = file.path("rbioapi_test", "test.txt") + ) + expect_identical( + object = .rba_file(file = "test.txt", save_to = TRUE, dir_name = "rbioapi_test"), + expected = file.path(getwd(), "rbioapi_test", "test_1.txt") + ) + unlink(file.path(getwd(), "rbioapi_test"), recursive = TRUE) + unlink(file.path(getwd(), "rbioapi"), recursive = TRUE) + })