# ========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
)
}