--- a +++ b/R/3-4.other_plot.R @@ -0,0 +1,481 @@ +# ========4.1.other_plot======== +# +#' Transfer an igraph object to a ggig +#' +#' @param go igraph or meatnet +#' @param coors coordinates for nodes,columns: name, X, Y +#' +#' @return ggig object +#' @export +#' @family plot +#' @examples +#' as.ggig(co_net, coors = c_net_layout(co_net)) -> ggig +#' plot(ggig) +#' as.ggig(multi1, coors = c_net_layout(multi1)) -> ggig +#' plot(ggig, labels_num = 0.3) +as.ggig <- function(go, coors = NULL) { + list(n_index = get_n(go), v_index = get_v(go), e_index = get_e(go)) -> net_par_res + + if (is.null(coors)) coors <- c_net_layout(go) + coors <- get_coors(coors, go) + + # add coors + coors <- coors[, 1:3] %>% na.omit() + net_par_res$v_index %<>% dplyr::left_join(., coors, by = "name", suffix = c("", ".1")) + net_par_res$e_index %<>% dplyr::left_join(., coors, by = c("from" = "name")) %>% + dplyr::rename(X1 = "X", Y1 = "Y") %>% + dplyr::left_join(., coors, by = c("to" = "name")) %>% + dplyr::rename(X2 = "X", Y2 = "Y") + + class(net_par_res) <- c("ggig", "list") + return(net_par_res) +} + +#' Plot a ggig +#' +#' @param x ggig object +#' @inheritParams c_net_plot +#' +#' @family plot +#' @return ggplot +#' @exportS3Method +#' @method plot ggig +plot.ggig <- function(x, coors = NULL, ..., labels_num = NULL, + vertex_size_range = NULL, edge_width_range = NULL, + plot_module = FALSE, + mark_module = FALSE, mark_color = NULL, mark_alpha = 0.3, + module_label = FALSE, module_label_cex = 2, module_label_color = "black", + module_label_just = c(0.5, 0.5), + legend_number = FALSE, legend = TRUE, legend_cex = 1, + legend_position = c(left_leg_x = -2, left_leg_y = 1, right_leg_x = 1.2, right_leg_y = 1), + group_legend_title = NULL, group_legend_order = NULL, + color_legend = TRUE, color_legend_order = NULL, + size_legend = FALSE, size_legend_title = "Node Size", + edge_legend = TRUE, edge_legend_title = "Edge type", edge_legend_order = NULL, + width_legend = FALSE, width_legend_title = "Edge width", + lty_legend = FALSE, lty_legend_title = "Edge class", lty_legend_order = NULL, + params_list = NULL, + seed = 1234) { + if (!is.null(params_list)) { + as.list(match.call()[-1]) -> set_params_list + set_params_list[["params_list"]] <- NULL + for (i in seq_along(params_list)) { + if (names(params_list)[i] %in% names(set_params_list)) { + message("The parameter `", names(params_list)[i], "` is duplicated, the format argument will be used.") + } + } + pcutils::update_param(params_list, set_params_list) -> set_params_list + do.call(c_net_plot, set_params_list) + return(invisible()) + } + + rename <- size <- color <- e_type <- lty <- e_class <- v_class <- shape <- X1 <- Y1 <- X2 <- Y2 <- width <- X <- Y <- label <- NULL + edge_width_text <- NULL + + ggig <- x + ggig$v_index -> tmp_v + ggig$e_index -> tmp_e + + set.seed(seed) + # get coordinates + if (!is.null(coors)) { + tmp_v$X <- tmp_v$Y <- NULL + tmp_e$X1 <- tmp_e$X2 <- tmp_e$Y1 <- tmp_e$Y2 <- NULL + # add coors + tmp_v %<>% dplyr::left_join(., coors, by = "name", suffix = c("", ".1")) + tmp_e %<>% dplyr::left_join(., coors, by = c("from" = "name")) %>% + rename(X1 = "X", Y1 = "Y") %>% + dplyr::left_join(., coors, by = c("to" = "name")) %>% + rename(X2 = "X", Y2 = "Y") + } + + # get network type + main <- get_net_main(ggig$n_index) + + # scale the size and width + scale_size_width(tmp_v, tmp_e, vertex_size_range, edge_width_range) + + # new shapes + tmp_v$shape <- tidai(tmp_v$v_group, 21:26) + + # some custom parameters + some_custom_paras(tmp_v, tmp_e, ...) + + # show labels + tmp_v <- get_show_labels(tmp_v, labels_num) + + if (TRUE) { + tmp_e$e_type <- pcutils::change_fac_lev(tmp_e$e_type, edge_legend_order) + edges <- levels(tmp_e$e_type) + edge_cols <- dplyr::distinct(tmp_e, color, e_type) + edge_cols <- setNames(edge_cols$color, edge_cols$e_type) + if (legend_number) { + eee <- table(tmp_e$e_type) + edge_text <- paste(edges, eee[edges], sep = ": ") + } else { + edge_text <- edges + } + } + + if (TRUE) { + edges1 <- levels(factor(tmp_e$e_class)) + edge_ltys <- dplyr::distinct(tmp_e, lty, e_class) + edge_ltys <- setNames(edge_ltys$lty, edge_ltys$e_class) + + if (legend_number) { + eee <- table(tmp_e$e_class) + lty_text <- paste(edges1, eee[edges1], sep = ": ") + } else { + lty_text <- edges1 + } + } + + if (TRUE) { + vgroups <- pcutils::change_fac_lev(tmp_v$v_group, group_legend_order) + + node_size_text <- c( + paste(lapply(node_size_text[levels(vgroups)], \(i)round(i[1], 3)), collapse = "/ "), + paste(lapply(node_size_text[levels(vgroups)], \(i)round(i[2], 3)), collapse = "/ ") + ) + + new_f <- c() + for (g_i in levels(vgroups)) { + tmp_v1 <- tmp_v[tmp_v$v_group == g_i, c("v_class", "color", "shape")] + tmp_f <- pcutils::change_fac_lev(tmp_v1$v_class, color_legend_order) + new_f <- c(new_f, levels(tmp_f)) + } + + tmp_v$v_class <- pcutils::change_fac_lev(tmp_v$v_class, new_f) + vclass <- levels(tmp_v$v_class) + + node_cols <- dplyr::distinct(tmp_v, color, v_class) + node_cols <- setNames(node_cols$color, node_cols$v_class) + node_shapes <- dplyr::distinct(tmp_v, shape, v_class) + node_shapes <- setNames(node_shapes$shape, node_shapes$v_class) + + if (legend_number) { + eee <- table(tmp_v$v_class) + le_text <- paste(vclass, eee[vclass], sep = ": ") + } else { + le_text <- vclass + } + } + + p <- ggplot() + + geom_segment(aes( + x = X1, y = Y1, xend = X2, yend = Y2, color = e_type, + linewidth = width, linetype = e_class + ), data = tmp_e, alpha = 0.7) + # draw edges + scale_color_manual( + name = edge_legend_title, values = edge_cols, + label = edge_text, guide = ifelse(edge_legend, "legend", "none") + ) + # edge colors + scale_linetype_manual( + name = lty_legend_title, values = edge_ltys, + label = lty_text, guide = ifelse(lty_legend, "legend", "none") + ) + # edge linetype + scale_linewidth( + name = width_legend_title, breaks = c(min(tmp_e$width), max(tmp_e$width)), range = c(0.5, 1), + labels = edge_width_text, guide = ifelse(width_legend, "legend", "none") + ) + + p1 <- p + + geom_point(aes(X, Y, fill = v_class, size = size, shape = v_class), data = tmp_v) + # draw nodes + # scale_shape_manual(values =setNames(default_v_shape[node_shapes],vclass))+#node shape + scale_shape_manual(values = node_shapes) + + scale_fill_manual( + name = group_legend_title, values = node_cols[vclass], + labels = le_text, guide = ifelse(color_legend, "legend", "none") + ) + # node color + scale_size( + name = size_legend_title, breaks = c(min(tmp_v$size), max(tmp_v$size)), + labels = node_size_text, guide = ifelse(size_legend, "legend", "none") + ) + # node size + + ggnewscale::new_scale("size") + + geom_text(aes(X, Y, size = size, label = label), col = "black", data = tmp_v, show.legend = FALSE) + + scale_size(range = c(1, 3), guide = "none") + + guides( + fill = guide_legend(override.aes = list(shape = node_shapes[vclass])), + shape = "none" + ) + + p2 <- p1 + labs(title = main) + + scale_x_continuous(breaks = NULL) + scale_y_continuous(breaks = NULL) + + coord_fixed(ratio = 1) + + theme(panel.background = element_blank()) + + theme(axis.title.x = element_blank(), axis.title.y = element_blank()) + + theme( + legend.background = element_rect(colour = NA), + legend.box.background = element_rect(colour = NA), + legend.key = element_rect(fill = NA) + ) + + theme(panel.background = element_rect(fill = "white", colour = NA)) + + theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank()) + + if (!legend) { + return(p2 + theme(legend.position = "none")) + } + + p2 +} + + +#' Input a graphml file exported by Gephi +#' +#' @param file graphml file exported by Gephi +#' @family plot +#' @return list contains the igraph object and coordinates +#' +#' @export +input_gephi <- function(file) { + X <- Y <- code <- NULL + igraph::read.graph(file, format = "graphml") -> gephi + get_v(gephi) -> tmp_v + # extract coors + if (!all(c("x", "y", "r", "g", "b", "id") %in% colnames(tmp_v))) { + stop("This file is not exported by Gephi, please use igraph::read.graph()") + } + coors <- tmp_v[, c("x", "y")] + coors <- data.frame(name = tmp_v$label, X = coors[, 1], Y = coors[, 2]) + class(coors) <- "coors" + coors <- rescale_coors(coors) + + # transform color + pcutils::rgb2code(tmp_v[, c("r", "g", "b")]) %>% dplyr::pull(code) -> tmp_v$color + if ("cor" %in% edge.attributes(gephi)) { + E(gephi)$color <- ifelse(E(gephi)$cor > 0, "#48A4F0", "#E85D5D") + } else { + E(gephi)$color <- "#48A4F0" + } + # scale size + tmp_v$size <- pcutils::mmscale(tmp_v$size, 1, 5) + E(gephi)$width <- pcutils::mmscale(E(gephi)$width, 0.05, 0.2) + # delete + tmp_v %>% + dplyr::select(-c("label", "x", "y", "r", "g", "b", "id")) %>% + as.list() -> vertex.attributes(gephi) + edge.attributes(gephi)["Edge Label"] <- edge.attributes(gephi)["id"] <- NULL + + gephi <- c_net_update(gephi, initialize = TRUE) + igraph::graph_attr(gephi, "coors") <- coors + return(list(go = gephi, coors = coors)) +} + + +#' Input a cyjs file exported by Cytoscape +#' +#' @param file cyjs file exported by Cytoscape +#' @family plot +#' @return list contains the igraph object and coordinates +#' +#' @export +input_cytoscape <- function(file) { + c_net_load(file, format = "cyjs") -> cyto + + get_v(cyto) -> tmp_v + coors <- tmp_v[, c("x", "y")] + coors <- data.frame(name = tmp_v$name, X = coors[, 1], Y = coors[, 2]) + + class(coors) <- "coors" + coors <- rescale_coors(coors) + + cyto <- c_net_update(cyto, initialize = TRUE) + igraph::graph_attr(cyto, "coors") <- coors + return(list(go = cyto, coors = coors)) +} + + +#' plot use networkD3 +#' +#' @param go metanet +#' @param v_class which attributes use to be v_class +#' @param ... see \code{\link[networkD3]{forceNetwork}} +#' @return D3 plot +#' @export +#' @family plot +#' @examples +#' data("c_net") +#' plot(co_net2) +#' if (requireNamespace("networkD3")) { +#' netD3plot(co_net2) +#' } +netD3plot <- function(go, v_class = "v_class", ...) { + flag <- "y" + if (length(V(go)) > 200) { + message("Too big network, recommend using Gephi to layout,still use networkD3?") + flag <- readline("yes/no(y/n):") + } + if (tolower(flag) %in% c("yes", "y")) { + lib_ps("networkD3", library = FALSE) + go <- c_net_set(go, vertex_class = v_class) + get_v(go) -> tmp_v + nodes <- tmp_v[, c("name", "v_class", "size", "color")] + colnames(nodes) <- c("name", "group", "size", "color") + nodes$size <- pcutils::mmscale(nodes$size, 2, 40) + + colors <- unique(nodes$color) + + get_e(go) -> tmp_e + links <- tmp_e[, c("from", "to", "width", "color")] + links$width <- pcutils::mmscale(links$width, 0.5, 1.5) + # give ids + links$IDsource <- match(links$from, nodes$name) - 1 + links$IDtarget <- match(links$to, nodes$name) - 1 + # Create force directed network plot + networkD3::forceNetwork( + Links = links, Nodes = nodes, + Source = "IDsource", Target = "IDtarget", linkColour = links$color, linkDistance = 20, + linkWidth = networkD3::JS("function(d) { return (d.width); }"), charge = -5, + NodeID = "name", Group = "group", Nodesize = "size", + colourScale = networkD3::JS(paste0("d3.scaleOrdinal([`", paste(colors, collapse = "`,`"), "`])")), legend = TRUE, ... + ) + } +} + +MetaNet_theme <- { + ggplot2::theme_classic(base_size = 13) + ggplot2::theme( + axis.text = element_text(color = "black"), + plot.margin = grid::unit(rep(0.5, 4), "lines"), + strip.background = ggplot2::element_rect(fill = NA) + ) +} + +#' Venn network +#' +#' @param tab data.frame (row is elements, column is group), or a list (names is group, value is elements) +#' +#' @return plot +#' @export +#' @family plot +#' @examples +#' data(otutab, package = "pcutils") +#' tab <- otutab[400:485, 1:3] +#' venn_net(tab) -> v_net +#' plot(v_net) +venn_net <- function(tab) { + # pcutils:::venn_cal(tab)->vennlist + tab[is.na(tab)] <- 0 + edgelist <- data.frame() + if (is.data.frame(tab)) { + groupss <- colnames(tab) + for (i in groupss) { + if (sum(tab[, i] > 0) > 0) edgelist <- rbind(edgelist, data.frame(Group = i, elements = rownames(tab)[tab[, i] > 0])) + } + } else if (all(class(tab) == "list")) { + vennlist <- tab + groupss <- names(vennlist) + for (i in groupss) { + if (length(vennlist[[i]] > 0)) edgelist <- rbind(edgelist, data.frame(Group = i, elements = vennlist[[i]])) + } + } else { + stop("wrong input tab") + } + + nodelist <- rbind( + data.frame(name = groupss, v_group = "Group", v_class = paste0("Group: ", groupss)), + data.frame(name = unique(edgelist$elements), v_group = "elements", v_class = "elements") + ) + venn_net <- c_net_from_edgelist(edgelist, vertex_df = nodelist) + graph.attributes(venn_net)$n_type <- "venn" + all_group <- get_e(venn_net)[, c("from", "to")] %>% + pcutils::squash("from") %>% + dplyr::rename(name = "to", all_group = "from") + venn_net <- c_net_set(venn_net, all_group, vertex_class = "all_group", edge_type = "from") + venn_net +} + + +#' Quick build a metanet from two columns table +#' +#' @param edgelist two columns table (no elements exist in two columns at same time) +#' +#' @return metanet +#' @export +#' @family plot +#' @examples +#' twocol <- data.frame( +#' "col1" = sample(letters, 30, replace = TRUE), +#' "col2" = sample(c("A", "B"), 30, replace = TRUE) +#' ) +#' twocol_net <- twocol_edgelist(twocol) +#' plot(twocol_net) +#' c_net_plot(twocol_net, g_layout_polygon(twocol_net)) +twocol_edgelist <- function(edgelist) { + if (any(edgelist[, 1] %in% edgelist[, 2])) stop("Must no elements exist in two columns at same time") + nodelist <- rbind( + data.frame(name = unique(edgelist[, 1]), v_group = names(edgelist)[1], v_class = names(edgelist)[1]), + data.frame(name = unique(edgelist[, 2]), v_group = names(edgelist)[2], v_class = names(edgelist)[2]) + ) + venn_net <- c_net_from_edgelist(edgelist, vertex_df = nodelist) + graph.attributes(venn_net)$n_type <- "twocol" + # venn_net=c_net_set(venn_net,edge_type = "from") + venn_net +} + + +#' Transform a dataframe to a network edgelist. +#' +#' @param test df +#' @param fun default: sum +#' +#' @return metanet +#' @export +#' +#' @examples +#' data("otutab", package = "pcutils") +#' cbind(taxonomy, num = rowSums(otutab))[1:20, ] -> test +#' df2net_tree(test) -> ttt +#' plot(ttt) +#' if (requireNamespace("ggraph")) plot(ttt, coors = as_circle_tree()) +df2net_tree <- function(test, fun = sum) { + flag <- FALSE + if (!is.numeric(test[, ncol(test)])) { + test$num <- 1 + } else { + flag <- TRUE + name <- colnames(test)[ncol(test)] + } + nc <- ncol(test) + if (nc < 3) stop("as least 3-columns dataframe") + + link <- pcutils::df2link(test, fun = fun) + + nodes <- link$nodes + links <- link$links + if (flag) { + colnames(links)[3] <- colnames(nodes)[3] <- name + } else { + name <- "weight" + } + + # c_net_from_edgelist(as.data.frame(links),vertex = nodes) + net <- igraph::graph_from_data_frame(as.data.frame(links), vertices = nodes) + net <- c_net_set(net, vertex_class = "level", vertex_size = name, edge_width = name) + net <- c_net_update(net, initialize = TRUE, verbose = FALSE) + graph_attr(net, "coors") <- c_net_layout(net, as_tree()) + net +} + +#' Plot olympic rings using network +#' +#' @return network plot +#' @export +#' @family plot +#' @examples +#' olympic_rings_net() +olympic_rings_net <- function() { + r <- 1 + pensize <- r / 6 + rings_data <- data.frame( + x = c(-2 * (r + pensize), -(r + pensize), 0, (r + pensize), 2 * (r + pensize)), + y = c(r, 0, r, 0, r), + color = c("#0081C8", "#FCB131", "#000000", "#00A651", "#EE334E") + ) + g1 <- module_net(module_number = 5, n_node_in_module = 30) + plot(g1, + coors = g_layout(g1, layout1 = rings_data[, 1:2], zoom1 = 1.2, zoom2 = 0.5), + rescale = FALSE, legend = FALSE, main = "Olympic Rings", vertex.frame.color = NA, + edge.width = 0, vertex.color = setNames(rings_data$color, 1:5), vertex.size = 7 + ) +}