Introduce plotModules prototype and make plotting more customisable

.github/workflows/update.yml

@@ -18,6 +18,7 @@ jobs:
         with:
           extra-packages: |
             any::devtools
+            any::rvest
             any::systemfonts
             any::usethis
       - name: Run scripts

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: ariadne
-Version: 0.2.7
+Version: 0.2.8
 Authors@R: 
     c(person(given = "Giulio", family = "Benedetti", role = c("aut", "cre"),
           email = "giulio.benedetti@utu.fi",
@@ -27,17 +27,18 @@ biocViews:
 License: Artistic-2.0
 Encoding: UTF-8
 Depends:
-    R (>= 4.1)
+    R (>= 4.1),
+    ggraph,
+    igraph (>= 2.3.0)
 Imports:
     arrow,
     BiocFileCache,
     BiocParallel,
     data.table,
     dplyr,
     ggplot2,
-    ggraph,
+    grid,
     httr2,
-    igraph (>= 2.3.0),
     KEGGREST,
     Matrix,
     methods,

NAMESPACE

@@ -7,6 +7,7 @@ export(drawPath)
 export(getModules)
 export(linkNames)
 export(listResourceVersions)
+export(plotModules)
 export(plotPath)
 export(processGeneFamilies)
 export(searchPath)
@@ -17,6 +18,7 @@ exportMethods(addResource)
 exportMethods(drawPath)
 exportMethods(getModules)
 exportMethods(linkNames)
+exportMethods(plotModules)
 exportMethods(plotPath)
 exportMethods(searchPath)
 exportMethods(weaveComplex)
@@ -48,19 +50,23 @@ importFrom(arrow,write_parquet)
 importFrom(data.table,as.data.table)
 importFrom(data.table,dcast)
 importFrom(data.table,fread)
+importFrom(data.table,melt)
 importFrom(data.table,rbindlist)
 importFrom(data.table,set)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,collect)
 importFrom(dplyr,filter)
 importFrom(dplyr,select)
 importFrom(ggplot2,aes)
+importFrom(ggplot2,guide_legend)
+importFrom(ggplot2,guides)
+importFrom(ggplot2,scale_colour_manual)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,theme_void)
-importFrom(ggraph,geom_edge_link)
 importFrom(ggraph,geom_node_point)
 importFrom(ggraph,geom_node_text)
 importFrom(ggraph,ggraph)
+importFrom(ggraph,scale_edge_colour_gradient2)
 importFrom(ggraph,scale_edge_colour_manual)
 importFrom(httr2,req_body_form)
 importFrom(httr2,req_body_json)
@@ -92,6 +98,7 @@ importFrom(stats,reshape)
 importFrom(stats,setNames)
 importFrom(stringr,fixed)
 importFrom(stringr,str_detect)
+importFrom(stringr,str_remove)
 importFrom(stringr,str_split)
 importFrom(tidyselect,all_of)
 importFrom(tools,R_user_dir)

R/AllGenerics.R

@@ -45,3 +45,9 @@ setGeneric("getModules", signature = c("x"), function(x, ...)
 #' @rdname addModules
 setGeneric("addModules", signature = c("x"), function(x, ...)
     standardGeneric("addModules"))
+
+#' @export
+#' @rdname plotModules
+setGeneric("plotModules", signature = c("modules"), function(modules, ...)
+    standardGeneric("plotModules"))
+

R/append.R

@@ -113,6 +113,7 @@ setMethod("getModules", signature = c(x = "SummarizedExperiment"),
 })
 
 
