run barebones version

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 export(add_ancestors)
+export(add_db)
 export(add_hoverboxes)
 export(add_ontology_metadata)
 export(cache_clear)
@@ -9,6 +10,8 @@ export(cache_files)
 export(cache_save)
 export(dt_to_matrix)
 export(example_dat)
+export(filter_dt)
+export(filter_graph)
 export(filter_kg)
 export(filter_ontology)
 export(get_alphamissense)
@@ -18,6 +21,7 @@ export(get_definitions)
 export(get_gencc)
 export(get_gene_lengths)
 export(get_genes_disease)
+export(get_graph_colnames)
 export(get_monarch)
 export(get_monarch_files)
 export(get_monarch_kg)
@@ -37,6 +41,7 @@ export(graph_to_ggnetwork)
 export(graph_to_plotly)
 export(kde_surface)
 export(link_monarch)
+export(map_colors)
 export(map_genes_dt)
 export(map_genes_monarch)
 export(map_mondo)
@@ -47,15 +52,16 @@ export(map_variants)
 export(ontology_to)
 export(ontology_to_adjacency)
 export(plot_clinvar)
+export(plot_ggnetwork)
 export(plot_graph_3d)
 export(plot_graph_visnetwork)
 export(plot_ontology)
 export(plot_ontology_heatmap)
+export(plot_save)
 export(plot_upheno)
 export(query_monarch)
 export(query_oard)
 export(to_graph)
-import(BiocParallel)
 import(data.table)
 import(orthogene)
 import(pals)

R/_docs.R → R/0docs.R

@@ -56,11 +56,14 @@ NULL
 #' @param show_plot Print the plot after it's been generated.
 #' @param save_path Path to save interactive plot to
 #' as a self-contained HTML file.
+#' @param interactive Make the plot interactive.
 #' @param verbose Print messages.
 #' @param id_col Column containing the unique identifier for each node 
 #' in a graph (e.g. "name").
-#' @param label_col Column containing the label for each node in a graph
+#' @param label_var Column containing the label for each node in a graph
 #'  (e.g. "hpo_name").
+#' @param size_var Column to scale node size by.
+#' @param colour_var Column to color nodes by.
 #' @param ... Additional arguments passed to plot-specific functions.
 #' @import simona
 #' @family plot_ 
@@ -149,6 +152,16 @@ NULL
 #' @param use_simona Use \link[simona]{dag_filter} to filter terms.
 #' @param keep_chr Which chromosomes to keep.
 #' @param grlist Named list of \link[GenomicRanges]{GRanges} objects.
+#' @param filters A named list of filters to apply to the data. 
+#' Names should be name of the metadata column, and values should be a vector of 
+#' valid options. For example, \code{list("type" = c("gene","variant"))} will
+#' return any rows where the "type" column contains either "gene" or "variant".
+#' @param keep_descendants Terms whose descendants should be kept 
+#' (including themselves).
+#'  Set to \code{NULL} (default) to skip this filtering step.
+#' @param remove_descendants Terms whose descendants should be removed 
+#' (including themselves).
+#'  Set to \code{NULL} (default) to skip this filtering step.
 #' @inheritParams plot_
 #' @inheritParams get_
 #' @import simona

R/add_ancestors.R

@@ -3,38 +3,53 @@
 #' 
 #' For each term, get its ancestor at a given level
 #' and add the ID and name of the ancestor to the ontology metadata.
+#' By default, lower numbers are higher in the ontology
+#'  (e.g. level 0 includes the most broad ontology term).
+#' When a terms does not have an ancestor at a given level
+#'  (e.g. \code{lvl=3} but the term itself is at level 1) the term is assigned
+#'   to itself as its own ancestor.
+#' When a term has multiple ancestors at a given level, 
+#' the first ancestor is arbitrarily chosen.
 #' @export
-#' @import BiocParallel
-#' @inheritParams simona::dag_ancestors
+#' @inheritParams simona::dag_offspring
 #' @examples 
