highlight_entities accept named numeric vector

R/highlight_functions.R

@@ -1,10 +1,13 @@
 #' highlight_entities
 #' 
 #' highlight the entities in the pathway,
-#' overlay raw map and return the results
+#' overlay raw map and return the results.
+#' Note that highlighted nodes are considered to be rectangular,
+#' so it is not compatible with the type like `compound`.
 #' 
 #' @param pathway pathway ID to be passed to `pathway()`
-#' @param set vector of identifiers
+#' @param set vector of identifiers, or named vector of numeric values
+#' @param num_combine combining function if multiple hits are obtained per node
 #' @param how if `all`, if node contains multiple
 #' IDs separated by `sep`, highlight if all the IDs
 #' are in query. if `any`, highlight if one of the IDs
@@ -22,43 +25,71 @@
 #' @export
 #'
 highlight_entities <- function(pathway, set, how="any",
-	name="graphics_name", sep=",", no_sep=FALSE,
+	num_combine=mean, name="graphics_name", sep=",", no_sep=FALSE,
 	show_type="gene", fill_color="tomato",
 	legend_name=NULL, use_cache=FALSE) {
 	graph <- pathway(pathway, use_cache=use_cache)
 	x <- get.vertex.attribute(graph, name)
-    vec <- vapply(seq_along(x), function(xn) {
-        if (no_sep) {
-            nn <- x[xn]
-        } else {
-            nn <- unlist(strsplit(x[xn], sep))
-        }
-        if (how == "all") {
-            if (length(intersect(nn, set)) == length(nn)) {
-                return(TRUE)
+
+	if (is.null(names(set))) {## Discrete
+	    vec <- vapply(seq_along(x), function(xn) {
+	        if (no_sep) {
+	            nn <- x[xn]
+	        } else {
+	            nn <- unlist(strsplit(x[xn], sep)) |> unique()
+	        }
+	        if (how == "all") {
+	            if (length(intersect(nn, set)) == length(nn)) {
+	                return(TRUE)
+	            } else {
+	                return(FALSE)
+	            }
+	        } else {
+	            if (length(intersect(nn, set)) >= 1) {
+	                return(TRUE)
+	            } else {
+	                return(FALSE)
+	            }      
+	        }
+	    }, FUN.VALUE=TRUE)
+	    graph <- graph |> mutate(highlight=vec)
+
+	    res <- ggraph(graph, layout="manual", x=.data$x, y=.data$y) + 
+	        geom_node_rect(aes(filter=.data$type %in% show_type,
+	            fill=.data$highlight))+
+	        scale_fill_manual(values=c("grey", fill_color), name=legend_name)+
+	        overlay_raw_map()+
+	        theme_void()
+	    if (is.null(legend_name)) {
+	    	res <- res + theme(legend.position="none")    	
+	    }
+	} else {## Numeric
+		vec <- lapply(seq_along(x), function(xn) {
+			if (no_sep) {
+				nn <- x[xn]
+			} else {
+				nn <- unlist(strsplit(x[xn], sep)) |> unique()
+			}
+            thresh <- ifelse(how=="any", 1, length(nn))
+            if (length(intersect(names(set), nn)) >= thresh) {
+                summed <- do.call(num_combine,
+                    list(x=set[intersect(names(set), nn)]))
             } else {
-                return(FALSE)
+                summed <- NA
             }
-        } else {
-            if (length(intersect(nn, set)) >= 1) {
-                return(TRUE)
-            } else {
-                return(FALSE)
-            }      
-        }
-    }, FUN.VALUE=TRUE)
-    graph <- graph |> mutate(highlight=vec)
-
-    res <- ggraph(graph, layout="manual", x=.data$x, y=.data$y) + 
-        geom_node_rect(aes(filter=.data$type %in% show_type,
-            fill=.data$highlight))+
-        scale_fill_manual(values=c("grey", fill_color), name=legend_name)+
-        overlay_raw_map()+
-        theme_void()
-    if (is.null(legend_name)) {
-    	res <- res + theme(legend.position="none")    	
-    }
-    res
+		}) |> unlist()
+	    graph <- graph |> mutate(highlight=vec)
+	    res <- ggraph(graph, layout="manual", x=.data$x, y=.data$y) + 
+	        geom_node_rect(aes(filter=.data$type %in% show_type,
+	            fill=.data$highlight))+
+	        scale_fill_continuous(name=legend_name)+
+	        overlay_raw_map()+
+	        theme_void()
+	    if (is.null(legend_name)) {
+	    	res <- res + theme(legend.position="none")    	
+	    }
+	}
+	return(res)
 }