--- a +++ b/R/combine_layers.R @@ -0,0 +1,240 @@ +#' Combine layers +#' +#' Return a merged graph from two graph layers. +#' +#' @param graph1 an igraph object or list of igraph (\code{list.igraph}). +#' @param graph2 an igraph object or list of igraph (\code{list.igraph}) with +#' the same length as \code{graph1}. +#' @param interaction.df (optional) a 2 colomns data.frame (from, to) +#' describing the edges between vertices from both graphs. +#' +#' @details +#' If \code{graph2} is a single graph, it will be merged to each element of +#' \code{graph1} (\code{igraph} or \code{list.igraph}). +#' +#' If \code{graph2} is a list of graph (\code{list.igraph}), each element of +#' \code{graph1} and each element of \code{graph2} are merged in pairs. +#' +#' Optionally, \code{interaction.df} should be provide if any vertex are shared +#' between graphs. It can also be used to extend the first graph. +#' +#' In both scenarios, vertex attributes are kept. If a vertex attribute is +#' missing from graph1 or graph2, NULL value is added. +#' Otherwise, if there is an overlap between attribute values for the same +#' vertex, attribute from graph2 is dropped. +#' +#' @return +#' a merged graph with both vertex attributes from graph1 and graph2. +#' +#' @examples +#' # with single graphs +#' graph1 <- igraph::graph_from_data_frame(list(from = c('A', 'B'), +#' to = c('B', 'C')), +#' directed = FALSE) +#' graph2 <- igraph::graph_from_data_frame(list(from = c(1), +#' to = c(2)), +#' directed = FALSE) +#' res <- combine_layers(graph1 = graph1, +#' graph2 = graph2) +#' +#' # with list of graphs +#' graph1.list <- list(graph1, graph1) +#' graph2.list <- list(graph2, graph2) +#' class(graph1.list) <- class(graph2.list) <- 'list.igraph' +#' +#' res <- combine_layers(graph1 = graph1.list, +#' graph2 = graph2) +#' res <- combine_layers(graph1 = graph1.list, +#' graph2 = graph2.list) +#' +#' # with interaction dataframe +#' interaction.df1 <- as.data.frame(list(from = c('C', 'B'), to = c(1, 2))) +#' res <- combine_layers(graph1 = graph1.list, +#' graph2 = graph2, +#' interaction.df = interaction.df1) +#' +#' +#' @importFrom purrr is_empty map reduce map2 +#' @importFrom igraph induced_subgraph +#' @importFrom igraph set_vertex_attr +#' @importFrom igraph adjacent_vertices +#' @importFrom igraph graph_from_data_frame +#' @importFrom igraph vcount +#' @importFrom igraph V +#' @importFrom igraph as.undirected + +#' @export +combine_layers <- function(graph1, + graph2 = NULL, + interaction.df = NULL) { + + # check graph1 + if (!is(graph1, "igraph") & !is(graph1, "list.igraph")) { + stop("graph1 must be an igraph or list.igraph object") + } + if (is(graph1, "list.igraph")) { + if (is.null(names(graph1))) { + names(graph1) <- seq_along(graph1) + } + } + + if (!is(graph2, "igraph") & !is(graph2, "list.igraph") & !is.null(graph2)) { + stop("graph2 must be an igraph or list.igraph object or NULL") + } + if (!is.null(interaction.df)) { + interaction.df <- check_db(interaction.df) + + if (!is(interaction.df, "igraph")) { + interaction.df <- interaction.df %>% + dplyr::select(c("from", "to")) + interaction.graph <- igraph::graph_from_data_frame(interaction.df, + directed = FALSE) + } else { + interaction.graph <- igraph::as.undirected(interaction.df) + } + } + + # case1: graph2 = NULL, interaction.df = NULL + if (is.null(graph2) & is.null(interaction.df)) { + merged.res <- graph1 + } + + # case2: graph1 and graph2 are single graph (+ interaction.df) + if (is(graph1, "igraph") & is(graph2, "igraph")) { + merged.res <- merge_graphs(graph1, graph2) + if (!is.null(interaction.df)) { + # interaction.graph can be not found, df can be NULL + interaction.graph.induced <- igraph::induced_subgraph( + graph = interaction.graph, + vids = intersect(igraph::V(interaction.graph)$name, + igraph::V(merged.res)$name)) + merged.res <- merge_graphs(merged.res, + interaction.graph.induced) + } + + # case3: graph1 is a list and graph2 is a single graph + # (+ interaction.df) + } else if (is(graph1, "list.igraph") & is(graph2, "igraph")) { + merged.res <- purrr::map(graph1, ~{ + merge_graphs(.x, graph2) + }) + names(merged.res) <- names(graph1) + if (!is.null(interaction.df)) { + # interaction.graph can be not found, df can be NULL + # merged.res <- list() # already defined + for (i in names(merged.res)) { + interaction.graph.induced <- igraph::induced_subgraph( + graph = interaction.graph, + vids = intersect(igraph::V(interaction.graph)$name, + igraph::V(merged.res[[i]])$name)) + merged.res[[i]] <- merge_graphs(merged.res[[i]], + interaction.graph.induced) + } + } + + # case4: graph1 and graph2 are list of graph (+ interaction.df) + } else if (is(graph1, "list.igraph") & is(graph2, "list.igraph")) { + if (length(graph1) != length(graph2)) { + stop("graph1 and graph2 must have the same length") + } + if (!is.null(names(graph1)) & !is.null(names(graph2))) { + # graph1 and graph2 have names same length + # so reciprocal is TRUE they don't have the same names + if (!all(names(graph1) %in% names(graph2))) { + stop("graph1 and graph2 must have the same names") + } else { + merged.res <- purrr::map2(graph1, graph2[names(graph1)], ~{ + merge_graphs(.x, .y) + }) + } + } else { + # no names, don't care about the order + merged.res <- purrr::map2(graph1, graph2, ~{ + merge_graphs(.x, .y) + }) + names(merged.res) <- names(graph1) + } + if (!is.null(interaction.df)) { + # interaction.graph can be not found, df can be NULL + for (i in names(merged.res)) { + interaction.graph.induced <- igraph::induced_subgraph( + graph = interaction.graph, + vids = intersect(igraph::V(interaction.graph)$name, + igraph::V(merged.res[[i]])$name)) + merged.res[[i]] <- merge_graphs(merged.res[[i]], + interaction.graph.induced) + } + } + + # case5: inverse of case3 -> error + } else if (is(graph1, "igraph") & is(graph2, "list.igraph")) { + stop("graph1 and graph2 must have the same length") + + # case6: graph1 and interaction.df + } else if (is(graph1, "igraph") & + is.null(graph2) & + !is.null(interaction.df)) { + interaction.df.sub <- interaction.df %>% + dplyr::filter(.$from %in% igraph::V(graph1)$name | + .$to %in% igraph::V(graph1)$name) + interaction.graph <- igraph::graph_from_data_frame(interaction.df.sub, + directed = FALSE) + merged.res <- merge_graphs(graph1, interaction.graph) + + # case7: graph1 list and interaction.df + } else if (is(graph1, "list.igraph") & + is.null(graph2) & + !is.null(interaction.df)) { + merged.res <- list() + for (i in names(graph1)) { + interaction.df.sub <- interaction.df %>% + dplyr::filter(.$from %in% igraph::V(graph1[[i]])$name | + .$to %in% igraph::V(graph1[[i]])$name) + interaction.graph <- igraph::graph_from_data_frame( + interaction.df.sub, + directed = FALSE) + merged.res[[i]] <- merge_graphs(graph1[[i]], interaction.graph) + } + } + + if (is(merged.res, "list")) { + class(merged.res) <- c("list.igraph", "list.merged.igraph") + } + return(merged.res) +} + + +#' @importFrom igraph vertex_attr +#' @importFrom igraph union +#' @importFrom igraph delete_vertex_attr +#' @importFrom igraph set_vertex_attr +#' @importFrom igraph vcount +merge_graphs <- function(graph1, + graph2) { + # shared attr except 'name' + shared_attr <- intersect(names(igraph::vertex_attr(graph1)), + names(igraph::vertex_attr(graph2))) + shared_attr <- shared_attr[!(shared_attr == "name")] + + merged_graphs <- igraph::union(graph1, graph2) + # vertex_attr(merged_graphs) %>% as.data.frame() + merged_attr <- igraph::vertex_attr(merged_graphs) + for (sa in shared_attr) { + merged_attr[[sa]] <- vector(length = igraph::vcount(merged_graphs)) + for (i in seq_along(merged_attr[[sa]])) { + # if !is.na _1, return _1 else return _2 + merged_attr[[sa]][i] <- + ifelse(!is.na(merged_attr[[paste0(sa, "_1")]][i]), + merged_attr[[paste0(sa, "_1")]][i], + merged_attr[[paste0(sa, "_2")]][i]) + } + merged_graphs <- delete_vertex_attr(graph = merged_graphs, + name = paste0(sa, "_1")) + merged_graphs <- delete_vertex_attr(graph = merged_graphs, + name = paste0(sa, "_2")) + merged_graphs <- set_vertex_attr(graph = merged_graphs, + name = sa, value = merged_attr[[sa]]) + } + class(merged_graphs) <- c("merged.igraph", "igraph") + return(merged_graphs) +}