-#' ont <- get_ontology("hpo", terms=10)
+#' ont <- get_ontology("hpo")
 #' ont2 <- add_ancestors(ont)
 add_ancestors <- function(ont,
-                         lvl=2, 
-                         include_self=TRUE,
-                         force_new=FALSE){
+                          lvl=2, 
+                          include_self=TRUE,
+                          force_new=FALSE){
+  term <- ancestor <- NULL;
+
+  if(is.null(lvl)) return (ont)
   messager("Adding ancestor metadata.")
   #### Check if ancestor metadata already present
   if(all(c("ancestor","ancestor_name") %in% colnames(ont@elementMetadata)) &&
      isFALSE(force_new)){
     messager("Ancestor metadata already present.",
              "Use force_new=TRUE to overwrite.")
     return(ont)
-  }
-  BPPARAM <- BiocParallel::MulticoreParam(progressbar=TRUE)
-  ont@elementMetadata$ancestor <- BiocParallel::bplapply(ont@terms,
-                                                         BPPARAM = BPPARAM,
-                                                         function(x){
-    opts <- simona::dag_ancestors(ont,
-                                  term = x,
-                                  include_self=include_self)
-    ## Find the ancestor at the given level (or closest to it)
-    names(sort(abs(simona::dag_depth(ont,opts)-lvl)))[1]
-  })|> unlist()
-  #### Add ancestor names ####
-  name_dict <- stats::setNames(ont@elementMetadata$name,
-                               ont@elementMetadata$id)
-  ont@elementMetadata$ancestor_name <- name_dict[ont@elementMetadata$ancestor]
+  } 
+  all_lvls <- get_ontology_levels(ont, method = "depth")
+  ancestors <- all_lvls[unname(all_lvls)==lvl]|>names()
+  messager(length(ancestors),"ancestors found at level",lvl)
+
+  ancestors_groups <- lapply(stats::setNames(ancestors,ancestors), function(x){
+    data.table::data.table(
+      term=simona::dag_offspring(ont, term = x, 
+                                 include_self = include_self)
+    )
+  }) |> data.table::rbindlist(idcol  = "ancestor", fill = TRUE)
+  #### Ensure one row per term ####
+  ancestors_groups <- ancestors_groups[, .SD[1], keyby = "term"] 
+  ancestors_groups <- ancestors_groups[ont@terms][is.na(ancestor),
+                                                  ancestor:=term]
+  ont@elementMetadata$ancestor <- ancestors_groups$ancestor 
+  #### Add ancestor_name col
+  ont@elementMetadata$ancestor_name <-  map_ontology_terms(
+    ont = ont, 
+    terms = ont@elementMetadata$ancestor, 
+    to = "name")
   #### Return ####
   return(ont)
 }

R/add_db.R

