--- a +++ b/R/2-2.manipulate.R @@ -0,0 +1,787 @@ +# ==========2.1 manipulate======== + +#' Set basic attributes from totu table +#' +#' @param go metanet an igraph object +#' @param ... some data.frames to annotate go +#' @param vertex_group choose which column to be vertex_group (map to vertex_shape) +#' @param vertex_class choose which column to be vertex_class (map to vertex_color) +#' @param vertex_size choose which column to be vertex_size (map to vertex_size) +#' @param edge_type choose which column to be edge_type (map to edge_color) +#' @param edge_class choose which column to be edge_class (map to edge_linetype) +#' @param edge_width choose which column to be edge_width (map to edge_width) +#' @param node_break node_break if v_class is numeric, default: 5 +#' @param edge_break edge_break if e_type is numeric, default: 5 +#' @param initialize initialize, default: TRUE +#' +#' @return a metanet object +#' @export +#' @family build +#' @examples +#' data("otutab", package = "pcutils") +#' t(otutab) -> totu +#' metadata[, 3:10] -> env +#' +#' data("c_net") +#' co_net <- c_net_set(co_net, taxonomy, data.frame("Abundance" = colSums(totu)), +#' vertex_class = "Phylum", vertex_size = "Abundance" +#' ) +#' co_net2 <- c_net_set(co_net2, taxonomy, data.frame(name = colnames(env), env = colnames(env)), +#' vertex_class = c("Phylum", "env") +#' ) +#' co_net2 <- c_net_set(co_net2, data.frame("Abundance" = colSums(totu)), vertex_size = "Abundance") +c_net_set <- function(go, ..., vertex_group = "v_group", vertex_class = "v_class", vertex_size = "size", + edge_type = "e_type", edge_class = "e_class", edge_width = "width", + node_break = 5, edge_break = 5, initialize = TRUE) { + size <- e_class <- width <- NULL + c_net_update(go, verbose = FALSE) -> go + name <- v_group <- v_class <- e_type <- color <- NULL + + # annotation vertex + anno_dfs <- list(...) + if (length(anno_dfs) > 0) { + anno_dfs2 <- list() + for (i in seq_len(length(anno_dfs))) { + x <- anno_dfs[[i]] + if ("name" %in% colnames(x)) { + rownames(x) <- x$name + x <- dplyr::select(x, -name) + } + anno_dfs2[[i]] <- x + } + + if (any(duplicated(lapply(anno_dfs2, names) %>% unlist()))) stop("Duplicated column names in your annotation tables, please check!") + + Reduce(\(x, y)merge(x, y, by = "row.names", all = TRUE) %>% + tibble::column_to_rownames("Row.names"), anno_dfs2) -> all_anno + + anno_vertex(go, all_anno) -> go + } + get_v(go) -> v_index + get_e(go) -> e_index + + # set something + # !!!这里的set要改成跟c_net_update一样的逻辑 + if (!setequal(vertex_group, "v_group")) dplyr::select(v_index, v_group, !!vertex_group) %>% condance() -> v_index$v_group + + if (!setequal(vertex_class, "v_class")) { + old_color <- twocol2vector(v_index[, c("v_class", "color")]) + new_color_name <- c() + + # 给每一个v_group加上v_class调整颜色 + # 可能某一个group用numeric做v_class,所以要分开上色 + for (i in unique(v_index$v_group)) { + tmp_index <- v_index[v_index$v_group == i, ] + tmp_v_class <- dplyr::select(tmp_index, v_class, !!vertex_class) %>% condance() + if (identical(tmp_v_class, tmp_index$v_class)) { + new_color_name <- c(new_color_name, unique(tmp_index$v_class)) + next + } + if (is.numeric(tmp_v_class)) { + tmp_v_color <- color_generate(tmp_v_class, n_break = node_break, mode = "v") + tmp_v_class <- color_generate(tmp_v_class, n_break = node_break, mode = "label") + v_index[v_index$v_group == i, "color"] <- tmp_v_color + } else { + new_color_name <- c(new_color_name, unique(tmp_index$v_class)) + } + v_index[v_index$v_group == i, "v_class"] <- as.character(tmp_v_class) + } + # 总体分类颜色是否改变,没变的话就不该,变了的话全部重新赋 + new_color_name <- unique(new_color_name) + if (!all(new_color_name %in% names(old_color))) { + new_color <- setNames(pcutils::get_cols(length(new_color_name), pal = default_v_color), new_color_name) + v_index$color <- condance(data.frame( + v_index$color, + pcutils::tidai(v_index$v_class, new_color) + )) + } + } + + if (!setequal(vertex_size, "size")) dplyr::select(v_index, size, !!vertex_size) %>% condance() -> v_index$size + + if (!setequal(edge_type, "e_type")) { + tmp_e_type <- dplyr::select(e_index, e_type, !!edge_type) %>% condance() + if (!identical(tmp_e_type, e_index$e_type)) { + tmp_e_color <- color_generate(tmp_e_type, edge_break, mode = "e") + tmp_e_type <- color_generate(tmp_e_type, edge_break, mode = "label") + e_index$e_type <- tmp_e_type + e_index$color <- tmp_e_color + } + } + if (!setequal(edge_class, "e_class")) dplyr::select(e_index, e_class, !!edge_class) %>% condance() -> e_index$e_class + if (!setequal(edge_width, "width")) dplyr::select(e_index, width, !!edge_width) %>% condance() -> e_index$width + + as.list(v_index) -> igraph::vertex.attributes(go) + as.list(e_index) -> igraph::edge.attributes(go) + + c_net_update(go, initialize = initialize, verbose = FALSE) -> go2 + return(go2) +} + + +#' Is this object a metanet object? +#' +#' @param go a test object +#' +#' @return logical +#' @export +#' @aliases is.metanet +#' @family manipulate +#' @examples +#' data(c_net) +#' is_metanet(co_net) +is_metanet <- function(go) { + is.igraph(go) & inherits(go, "metanet") +} + +#' Get vertex information +#' +#' @param go metanet object +#' @param index attribute name, default: NULL +#' @family manipulate +#' @return data.frame +#' @export +get_v <- function(go, index = NULL) { + # 规定name只能为字符 + if (is.null(V(go)$name)) V(go)$name <- as.character(V(go)) + # df <- as.data.frame(igraph::vertex.attributes(go)) + igraph::as_data_frame(go, what = "vertices") -> df + df <- dplyr::select(df, name, dplyr::everything()) + rownames(df) <- NULL + if (!is.null(index)) { + return(dplyr::select(df, !!index)) + } else { + return(df) + } +} + +#' Get edge information +#' @param go metanet object +#' @param index attribute name, default: NULL +#' @return data.frame +#' @family manipulate +#' @export +get_e <- function(go, index = NULL) { + id <- NULL + tmp_e <- cbind_new(igraph::as_data_frame(go), data.frame(id = seq_len(igraph::ecount(go)))) + tmp_e <- dplyr::select(tmp_e, id, dplyr::everything()) + if (!is.null(index)) { + return(dplyr::select(tmp_e, !!index)) + } else { + return(tmp_e) + } +} + +#' Get network information +#' +#' @param go metanet object +#' @param index attribute name, default: NULL +#' @param simple logical, get simple index +#' @family manipulate +#' @return data.frame +#' @export +get_n <- function(go, index = NULL, simple = FALSE) { + gls <- igraph::graph.attributes(go) + if (simple) { + gls <- lapply(gls, \(x){ + if (inherits(x, "data.frame")) { + return(NULL) + } + if (is.array(x)) { + return(NULL) + } + if (is.list(x)) { + return(NULL) + } + if (length(x) > 1) { + return(NULL) + } + return(x) + }) + } else { + gls <- lapply(gls, \(x){ + if (inherits(x, "data.frame")) { + return(paste0(ncol(x), "-columns df")) + } + if (is.array(x)) { + return(paste0(length(x), "-elements ", class(x))) + } + if (is.list(x)) { + return(paste0(length(x), "-elements ", class(x))) + } + if (length(x) > 1) { + return(paste0(length(x), "-elements vector")) + } + return(x) + }) + } + df <- as.data.frame(do.call(cbind, gls)) + if (!is.null(index)) { + return(dplyr::select(df, !!index)) + } else { + return(df) + } +} + +#' Filter a network according to some attributes +#' +#' @param go metanet object +#' @param ... some attributes of vertex and edge +#' @param mode "v" or "e" +#' +#' @return metanet +#' @export +#' @family manipulate +#' @examples +#' data("multi_net") +#' c_net_filter(multi1, v_group %in% c("omic1", "omic2")) +c_net_filter <- function(go, ..., mode = "v") { + if (mode == "v") { + go1 <- filter_v(go, ...) + } else if (mode == "e") { + go1 <- filter_e(go, ...) + } else { + stop("mode should be 'v' or 'e'") + } + if (length(V(go1)) == 0) { + message("The network is empty.") + } + go1 +} + +filter_v <- function(go, ...) { + get_v(go) -> tmp_v + tmp_v <- dplyr::filter(tmp_v, ...) + tmp_v$name -> vid + igraph::subgraph(go, vid) -> go1 + class(go1) <- c("metanet", "igraph") + go1 +} + +filter_e <- function(go, ...) { + get_e(go) -> tmp_e + tmp_e <- dplyr::filter(tmp_e, ...) + tmp_e$id -> eid + igraph::subgraph.edges(go, eid) -> go1 + class(go1) <- c("metanet", "igraph") + go1 +} + + +#' Union two networks +#' +#' @param go1 metanet object +#' @param go2 metanet object +#' +#' @return metanet +#' @export +#' @family manipulate +#' @examples +#' data("c_net") +#' co_net_union <- c_net_union(co_net, co_net2) +#' c_net_plot(co_net_union) +c_net_union <- function(go1, go2) { + tmp_v1 <- get_v(go1) + tmp_v2 <- get_v(go2) + cols <- c("name", "label", "size", "v_group", "shape", "v_class", "color") + tmp_v <- rbind(tmp_v1[cols], tmp_v2[cols]) + message("Duplicated vertexes: ", sum(duplicated(tmp_v$name)), "\nUse the attributes of the first network.") + tmp_v <- tmp_v[!duplicated(tmp_v$name), ] + + tmp_e1 <- get_e(go1) + tmp_e2 <- get_e(go2) + cols <- c("from", "to", "e_type", "color", "e_class", "lty", "width") + tmp_e <- rbind(tmp_e1[cols], tmp_e2[cols]) + message("Duplicated edges: ", sum(duplicated(tmp_e[, c("from", "to")])), "\nUse the attributes of the first network.") + tmp_e <- tmp_e[!duplicated(tmp_e[, c("from", "to")]), ] + + go <- igraph::union(go1, go2) + go <- clean_igraph(go, direct = FALSE) + go <- c_net_annotate(go, tmp_v, mode = "v") + go <- c_net_annotate(go, tmp_e, mode = "e") + go <- c_net_annotate(go, list(n_type = "combine_net"), mode = "n") + go <- c_net_update(go, initialize = TRUE) + go +} + + +#' Annotate a metanet +#' +#' @param go metanet object +#' @param anno_tab a dataframe using to annotate (mode v, e), or a list (mode n) +#' @param mode "v" for vertex, "e" for edge, "n" for network +#' @param verbose logical +#' +#' @return a annotated metanet object +#' @export +#' @family manipulate +#' @examples +#' data("c_net") +#' anno <- data.frame("name" = "s__Pelomonas_puraquae", new_atr = "new") +#' co_net_new <- c_net_annotate(co_net, anno, mode = "v") +#' get_v(co_net_new, c("name", "new_atr")) +#' +#' anno <- data.frame("from" = "s__Pelomonas_puraquae", "to" = "s__un_g__Rhizobium", new_atr = "new") +#' co_net_new <- c_net_annotate(co_net, anno, mode = "e") +#' get_e(co_net_new, c("from", "to", "new_atr")) +#' +#' co_net_new <- c_net_annotate(co_net, list(new_atr = "new"), mode = "n") +#' get_n(co_net_new) +c_net_annotate <- function(go, anno_tab, mode = "v", verbose = TRUE) { + mode <- match.arg(mode, c("v", "e", "n")) + if (mode == "v") { + anno_vertex(go, anno_tab, verbose = verbose) -> go + } else if (mode == "e") { + anno_edge(go, anno_tab, verbose = verbose) -> go + } else if (mode == "n") { + igraph::graph.attributes(go) <- + pcutils::update_param(igraph::graph.attributes(go), anno_tab) + } + go +} + + +#' Use data.frame to annotate vertexes of metanet +#' +#' @param go metanet object +#' @param verbose logical +#' @param anno_tab a dataframe using to annotate (with rowname or a "name" column) +#' +#' @return a annotated metanet object +#' @aliases anno_node +#' @export +#' @family manipulate +#' @examples +#' data("c_net") +#' data("otutab", package = "pcutils") +#' anno_vertex(co_net, taxonomy) +anno_vertex <- function(go, anno_tab, verbose = TRUE) { + if (is.null(anno_tab)) { + return(go) + } + get_v(go) -> v_atr + if (!"name" %in% colnames(anno_tab)) rownames(anno_tab) -> anno_tab$name + if (any(duplicated(anno_tab$name))) { + stop( + "Duplicated name in annotation tables: ", + paste0(anno_tab$name[duplicated(anno_tab$name)], collapse = ", ") + ) + } + v_atr <- dplyr::left_join(v_atr, anno_tab, by = "name", suffix = c(".x", "")) + grep(".x", colnames(v_atr), value = TRUE) %>% gsub(".x", "", .) -> du + if (length(du) > 0) message(length(du), (" attributes will be overwrited:\n"), paste0(du, collapse = ", "), "\n") + v_atr %>% dplyr::select(!dplyr::ends_with(".x")) -> v_atr + + as.list(v_atr) -> igraph::vertex.attributes(go) + return(go) +} + +#' Use dataframe to annotate edges of an igraph +#' +#' @param go metanet an igraph object +#' @param verbose logical +#' @param anno_tab a dataframe using to annotate (with rowname or a name column) +#' +#' @return a annotated igraph object +#' @export +#' @family manipulate +#' @examples +#' data("c_net") +#' anno <- data.frame("from" = "s__Pelomonas_puraquae", "to" = "s__un_g__Rhizobium", new_atr = "new") +#' anno_edge(co_net, anno) -> anno_net +anno_edge <- function(go, anno_tab, verbose = TRUE) { + name <- NULL + if (is.null(anno_tab)) { + return(go) + } + get_e(go) -> e_atr + if (all(c("from", "to") %in% colnames(anno_tab))) { + e_atr <- dplyr::left_join(e_atr, anno_tab, by = c("from", "to"), suffix = c(".x", "")) + grep(".x", colnames(e_atr), value = TRUE) %>% gsub(".x", "", .) -> du + if (length(du) > 0) { + if (verbose) message(length(du), (" attributes will be overwrited:\n"), paste0(du, collapse = ","), "\n") + } + e_atr %>% dplyr::select(!dplyr::ends_with(".x")) -> e_atr + } else { + if (verbose) message("No 'from' and 'to' columns in annotation table, will use 'name_from' and 'name_to' instead.") + if (!"name" %in% colnames(anno_tab)) rownames(anno_tab) -> anno_tab$name + anno_tab %>% dplyr::select(name, dplyr::everything()) -> anno_tab + # from + tmp <- anno_tab + colnames(tmp) <- paste0(colnames(anno_tab), "_from") + e_atr <- dplyr::left_join(e_atr, tmp, by = c("from" = "name_from"), suffix = c(".x", "")) + grep(".x", colnames(e_atr), value = TRUE) %>% gsub(".x", "", .) -> du + if (length(du) > 0) { + if (verbose) message(length(du), (" attributes will be overwrited:\n"), paste0(du, collapse = ","), "\n") + } + e_atr %>% dplyr::select(!dplyr::ends_with(".x")) -> e_atr + # to + tmp <- anno_tab + colnames(tmp) <- paste0(colnames(anno_tab), "_to") + e_atr <- dplyr::left_join(e_atr, tmp, by = c("to" = "name_to"), suffix = c(".x", "")) + grep(".x", colnames(e_atr), value = TRUE) %>% gsub(".x", "", .) -> du + if (length(du) > 0) { + if (verbose) message(length(du), (" attributes will be overwrited:\n"), paste0(du, collapse = ","), "\n") + } + e_atr %>% dplyr::select(!dplyr::ends_with(".x")) -> e_atr + } + as.list(e_atr) -> igraph::edge.attributes(go) + return(go) +} + +#' Save network file +#' +#' @param go metanet network +#' @param filename filename +#' @param format "data.frame","graphml" +#' @return No value +#' @family manipulate +#' @export +c_net_save <- function(go, filename = "net", format = "data.frame") { + if (format == "data.frame") { + get_v(go) %>% write.csv(., paste0(filename, "_nodes.csv"), row.names = FALSE) + get_e(go) %>% + dplyr::select(-1) %>% + write.csv(., paste0(filename, "_edges.csv"), row.names = FALSE) + } else if (format == "graphml") { + if ("id" %in% edge.attributes(go)) go <- igraph::delete_edge_attr(go, "id") + if (!grepl("\\.graphml$", filename)) filename <- paste0(filename, ".graphml") + igraph::write_graph(go, filename, format = "graphml") + } else { + if (!grepl(paste0("\\.", format), filename)) filename <- paste0(filename, ".", format) + igraph::write_graph(go, filename, format = format) + } + message(paste0(filename, " saved sucessfully!")) +} + +#' Load network file +#' +#' @inheritParams c_net_save +#' +#' @return metanet +#' @export +#' @family manipulate +c_net_load <- function(filename, format = "data.frame") { + if (format == "data.frame") { + nodes <- read.csv(paste0(filename, "_nodes.csv"), stringsAsFactors = FALSE) + edges <- read.csv(paste0(filename, "_edges.csv"), stringsAsFactors = FALSE) + c_net_from_edgelist(edges, vertex_df = nodes) -> go + } else if (format == "cyjs") { + lib_ps("jsonify", library = FALSE) + if (!grepl("\\.cyjs$", filename)) filename <- paste0(filename, ".cyjs") + jsonify::from_json(filename) -> G + + if (!is.data.frame(G$elements$nodes$data)) { + names <- lapply(G$elements$nodes$data, names) + comm_name <- Reduce(intersect, names) + lapply(G$elements$nodes$data, \(i)i[comm_name]) -> G$elements$nodes$data + G$elements$nodes$data <- list_to_dataframe(G$elements$nodes$data) + } + + node <- cbind_new(G$elements$nodes$data, G$elements$nodes$position) + node$y <- -node$y + node <- node[, colnames(node) != "name"] + colnames(node)[1] <- "name" + + edge <- G$elements$edges$data + edge <- edge[, !colnames(edge) %in% c("from", "to")] + colnames(edge)[1:3] <- c("id", "from", "to") + c_net_from_edgelist(edge, node) -> go + } else if (format == "graphml") { + if (!grepl("\\.graphml$", filename)) filename <- paste0(filename, ".graphml") + igraph::read_graph(filename, format = "graphml") -> go + go <- c_net_update(go, initialize = TRUE) + } else { + if (!grepl(paste0("\\.", format), filename)) filename <- paste0(filename, ".", format) + igraph::read_graph(filename, format = format) -> go + go <- c_net_update(go, initialize = TRUE) + } + go +} + +#' Summaries two columns information +#' @param df data.frame +#' @param from first column name or index +#' @param to second column name or index +#' @param count (optional) weight column, if no, each equal to 1 +#' @param direct consider direct? default: FALSE +#' +#' @return data.frame +#' @export +#' @examples +#' test <- data.frame( +#' a = sample(letters[1:4], 10, replace = TRUE), +#' b = sample(letters[1:4], 10, replace = TRUE) +#' ) +#' summ_2col(test, direct = TRUE) +#' summ_2col(test, direct = FALSE) +#' if (requireNamespace("circlize")) { +#' summ_2col(test, direct = TRUE) %>% pcutils::my_circo() +#' } +summ_2col <- function(df, from = 1, to = 2, count = 3, direct = FALSE) { + if (ncol(df) < 2) stop("need at least two columns") + if (ncol(df) == 2) { + tmp <- cbind(df, count = 1) + } else { + tmp <- dplyr::select(df, !!from, !!to, !!count) + } + cols <- colnames(tmp) + colnames(tmp) <- c("from", "to", "count") + + if (direct) { + tmp <- (dplyr::group_by(tmp, from, to) %>% dplyr::summarise(count = sum(count))) + colnames(tmp) <- cols + return(as.data.frame(tmp)) + } + + com <- \(group1, group2, levels){ + factor(c(group1, group2), levels = levels) %>% sort() + } + + group <- factor(c(tmp[, 1], tmp[, 2])) + tmp1 <- apply(tmp, 1, function(x) com(x[1], x[2], levels(group))) %>% + t() %>% + as.data.frame() + + tmp1 <- cbind(tmp1, tmp$count) + colnames(tmp1) <- c("from", "to", "count") + tmp1 <- dplyr::group_by(tmp1, from, to) %>% dplyr::summarise(count = sum(count)) + colnames(tmp1) <- cols + return(as.data.frame(tmp1)) +} + + +#' Get skeleton network according to a group +#' +#' @param go network +#' @param Group vertex column name +#' @param count take which column count, default: NULL +#' @param top_N top_N +#' +#' @return skeleton network +#' @export +#' @family topological +#' @examples +#' get_group_skeleton(co_net) -> ske_net +#' skeleton_plot(ske_net) +get_group_skeleton <- function(go, Group = "v_class", count = NULL, top_N = 8) { + name <- v_group <- n <- NULL + stopifnot(is_igraph(go)) + direct <- igraph::is_directed(go) + + if (!Group %in% vertex_attr_names(go)) stop("no Group named ", Group, " !") + get_v(go) -> tmp_v + tmp_v %>% dplyr::select(name, !!Group) -> nodeGroup + colnames(nodeGroup) <- c("name", "Group") + nodeGroup$Group <- as.factor(nodeGroup$Group) + # summary edges counts in each e_type + suppressMessages(anno_edge(go, nodeGroup) %>% get_e() -> edge) + { + if (is.null(count)) { + edge$count <- 1 + } else { + edge$count <- edge[, count] + } + } + bb <- data.frame() + for (i in unique(edge$e_type)) { + tmp <- edge[edge$e_type == i, c("Group_from", "Group_to", "count")] + tmp <- dplyr::mutate_if(tmp, is.factor, as.character) + # tmp=pcutils:::gettop(tmp,top_N) + bb <- rbind(bb, data.frame(summ_2col(tmp, + direct = direct + ), e_type = i)) + } + tmp_go <- igraph::graph_from_data_frame(bb, directed = direct) + nodeGroup <- cbind_new(nodeGroup, data.frame(v_group = tmp_v$v_group)) + + # nodeGroup=mutate_all(nodeGroup,as.character) + # nodeGroup=rbind(nodeGroup,c("others","others","others")) + + dplyr::distinct(nodeGroup, Group, v_group) %>% tibble::column_to_rownames("Group") -> v_group_tab + + V(tmp_go)$v_group <- v_group_tab[V(tmp_go)$name, "v_group"] + V(tmp_go)$v_class <- V(tmp_go)$name + V(tmp_go)$size <- stats::aggregate(tmp_v$size, by = list(tmp_v[, Group]), sum) %>% + tibble::column_to_rownames("Group.1") %>% + .[V(tmp_go)$name, "x"] + suppressWarnings({ + V(tmp_go)$count <- tmp_v %>% + dplyr::group_by_(Group) %>% + dplyr::count() %>% + tibble::column_to_rownames(Group) %>% + .[V(tmp_go)$name, "n"] + }) + + tmp_go <- c_net_update(tmp_go, initialize = TRUE) + get_e(tmp_go) -> tmp_e + + E(tmp_go)$width <- E(tmp_go)$label <- tmp_e$count + + graph.attributes(tmp_go)$n_type <- "skeleton" + graph.attributes(tmp_go)$skeleton <- Group + tmp_go +} + +#' Skeleton plot +#' +#' @param ske_net skeleton +#' @param split_e_type split by e_type? default: TRUE +#' @param ... additional parameters for \code{\link[igraph]{igraph.plotting}} +#' +#' @export +#' @rdname get_group_skeleton +skeleton_plot <- function(ske_net, split_e_type = TRUE, ...) { + e_type <- NULL + params <- list(...) + tmp_go <- ske_net + if (get_n(tmp_go)$n_type != "skeleton") stop("Not a skeleton network") + get_e(tmp_go) -> tmp_e + + if (split_e_type) { + for (i in unique(tmp_e$e_type)) { + # main plot + tmp_go1 <- c_net_filter(tmp_go, e_type == i, mode = "e") + do.call(c_net_plot, pcutils::update_param( + list(go = tmp_go1, legend_number = TRUE, edge_width_range = c(1, 5)), params + )) + } + } else { + tmp_go <- clean_multi_edge_metanet(tmp_go) + do.call(c_net_plot, pcutils::update_param( + list(go = tmp_go, legend_number = TRUE, edge_width_range = c(1, 5)), params + )) + } +} + +# 整理skeleton网络的边,使其尽量不重叠。 +# 1.from-to都是自己时,添加edge.loop.angle +# 2.from-to一致时,添加edge.curved +# 3.from-to刚好相反时,添加edge.curved + + +#' Clean multi edge metanet to plot +#' @param go metanet object +#' +#' @return metanet object +#' @export +#' +#' @examples +#' g <- igraph::make_ring(2) +#' g <- igraph::add.edges(g, c(1, 1, 1, 1, 2, 1)) +#' plot(g) +#' plot(clean_multi_edge_metanet(g)) +clean_multi_edge_metanet <- function(go) { + tmp_e <- get_e(go) + tmp_e$loop.angle <- 0 + # tmp_e$curved=0 + + summ_2col(tmp_e[, c("from", "to")], direct = FALSE) -> e_count + filter(e_count, count > 1) -> multi_e_count + for (i in seq_len(nrow(multi_e_count))) { + from <- multi_e_count$from[i] + to <- multi_e_count$to[i] + count <- multi_e_count$count[i] + if (from == to) { + tmp_e[tmp_e$from == from & tmp_e$to == to, "loop.angle"] <- seq(0, 2 * pi, length = count + 1)[-(count + 1)] + } + # else { + # tmp_e[tmp_e$from%in%c(from,to) & tmp_e$to%in%c(from,to),"curved"] <- 0.2 # seq(0,1,length=count) + # } + } + + # summ_2col(tmp_e[,c("from","to")],direct = TRUE) -> e_count + # filter(e_count,count>1) -> multi_e_count + # for (i in seq_len(nrow(multi_e_count))) { + # from=multi_e_count$from[i] + # to=multi_e_count$to[i] + # count=multi_e_count$count[i] + # if(from!=to){ + # tmp_e[tmp_e$from==from & tmp_e$to==to,"curved"] <- seq(0.2,1,length=count) + # } + # } + + igraph::edge.attributes(go) <- as.list(tmp_e) + go +} + +#' Link summary of the network +#' +#' @param go igraph or metanet +#' @param group summary which group of vertex attribution in names(vertex_attr(go)) +#' @param e_type "positive", "negative", "all" +#' @param topN topN of group, default: 10 +#' @param mode 1~2 +#' @param colors colors +#' @param plot_param plot parameters +#' +#' @return plot +#' @export +#' @family topological +#' @examples +#' if (requireNamespace("circlize")) { +#' links_stat(co_net, topN = 10) +#' module_detect(co_net) -> co_net_modu +#' links_stat(co_net_modu, group = "module") +#' } +#' if (requireNamespace("corrplot")) { +#' links_stat(co_net, topN = 10, mode = 2) +#' } +links_stat <- function(go, group = "v_class", e_type = "all", + topN = 10, colors = NULL, mode = 1, plot_param = list()) { + color <- v_class <- shape <- left_leg_x <- from <- to <- n <- NULL + direct <- is_directed(go) + go <- c_net_set(go, vertex_class = group) + + get_v(go) -> v_index + v_index %>% dplyr::select("name", "v_class") -> map + + suppressMessages(anno_edge(go, map) %>% get_e() -> edge) + # statistics + if (e_type != "all") edge %>% dplyr::filter(e_type == !!e_type) -> edge + summ_2col(edge[, paste0("v_class", c("_from", "_to"))], direct = direct) -> bb + colnames(bb) <- c("from", "to", "count") + + dplyr::group_by(bb, from) %>% + dplyr::summarise(n = sum(count)) %>% + dplyr::arrange(-n) %>% + dplyr::top_n(topN, n) %>% + dplyr::pull(from) -> nnn + + # plot + bb2 <- mutate(bb, + from = ifelse(from %in% nnn, from, "Others"), + to = ifelse(to %in% nnn, to, "Others") + ) %>% summ_2col(direct = direct) + + if (mode == 1) { + do.call(pcutils::my_circo, pcutils::update_param( + list( + df = bb2, + reorder = FALSE, + pal = colors + ), plot_param + )) + } + if (mode == 2) { + tab <- pcutils::df2distance(bb2) + tab2 <- tab + tab2[tab2 > 0] <- 1 + tab2[tab2 != 1] <- 0 + # tab2 <- trans(tab, "pa") %>% as.matrix() + do.call(corrplot::corrplot, pcutils::update_param( + list( + corr = tab2, + type = "lower", + method = "color", + col = c("white", "white", "red"), + addgrid.col = "black", + cl.pos = "n", + tl.col = "black" + ), + plot_param + )) + } +} + +# 每个分组可以构建一个网络,每个网络都可以用link_stat得到一些互作的数量(互作强度),可以再看这些数量和分组间某些指标的相关性。