+#' @importFrom stats reformulate
 #' @importFrom data.table set dcast as.data.table
 .get_modules <- function(df, modules, key, as){
     # Check if by is rownames
@@ -127,7 +128,7 @@ setMethod("getModules", signature = c(x = "SummarizedExperiment"),
     # Choose between ids and names
     origin_col <- colnames(modules)[1L]
     target_col <- colnames(modules)[switch(as, ids = 2L, names = ncol(modules))]
-    widen_form <- as.formula(paste(origin_col, "~", target_col))
+    widen_form <- reformulate(target_col, origin_col)
 
     modules <- as.data.table(modules)
 

R/cache.R

@@ -1,6 +1,7 @@
 
 #' @importFrom BiocFileCache bfcquery
 #' @importFrom arrow write_parquet
+#' @importFrom stringr str_remove fixed
 .cache_resource <- function(url, res.name, from, to){
     # Initialise cache
     bfc <- .init_cache()
@@ -14,25 +15,29 @@
     FUN <- switch(
         res.name,
         ChocoPhlAn = function(x) .process_one2many(
-            x, key.FUN = function(keys) sub("GO:", "", keys, fixed = TRUE)
+            x, key.FUN = function(keys) str_remove(keys, fixed("GO:"))
         ),
         WoL = function(x) .process_one2many(
             x, key.FUN = ifelse(from == "uniref90",
                 function(keys) paste0("UniRef90_", keys), identity),
-            val.FUN = function(vals) sub("EC-", "", vals, fixed = TRUE)
+            val.FUN = function(vals) str_remove(vals, fixed("EC-"))
         ),
         BugSigDB = function(x) .process_one2many(
             x, val.cols = -c(1L, 2L), skip = 1L, key.FUN = function(keys){
-                # Remove module prefix
-                keys <- sub("bsdb:", "", keys, fixed = TRUE)
-                # Remove module description
-                keys <- sub("_.*$", "", keys)
+                # Remove module prefix and description
+                keys <- keys |>
+                    str_remove(fixed("bsdb:")) |>
+                    str_remove("_.*$")
             }
         ),
         TIGRFAMs = function(x) .process_one2one(
             x, header = FALSE, select = c(1L, 2L)
         ),
-        GO = function(x) .process_one2one(x, header = FALSE),
+        GO = function(x) .process_one2one(
+            x, header = FALSE, key.FUN = function(keys){
+                keys <- str_remove(keys, " >.*")
+            }
+        ),
         GM = .process_complex_modules,
         MSigDB = .process_rdslist
     )
@@ -81,21 +86,24 @@
 
 # from to args?
 #' @importFrom data.table fread
-.process_one2one <- function(x, ...){
+#' @importFrom stringr str_remove fixed
+.process_one2one <- function(x, key.FUN = identity, ...){
     # Read linkmap
     linkmap <- fread(x, ...)
+    # Process keys with custom function
+    linkmap$V1 <- key.FUN(linkmap$V1)
     # Remove id prefix ending with : (for GO resources)
-    linkmap$V1 <- sub("^[^:]*:", "", linkmap$V1)
+    linkmap$V1 <- str_remove(linkmap$V1, "^[^:]*:")
     # Remove GO prefix (for GO and TIGRFAMs resources)
-    linkmap$V2 <- sub("GO:", "", linkmap$V2, fixed = TRUE)
+    linkmap$V2 <- str_remove(linkmap$V2, fixed("GO:"))
     return(linkmap)
 }
 
 
 #' @importFrom readr read_lines
 #' @importFrom stringr str_split fixed
 .process_one2many <- function(x, key.col = 1L, val.cols = -key.col,
-    key.FUN = identity, val.FUN = identity,...){
+    key.FUN = identity, val.FUN = identity, ...){
     # Read file content
     x <- read_lines(x, ...)
     # Split elements in each line by tab

R/linknet.R

@@ -0,0 +1,75 @@
+#' Visualise modules network
+#' 
+#' @name plotModules
+#' 
+#' @description
+#' \code{plotModules} generates a graph linking origin to target features.
+#' 
+#' @param modules \code{data.frame}. A linkmap as returned by
+#'   \code{\link{weavePath}} or \code{\link{weaveComplex}}. Its first and second
+#'   columns must contain elements to match to \code{key} and the target
+#'   modules, respectively.
+#' 
+#' @param show.labels \code{Logical scalar}. Whether node labels should be
+#'   shown. (Default: \code{TRUE})
+#' 
+#' @param edge.type \code{Character scalar} String specifying the type of edge
+#'   to use from the options available in ggraph (geom_edge_*).
+#'   (Default: \code{"diagonal"})
+#' 
+#' @param ... Additional arguments passed to \code{\link[ggraph:ggraph]{ggraph}}.
+#' 
+#' @returns A ggplot2 object.
+#' 
+#' @examples
+#' library(ggplot2)
+#' 
+#' graph <- ariadne()
+#' ec2gmm <- weaveComplex(graph, ec ~ gmm)
+#' 
+#' plotModules(ec2gmm) + coord_flip()
+NULL
+
+#' @export
+#' @rdname plotModules
+#' @importFrom data.table as.data.table melt
+#' @importFrom igraph graph_from_data_frame
+#' @importFrom ggraph ggraph scale_edge_colour_gradient2 geom_node_text
+#' @importFrom ggplot2 scale_colour_manual guides guide_legend
+setMethod("plotModules", signature = c(modules = "data.frame"),
+    function(modules, edge.type = "diagonal", show.labels = TRUE, ...){
+
+    modules <- as.data.table(modules)
+    if( !"cov" %in% colnames(modules) ) modules$cov <- 1
+
+    node_df <- melt(
+        modules[ , c(1, 2)], measure.vars = c(1, 2),
+        variable.name = "type", value.name = "name",
+        variable.factor = TRUE, value.factor = TRUE
+    )
+
+    node_df <- unique(node_df[ , c(2, 1)])
+    graph <- graph_from_data_frame(modules, vertices = node_df)
+
+    geom_edge <- eval(parse(text = paste0("ggraph::geom_edge_", edge.type)))
+
+    p <- ggraph(graph, ...) +
+        geom_edge(aes(colour = .data$cov)) +
+        geom_node_point(aes(colour = .data$type)) +
+        scale_colour_manual(values = c("darkorange", "#06B4B4")) +
+        scale_edge_colour_gradient2(
+            low = "white", mid = "grey80", high = "red",
+            midpoint = 0.5, limits = c(0, 1)
+        ) +
+        theme_void() +
+        guides(
+            colour = guide_legend(order = 1),
+            edge_colour = guide_legend(order = 2)
+        )
+
+    if( show.labels ){
+        p <- p + geom_node_text(aes(label = .data$name), vjust = 1.8, size = 2)
+    }
+
+    return(p)
+})

R/plot.R

@@ -26,8 +26,12 @@
 #' 
 #' @param focus \code{Logical scalar}. Whether the selected edges and nodes
 #'   should be zoomed in. (Default: \code{FALSE})
+#'  
+#' @param edge.type \code{Character scalar} String specifying the type of edge
+#'   to use from the options available in ggraph (geom_edge_*).
+#'   (Default: \code{"link"})
 #' 
-#' @param ... Unused.
+#' @param ... Additional arguments passed to \code{\link[ggraph:ggraph]{ggraph}}.
 #' 
 #' @returns A ggplot2 object.
 #' 
@@ -51,11 +55,11 @@ NULL
 #' @export
 #' @rdname plotPath
 #' @importFrom igraph as_data_frame graph_from_data_frame subgraph_from_edges ends
+#' @importFrom ggraph ggraph geom_node_point geom_node_text scale_edge_colour_manual
 #' @importFrom ggplot2 aes theme_void theme
-#' @importFrom ggraph ggraph geom_edge_link geom_node_point geom_node_text scale_edge_colour_manual
 setMethod("plotPath", signature = c(graph = "igraph"),
     function(graph, by = NULL, k = 1, include = NULL, exclude = NULL,
-    res.name = NULL, prune = FALSE, focus = FALSE){
+    res.name = NULL, prune = FALSE, focus = FALSE, edge.type = "link", ...){
     # Check args
     if( length(prune) != 1L || !is.logical(prune) || is.na(prune) ){
         stop("'prune' must be TRUE or FALSE.", call. = FALSE)
@@ -96,23 +100,24 @@ setMethod("plotPath", signature = c(graph = "igraph"),
     # Create a vector for edge alpha: 1 if marked, else 0 (transparent)
     if( prune ){
         edge_df$alpha <- edge_df$mark != 0
-        connected_nodes <- unique(c(ends(graph, E(graph)[edge_df$mark != 0])))
+        connected_nodes <- unique(ends(graph, E(graph)[edge_df$mark != 0]))
         node_df$alpha <- node_df$name %in% connected_nodes
     }else if( !is.null(res.name) ){
         edge_df$alpha <- edge_df$source %in% res.name
-        node_df$alpha <- rowSums(!is.na(node_df[ , res.name, drop = FALSE])) != 0L
+        node_df$alpha <- rowSums(!is.na(node_df[res.name])) != 0L
     }
     # Create graph from edges and nodes data
     graph <- graph_from_data_frame(edge_df, vertices = node_df)
     # Remove transparent nodes and edges
     if( focus ){
         graph <- subgraph_from_edges(graph, E(graph)[alpha != 0])
     }
+    # Select custom edge geom
+    geom_edge <- eval(parse(text = paste0("ggraph::geom_edge_", edge.type)))
     # Plot graph with edges marked and others faded
-    p <- ggraph(graph, layout = "stress") +
-        geom_edge_link(aes(colour = factor(.data$mark), label = .data$name,
-            alpha = .data$alpha), edge_width = 1, fontface = "bold",
-            show.legend = TRUE) +
+    p <- ggraph(graph, ...) +
+        geom_edge(aes(colour = factor(.data$mark), label = .data$name,
+            alpha = .data$alpha), edge_width = 1, fontface = "bold") +
         geom_node_point(aes(filter = .data$alpha),
             size = 4, colour = "darkorange") +
         geom_node_text(aes(label = .data$name, filter = .data$alpha),
@@ -134,4 +139,3 @@ setMethod("plotPath", signature = c(graph = "igraph"),
     )
     return(edges)
 }
-

R/weave.R

@@ -164,8 +164,8 @@ setMethod("weavePath", signature = c(graph = "data.frame"),
 #' @importFrom MultiFactor MultiFactor weave
 setMethod("weavePath", signature = c(graph = "igraph"),
     function(graph, by, k = 1, include = NULL, exclude = NULL, res.name = NULL,
-    init = NULL, prune = TRUE, use.names = TRUE, verbose = TRUE,
-    timeout = 1e6, ...){
+    init = NULL, prune = TRUE, use.names = TRUE, verbose = TRUE, timeout = 1e6,
+    ...){
     # Build MultiFactor from path linkmaps
     mf <- .build_path_mf(
         graph, by, k, include, exclude, res.name,

R/weave_complex.R

@@ -3,16 +3,16 @@
 #' @rdname weavePath
 #' @importFrom stats reformulate
 setMethod("weaveComplex", signature = c(graph = "data.frame"),
-    function(graph, init = NULL, prune = TRUE, use.names = TRUE,
-    threshold = NULL, verbose = TRUE, timeout = 1e6, ...){
+    function(graph, init = NULL, threshold = NULL, prune = TRUE,
+    use.names = TRUE, verbose = TRUE, timeout = 1e6, ...){
     # Derive formula from pathway dataframe
     by <- reformulate(graph$to[nrow(graph)], graph$from[1L])
     # Retrieve minimal graph for the pathway
     graph <- .graph_from_path_df(graph)
     # Weave linkmap from minimal graph
     linkmap <- weaveComplex(
-        graph, by, init = init, prune = prune, use.names = use.names,
-        threshold = threshold, verbose = verbose, timeout = timeout, ...
+        graph, by, init = init, threshold = threshold, prune = prune,
+        use.names = use.names, verbose = verbose, timeout = timeout, ...
     )
     return(linkmap)
 })
@@ -25,7 +25,7 @@ setMethod("weaveComplex", signature = c(graph = "data.frame"),
 #' @importFrom Matrix summary
 setMethod("weaveComplex", signature = c(graph = "igraph"),
     function(graph, by, k = 1, include = NULL, exclude = NULL, res.name = NULL,
-    init = NULL, prune = TRUE, use.names = TRUE, threshold = NULL,
+    init = NULL, threshold = NULL, prune = TRUE, use.names = TRUE,
     verbose = TRUE, timeout = 1e6, ...){
     # Check threshold
     if( !is.null(threshold) && (!is.numeric(threshold) ||