@@ -1,4 +1,12 @@
-#' @describeIn utils_ utils_
+#' @describeIn add_ add_
+#' Extract a database identifier from an ID column and add it
+#' as a separate column.
+#' @param dat data.table or tbl_graph.
+#' @param input_col Column containing IDs.
+#' @param output_col Column to add.
+#' @inheritParams data.table::tstrsplit
+#' @inheritParams base::strsplit
+#' @export
 add_db <- function(dat,
                    input_col,
                    output_col=paste0(input_col,"_db"),

R/add_ontology_metadata.R

@@ -8,7 +8,7 @@
 #' ont <- get_ontology("hpo", terms=10)
 #' ont2 <- add_ontology_metadata(ont)
 add_ontology_metadata <- function(ont,
-                                  add_ancestors=FALSE,
+                                  add_ancestors=2,
                                   add_n_edges=TRUE,
                                   add_ontology_levels=TRUE){
   messager("Adding term metadata.")
@@ -19,9 +19,8 @@ add_ontology_metadata <- function(ont,
   simona::mcols(ont)$n_parents <- simona::n_parents(ont)
   simona::mcols(ont)$n_offspring <- simona::n_offspring(ont)
   simona::mcols(ont)$n_connected_leaves <- simona::n_connected_leaves(ont) 
-  if(isTRUE(add_ancestors)) {
-    ont <- add_ancestors(ont)
-  }
+  ont <- add_ancestors(ont = ont, 
+                       lvl = add_ancestors)
   if(isTRUE(add_n_edges)){
     adj <- ontology_to(ont = ont,
                        to="adjacency")

R/dt_to_graph.R

@@ -2,6 +2,10 @@ dt_to_graph <- function(dat,
                         from_pattern="subject",
                         to_pattern="object",
                         add_hover=FALSE){
+  if(methods::is(dat,"tbl_graph")) {
+    messager("Input is already a tbl_graph. Returning input.")
+    return(dat)
+  }
  make_nodes <- function(dat,
                         pattern){
    cols <- grep(pattern,names(dat), value = TRUE)
@@ -30,7 +34,7 @@ dt_to_graph <- function(dat,
   edge_cols <- c(
     from_pattern,to_pattern,
     # paste0(c(from_pattern,to_pattern),"_category"),
-    grep(paste(c(from_pattern,from_pattern),collapse="|"),
+    grep(paste(c(from_pattern,to_pattern),collapse="|"),
          names(dat), value = TRUE, invert = TRUE)
   )|> unique()
   edge_cols <- edge_cols[edge_cols %in% names(dat)]

R/filter_dt.R

@@ -1,12 +1,20 @@
 #' @describeIn filter_ filter_
+#' Filter a \link[data.table]{data.table}.
+#' @export
+#' @examples
+#' dat <- mtcars 
+#' dat2 <- filter_dt(dat, filters=list(cyl=c(4,6)))
 filter_dt <- function(dat,
                       filters){
+  if(!methods::is(dat,"data.table")){
+    dat <- data.table::as.data.table(dat)
+  } 
   for(f in names(filters)){
-    if(!is.null(filters[[f]]) &&
-       filters[[f]] %in% names(dat)) {
+    if(any(!is.null(filters[[f]])) &&
+       f %in% names(dat)) {
       n1 <- nrow(dat)
       dat <- dat[get(f) %in% filters[[f]]]
-      messager("Filtered",f,":",
+      messager("Filtered",shQuote(f),":",
                formatC(n1-nrow(dat),big.mark = ","),"/",
                formatC(n1,big.mark = ","),
                "rows dropped.")

R/filter_graph.R

@@ -0,0 +1,17 @@
+#' @describeIn filter_ filter_
+#' Filter a tbl_graph.
+#' @export
+filter_graph <- function(g,
+                         filters){
+  for(nm in names(filters)){
+    f <- filters[[nm]]
+    if(is.null(f)){
+      next
+    }
+    ## filter just that column in the nodes of the graph
+    g <- g|> 
+      tidygraph::activate("nodes") |>
+      tidygraph::filter(get(eval(nm)) %in% f)
+  }
+  return(g)
+}

R/filter_kg.R

@@ -4,8 +4,10 @@
 #' types of nodes (e.g. Disease <--> Cell).
 #' @export
 #' @examples
+#' \dontrun{
 #' g <- get_monarch_kg()
 #' g2 <- filter_kg(g)
+#' }
 filter_kg <- function(g,
                       from_categories = paste0("biolink:",
                                                   c("Disease",
@@ -14,11 +16,11 @@ filter_kg <- function(g,
                                                     "AnatomicalEntity",
                                                     "Cell")
                                                   ),
-                              to_categories = from_categories,
-                              edge_categories = NULL,
-                              dbs=NULL,# c("mondo","HP","CL")
-                              rm_isolated=TRUE,
-                              as_dt=FALSE){
+                      to_categories = from_categories,
+                      edge_categories = NULL,
+                      dbs=NULL,# c("mondo","HP","CL")
+                      rm_isolated=TRUE,
+                      as_dt=FALSE){
   category <- db <- NULL;
   len1 <- length(g)
   nodes <- g|> tidygraph::activate("nodes")|>data.table::as.data.table()

R/filter_ontology.R

@@ -10,6 +10,8 @@
 filter_ontology <- function(ont,
                             terms=NULL,
                             remove_terms=NULL,
+                            keep_descendants=NULL,
+                            remove_descendants=NULL,
                             use_simona=FALSE,
                             ...){
   #### Check remove_terms #### 
@@ -19,6 +21,45 @@ filter_ontology <- function(ont,
     ont <- simona::dag_filter(ont, terms=terms, ...)
     return(ont)
   }
+  #### keep_descendants ####
+  if(!is.null(keep_descendants)){
+    keep_descendants <- map_ontology_terms(ont = ont,
+                                           terms = keep_descendants,
+                                           to = "id") |> stats::na.omit()
+    if(length(keep_descendants)>0){
+      messager("Keeping descendants of",length(keep_descendants),"term(s).")
+      keep_descendants <- simona::dag_offspring(dag = ont,
+                                                include_self = TRUE,
+                                                term = keep_descendants)
+      ont <- simona::dag_filter(ont, 
+                                terms=keep_descendants, 
+                                ...)
+      messager(formatC(ont@n_terms,big.mark = ","),
+               "terms remain after filtering.")
+    } else {
+      messager("keep_descendants: No descendants found.")
+    } 
+  }
+  #### remove_descendants ####
+  if(!is.null(remove_descendants)){
+    remove_descendants <- map_ontology_terms(ont = ont,
+                                             terms = remove_descendants,
+                                             to = "id") |> stats::na.omit()
+    if(length(remove_descendants)>0){
+      messager("Removing descendants of",length(remove_descendants),"term(s).")
+      remove_descendants <- simona::dag_offspring(dag = ont,
+                                                  include_self = TRUE,
+                                                  term = remove_descendants)
+      keep_terms <- ont@terms[!ont@terms %in% remove_descendants]
+      ont <- simona::dag_filter(ont, 
+                                terms=keep_terms, 
+                                ...)
+      messager(formatC(ont@n_terms,big.mark = ","),
+               "terms remain after filtering.")
+    } else {
+      messager("remove_descendants: No descendants found.")
+    }
+  }
   #### Use custom filtering methods ####
   if(!is.null(terms)){
     ## Characters 

R/get_graph_colnames.R

@@ -1,3 +1,7 @@
+#' @describeIn get_ get_
+#' Get column names in the nodes and/or edges of a tbl_graph.
+#' @inheritParams tidygraph::activate
+#' @export
 get_graph_colnames <- function(g,
                                what=c("nodes","edges")){
   if(methods::is(g,"data.frame")) return(names(g))

R/get_monarch.R

@@ -20,7 +20,8 @@ get_monarch <- function(queries=NULL,
                         maps=NULL,
                         domain="https://data.monarchinitiative.org",
                         subdir="latest/tsv/all_associations/",
-                        rbind=FALSE
+                        rbind=FALSE,
+                        save_dir=cache_dir()
                         ){
   files <- get_monarch_files(domain=domain,
                              subdir=subdir,
@@ -33,7 +34,8 @@ get_monarch <- function(queries=NULL,
     messager("-",paste0(i,"/",nrow(files),":"),
              files[i,]$name) 
     tryCatch({
-      data.table::fread(files[i,]$url)
+      data.table::fread(files[i,]$url, 
+                        tmpdir = save_dir)
     }, error=function(e){messager(e);NULL})
   }) 
   ### Bind