Feature/vignettes and gwas upload (#20)

* Updating vignettes and removing api related Rd files

* Updating vignettes

* Removing unneccesary get trait param

Author: andrew-e

.lintr

@@ -1,4 +1,5 @@
 linters: linters_with_defaults(
+    object_length_linter = object_length_linter(length = 50),
     line_length_linter = line_length_linter(120),
     return_linter = return_linter(return_style = "explicit"),
     object_name_linter = NULL,

DESCRIPTION

@@ -18,8 +18,13 @@ Imports:
     readr,
     tidyr
 Suggests: 
+    ggplot2,
+    ggrepel,
     knitr,
+    RColorBrewer,
+    reshape2,
     rmarkdown,
+    stringr,
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 VignetteBuilder: knitr

NAMESPACE

@@ -8,16 +8,13 @@ export(genes)
 export(get_all_gene_pleiotropies)
 export(get_all_snp_pleiotropies)
 export(get_gwas)
-export(get_gwas_api)
 export(health_api)
 export(ld_matrix)
 export(ld_proxies)
 export(region)
 export(search_gpmap)
-export(select_api)
 export(trait)
 export(traits)
 export(upload_gwas)
 export(variant)
 export(variants)
-export(version_api)

R/api.r

@@ -4,7 +4,7 @@ timeout_seconds <- 360
 #' @description Select the API to use
 #' @param api A character string specifying the API to use. Default is "production".
 #' @return NULL
-#' @export
+#' @noRd
 select_api <- function(api = "dev") {
   if (api == "dev") {
     api_option <- options("gpmap_url" = "http://localhost:8000")
@@ -32,7 +32,7 @@ health_api <- function() {
 #' @title Get API Version
 #' @description Get the version of the API
 #' @return A list containing the version
-#' @export
+#' @noRd
 version_api <- function() {
   url <- paste0(getOption("gpmap_url"), "/v1/info/version")
   version <- httr::GET(url)
@@ -44,6 +44,7 @@ version_api <- function() {
 #' @title Search Options API
 #' @description Search options from the API
 #' @return A list containing the search options
+#' @noRd
 search_options_api <- function() {
   url <- paste0(getOption("gpmap_url"), "/v1/search/options")
   search_options <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -57,6 +58,7 @@ search_options_api <- function() {
 #' @param query A character string specifying the query
 #' @param rsquared_threshold A numeric value specifying the rsquared threshold for the proxy variants
 #' @return A list containing the variants
+#' @noRd
 search_variants_api <- function(query, rsquared_threshold = 0.8) {
   url <- paste0(getOption("gpmap_url"), "/v1/search/variant/", query, "?rsquared_threshold=", rsquared_threshold)
   search_variants <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -68,6 +70,7 @@ search_variants_api <- function(query, rsquared_threshold = 0.8) {
 #' @title Get All Traits API
 #' @description Get all traits from the API
 #' @return A list containing all traits
+#' @noRd
 traits_api <- function() {
   url <- paste0(getOption("gpmap_url"), "/v1/traits")
   traits <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -83,6 +86,7 @@ traits_api <- function() {
 #' @param include_coloc_pairs A logical value specifying whether to include coloc pairs
 #' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
 #' @return A list containing the traits
+#' @noRd
 specific_traits_api <- function(
   trait_ids,
   include_associations = FALSE,
@@ -106,6 +110,7 @@ specific_traits_api <- function(
 #' @param trait_id A character string specifying the trait ID
 #' @param include_associations A logical value specifying whether to include associations
 #' @return A list containing the trait
+#' @noRd
 trait_api <- function(trait_id, include_associations = FALSE) {
   url <- paste0(
     getOption("gpmap_url"),
@@ -118,6 +123,12 @@ trait_api <- function(trait_id, include_associations = FALSE) {
   return(trait)
 }
 
+#' @title Get Trait Coloc Pairs API
+#' @description Get trait coloc pairs from the API
+#' @param trait_id A character string specifying the trait ID
+#' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
+#' @return A list containing the trait coloc pairs
+#' @noRd
 trait_coloc_pairs_api <- function(trait_id, h4_threshold = 0.8) {
   url <- paste0(
     getOption("gpmap_url"),
@@ -135,6 +146,7 @@ trait_coloc_pairs_api <- function(trait_id, h4_threshold = 0.8) {
 #' @title Get Gene Information
 #' @description Get gene information from the API
 #' @return A list containing the genes
+#' @noRd
 genes_api <- function() {
   url <- paste0(getOption("gpmap_url"), "/v1/genes")
   genes <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -151,6 +163,7 @@ genes_api <- function() {
 #' @param include_trans A logical value specifying whether to include trans genetic effects
 #' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
 #' @return A list containing the genes
+#' @noRd
 specific_genes_api <- function(
   gene_ids,
   include_associations = FALSE,
@@ -180,6 +193,7 @@ specific_genes_api <- function(
 #' @param include_trans A logical value specifying whether to include trans genetic effects
 #' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
 #' @return A list containing the gene information
+#' @noRd
 gene_api <- function(gene_id,
                      include_associations = FALSE,
                      include_coloc_pairs = FALSE,
@@ -207,6 +221,7 @@ gene_api <- function(gene_id,
 #' @param include_coloc_pairs A logical value specifying whether to include coloc pairs
 #' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
 #' @return A list containing the region information
+#' @noRd
 region_api <- function(region_id, include_associations = FALSE, include_coloc_pairs = FALSE, h4_threshold = 0.8) {
   url <- paste0(
     getOption("gpmap_url"),
@@ -230,6 +245,7 @@ region_api <- function(region_id, include_associations = FALSE, include_coloc_pa
 #' @param include_coloc_pairs Logical. Whether to include coloc pairs for SNPs (only when expand=TRUE)
 #' @param h4_threshold Numeric. H4 threshold for coloc pairs, defaults to 0.8
 #' @return A list containing the variants
+#' @noRd
 variants_api <- function(variants, expand = FALSE, include_associations = FALSE, include_coloc_pairs = FALSE, h4_threshold = 0.8) {
   variants <- paste(variants, collapse = "&variants=")
   url <- paste0(getOption("gpmap_url"), "/v1/variants?variants=", variants)
@@ -245,11 +261,21 @@ variants_api <- function(variants, expand = FALSE, include_associations = FALSE,
 #' @param include_coloc_pairs Logical. Whether to include coloc pairs
 #' @param h4_threshold Numeric. H4 threshold for coloc pairs, defaults to 0.8
 #' @return A list containing the variants
+#' @noRd
 variants_grange_api <- function(chr, start, stop, include_associations = FALSE, include_coloc_pairs = FALSE, h4_threshold = 0.8) {
   url <- paste0(getOption("gpmap_url"), "/v1/variants?grange=", chr, ":", start, "-", stop)
   return(get_variants_with_options_api(url, expand = FALSE, include_associations, include_coloc_pairs, h4_threshold))
 }
 
+#' @title Get Variants with Options API
+#' @description Get variants from the API with options
+#' @param url A character string specifying the URL
+#' @param expand A logical value specifying whether to expand the variants
+#' @param include_associations A logical value specifying whether to include associations
+#' @param include_coloc_pairs A logical value specifying whether to include coloc pairs
+#' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
+#' @return A list containing the variants
+#' @noRd
 get_variants_with_options_api <- function(
   url,
   expand = FALSE,
@@ -275,6 +301,7 @@ get_variants_with_options_api <- function(
 #' @param include_coloc_pairs A logical value specifying whether to include coloc pairs
 #' @param h4_threshold A numeric value specifying the h4 threshold for coloc pairs
 #' @return A list containing the variant
+#' @noRd
 variant_api <- function(snp_id, include_coloc_pairs = FALSE, h4_threshold = 0.8) {
   url <- paste0(
     getOption("gpmap_url"),
@@ -293,6 +320,7 @@ variant_api <- function(snp_id, include_coloc_pairs = FALSE, h4_threshold = 0.8)
 #' @description Get variant summary statistics from the API
 #' @param snp_id A character string specifying the SNP ID
 #' @return A list containing dataframes from the TSV files
+#' @noRd
 variant_summary_stats_api <- function(snp_id) {
   temp_zip <- file.path(tempdir(), paste0("summary_stats_", snp_id, ".zip"))
 
@@ -317,6 +345,7 @@ variant_summary_stats_api <- function(snp_id) {
 #' @description Get LD proxies from the API by Variant ID
 #' @param variants A character string specifying the Variant ID
 #' @return A list containing the LD proxies
+#' @noRd
 ld_proxies_by_variant_api <- function(variants) {
   variants <- paste(variants, collapse = "&variants=")
   url <- paste0(getOption("gpmap_url"), "/v1/ld/proxies?variants=", variants)
@@ -330,6 +359,7 @@ ld_proxies_by_variant_api <- function(variants) {
 #' @description Get LD proxies from the API by SNP ID
 #' @param snp_ids A character string specifying the SNP ID
 #' @return A list containing the LD proxies
+#' @noRd
 ld_proxies_by_snp_id_api <- function(snp_ids) {
   snp_ids <- paste(snp_ids, collapse = "&snp_ids=")
   url <- paste0(getOption("gpmap_url"), "/v1/ld/proxies?snp_ids=", snp_ids)
@@ -343,6 +373,7 @@ ld_proxies_by_snp_id_api <- function(snp_ids) {
 #' @description Get LD matrix from the API by Variant ID
 #' @param variants A character string specifying the Variant ID
 #' @return A list containing the LD matrix
+#' @noRd
 ld_matrix_by_variant_api <- function(variants) {
   variants <- paste(variants, collapse = "&variants=")
   url <- paste0(getOption("gpmap_url"), "/v1/ld/matrix?variants=", variants)
@@ -356,6 +387,7 @@ ld_matrix_by_variant_api <- function(variants) {
 #' @description Get LD matrix from the API by SNP ID
 #' @param snp_ids A character string specifying the SNP ID
 #' @return A list containing the LD matrix
+#' @noRd
 ld_matrix_by_snp_id_api <- function(snp_ids) {
   snp_ids <- paste(snp_ids, collapse = "&snp_ids=")
   url <- paste0(getOption("gpmap_url"), "/v1/ld/matrix?snp_ids=", snp_ids)
@@ -370,6 +402,7 @@ ld_matrix_by_snp_id_api <- function(snp_ids) {
 #' @param snp_ids A vector of numeric values specifying the SNP IDs
 #' @param study_ids A vector of numeric values specifying the Study IDs
 #' @return A list containing the associations
+#' @noRd
 associations_api <- function(snp_ids, study_ids) {
   snp_ids <- paste(snp_ids, collapse = "&snp_ids=")
   study_ids <- paste(study_ids, collapse = "&study_ids=")
@@ -384,6 +417,7 @@ associations_api <- function(snp_ids, study_ids) {
 #' @title Get All Gene Pleiotropies API
 #' @description Get all gene pleiotropies from the API
 #' @return A list containing the gene pleiotropies
+#' @noRd
 gene_pleiotropies_api <- function() {
   url <- paste0(getOption("gpmap_url"), "/v1/pleiotropy/genes")
   gene_pleiotropies <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -395,6 +429,7 @@ gene_pleiotropies_api <- function() {
 #' @title Get All SNP Pleiotropies API
 #' @description Get all SNP pleiotropies from the API
 #' @return A list containing the SNP pleiotropies
+#' @noRd
 snp_pleiotropies_api <- function() {
   url <- paste0(getOption("gpmap_url"), "/v1/pleiotropy/snps")
   snp_pleiotropies <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -407,10 +442,14 @@ snp_pleiotropies_api <- function() {
 #' @description Get a GWAS from the API
 #' @param gwas_id The ID of the GWAS
 #' @param include_summary_stats Whether to include summary statistics
+#' @param include_associations Whether to include associations
 #' @return A list containing the GWAS information
-#' @export
-get_gwas_api <- function(gwas_id, include_summary_stats = FALSE) {
+#' @noRd
+get_gwas_api <- function(gwas_id, include_summary_stats = FALSE, include_associations = FALSE) {
   url <- paste0(getOption("gpmap_url"), "/v1/gwas/", gwas_id)
+  if (include_associations) {
+    url <- paste0(url, "?include_associations=true")
+  }
   gwas <- httr::GET(url, httr::timeout(timeout_seconds))
   gwas <- httr::content(gwas, "text", encoding = "UTF-8")
   gwas <- jsonlite::fromJSON(gwas)
@@ -421,6 +460,11 @@ get_gwas_api <- function(gwas_id, include_summary_stats = FALSE) {
   return(gwas)
 }
 
+#' @title Get a GWAS Summary Stats API
+#' @description Get a GWAS summary stats from the API
+#' @param gwas_id The ID of the GWAS
+#' @return A list containing the GWAS summary stats
+#' @noRd
 get_gwas_summary_stats_api <- function(gwas_id) {
   url <- paste0(getOption("gpmap_url"), "/v1/gwas/", gwas_id, "/summary-stats")
   summary_stats <- httr::GET(url, httr::timeout(timeout_seconds))
@@ -451,7 +495,9 @@ get_gwas_summary_stats_api <- function(gwas_id) {
 #' @param ancestry The ancestry of the GWAS.  Currently only "EUR" is accepted.
 #' @param sample_size The sample size of the GWAS
 #' @param reference_build The reference build of the GWAS.  Only "GRCh37" and "GRCh38" are accepted.
+#' @param compare_with_upload_guids A vector of GUIDs of uploads to compare with
 #' @return A list containing the GWAS information
+#' @noRd
 upload_gwas_api <- function(file,
                             name,
                             p_value_threshold,
@@ -463,7 +509,8 @@ upload_gwas_api <- function(file,
                             should_be_added = FALSE,
                             ancestry = "EUR",
                             sample_size,
-                            reference_build = "GRCh38") {
+                            reference_build = "GRCh38",
+                            compare_with_upload_guids = NA) {
   url <- paste0(getOption("gpmap_url"), "/v1/gwas")
 
   gwas_request <- list(
@@ -477,7 +524,8 @@ upload_gwas_api <- function(file,
     ancestry = ancestry,
     sample_size = sample_size,
     p_value_threshold = p_value_threshold,
-    column_names = column_names
+    column_names = column_names,
+    compare_with_upload_guids = compare_with_upload_guids
   )
   request_json <- jsonlite::toJSON(gwas_request, auto_unbox = TRUE)
 

R/common.R

@@ -24,23 +24,72 @@ is_guid <- function(id) {
 merge_associations <- function(coloc_groups, rare_results, associations) {
   if (is.null(associations)) return(coloc_groups = coloc_groups, rare_results = rare_results)
 
-  if (is.data.frame(coloc_groups) && nrow(coloc_groups) > 0) {
-    coloc_groups <- dplyr::left_join(
-      coloc_groups,
-      associations,
-      by = c("study_id", "snp_id")
-    )
+  join_keys <- c("study_id", "snp_id")
+  if (!all(join_keys %in% colnames(associations))) {
+    return(list(coloc_groups = coloc_groups, rare_results = rare_results))
   }
+  associations <- dplyr::distinct(associations, dplyr::across(dplyr::all_of(join_keys)), .keep_all = TRUE)
 
+  if (is.data.frame(coloc_groups) && nrow(coloc_groups) > 0) {
+    coloc_groups <- dplyr::left_join(coloc_groups, associations, by = join_keys)
+  }
   if (is.data.frame(rare_results) && nrow(rare_results) > 0) {
-    rare_results <- dplyr::left_join(
-      rare_results,
+    rare_results <- dplyr::left_join(rare_results, associations, by = join_keys)
+  }
+
+  return(list(coloc_groups = coloc_groups, rare_results = rare_results))
+}
+
+#' Merge associations into coloc info for GWAS upload results
+#'
+#' Joins associations using study_id when study_id is not NA, or existing_study_id
+#' when existing_study_id is not NA. GWAS uploads do not have rare results.
+#'
+#' @param coloc_groups A dataframe of coloc groups
+#' @param associations A dataframe of associations
+#' @return Coloc groups with associations merged in
+#' @keywords internal
+#' @noRd
+merge_gwas_upload_associations <- function(coloc_groups, associations) {
+  if (is.null(associations)) return(coloc_groups)
+  if (!is.data.frame(coloc_groups) || nrow(coloc_groups) == 0) return(coloc_groups)
+
+  study_rows <- coloc_groups[!is.na(coloc_groups[["study_id"]]), , drop = FALSE]
+  existing_rows <- coloc_groups[
+    is.na(coloc_groups[["study_id"]]) & !is.na(coloc_groups[["existing_study_id"]]),
+    , drop = FALSE
+  ]
+  other_rows <- coloc_groups[
+    is.na(coloc_groups[["study_id"]]) & is.na(coloc_groups[["existing_study_id"]]),
+    , drop = FALSE
+  ]
+  parts <- list()
+
+  assoc_cols <- c("beta", "se", "p", "eaf", "imputed")
+  assoc_cols <- intersect(assoc_cols, colnames(associations))
+
+  if (nrow(study_rows) > 0 && "study_id" %in% colnames(associations)) {
+    assoc <- dplyr::distinct(associations, dplyr::across(dplyr::all_of(c("study_id", "snp_id"))), .keep_all = TRUE)
+    assoc <- dplyr::select(assoc, dplyr::all_of(c("study_id", "snp_id", assoc_cols)))
+    parts[[length(parts) + 1L]] <- dplyr::left_join(study_rows, assoc, by = c("study_id", "snp_id"))
+  }
+  if (nrow(existing_rows) > 0 && "existing_study_id" %in% colnames(associations)) {
+    assoc <- dplyr::distinct(
       associations,
-      by = c("study_id", "snp_id")
+      dplyr::across(dplyr::all_of(c("existing_study_id", "snp_id"))),
+      .keep_all = TRUE
     )
+    assoc <- dplyr::select(assoc, dplyr::all_of(c("existing_study_id", "snp_id", assoc_cols)))
+    parts[[length(parts) + 1L]] <- dplyr::left_join(existing_rows, assoc, by = c("existing_study_id", "snp_id"))
+  }
+  if (nrow(other_rows) > 0) {
+    parts[[length(parts) + 1L]] <- other_rows
   }
 
-  return(list(coloc_groups = coloc_groups, rare_results = rare_results))
+  if (length(parts) > 0) {
+    return(dplyr::bind_rows(parts))
+  }
+  return(coloc_groups)
 }
 
 #' Create a source url for a study