使用 circlepack 在 ggraph 中分面时隐藏根节点
Hide root node when faceting in ggraph with circlepack
我有 table 个小部件；每个小部件都有唯一的 ID、颜色和类别。我想在 ggraph 中制作此 table 的 circlepack 图表，该图表在类别方面具有层次结构类别 > 颜色 > 小部件 ID：
问题出在根节点上。在此 MWE 中，根节点没有类别，因此它有自己的分面。
library(igraph)
library(ggraph)
# Toy dataset. Each widget has a unique ID, a fill color, a category, and a
# count. Most widgets are blue.
widgets.df = data.frame(
id = seq(1:200),
fill.hex = sample(c("#0055BF", "#237841", "#81007B"), 200, replace = T,
prob = c(0.6, 0.2, 0.2)),
category = c(rep("a", 100), rep("b", 100)),
num.widgets = ceiling(rexp(200, 0.3)),
stringsAsFactors = F
)
# Edges of the graph.
widget.edges = bind_rows(
# One edge from each color/category to each related widget.
widgets.df %>%
mutate(from = paste(fill.hex, category, sep = ""),
to = paste(id, fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from each category to each related color.
widgets.df %>%
mutate(from = category,
to = paste(fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from the root node to each category.
widgets.df %>%
mutate(from = "root",
to = category)
)
# Vertices of the graph.
widget.vertices = bind_rows(
# One vertex for each widget.
widgets.df %>%
mutate(name = paste(id, fill.hex, category, sep = ""),
fill.to.plot = fill.hex,
color.to.plot = "#000000") %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each color/category.
widgets.df %>%
mutate(name = paste(fill.hex, category, sep = ""),
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each category.
widgets.df %>%
mutate(name = category,
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One root vertex.
data.frame(name = "root",
category = "",
fill.to.plot = "#FFFFFF",
color.to.plot = "#BBBBBB",
num.widgets = 1,
stringsAsFactors = F)
)
# Make the graph.
widget.igraph = graph_from_data_frame(widget.edges, vertices = widget.vertices)
widget.ggraph = ggraph(widget.igraph,
layout = "circlepack", weight = "num.widgets") +
geom_node_circle(aes(fill = fill.to.plot, color = color.to.plot)) +
scale_fill_manual(values = sort(unique(widget.vertices$fill.to.plot))) +
scale_color_manual(values = sort(unique(widget.vertices$color.to.plot))) +
theme_void() +
guides(fill = F, color = F, size = F) +
theme(aspect.ratio = 1) +
facet_nodes(~ category, scales = "free")
widget.ggraph
如果我完全省略根节点，ggraph 会发出警告，指出该图有多个组件并且只绘制第一个类别。
如果我将根节点分配给第一个类别，第一个类别的图就会缩小（因为整个根节点也被绘制出来，而 scales="free" 会根据需要显示所有其他类别） .
我也试过在geom_node_circle的aes中添加filter = !is.na(category)，在facet_nodes中添加drop = T，但这似乎没有任何效果.
作为最后的手段，我可以保留根节点的分面但将其完全空白（将类别名称设为空字符串，将圆圈颜色更改为白色）。如果根节点面总是在最后，那么那里的无关紧要的东西就不那么明显了。但我很想找到更好的解决方案。
我愿意使用 ggraph 以外的东西，但我有以下技术限制：
我需要用小部件的实际颜色填充每个小部件的圆圈。我相信这排除了 circlepackeR.
我需要在每个图表中设置两个级别（颜色和小部件 ID）；我相信这排除了 packcircles + ggiraph，如 here.
图表是我正在使用的 Shiny 应用程序的一部分 this solution to add tooltips (the ID for each widget; this has to be a tooltip rather than a label because in the real dataset, the circles are small and the IDs are very long). I believe this is incompatible with making separate graphs for each category and plotting them with grid.arrange. I've never used d3, so I don't know whether 可以修改以适应分面和工具提示。
编辑： 另一个包含 Shiny 部分的 MWE：
library(dplyr)
library(shiny)
library(igraph)
library(ggraph)
# Toy dataset. Each widget has a unique ID, a fill color, a category, and a
# count. Most widgets are blue.
widgets.df = data.frame(
id = seq(1:200),
fill.hex = sample(c("#0055BF", "#237841", "#81007B"), 200, replace = T,
prob = c(0.6, 0.2, 0.2)),
category = c(rep("a", 100), rep("b", 100)),
num.widgets = ceiling(rexp(200, 0.3)),
stringsAsFactors = F
)
# Edges of the graph.
widget.edges = bind_rows(
# One edge from each color/category to each related widget.
widgets.df %>%
mutate(from = paste(fill.hex, category, sep = ""),
to = paste(id, fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from each category to each related color.
widgets.df %>%
mutate(from = category,
to = paste(fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from the root node to each category.
widgets.df %>%
mutate(from = "root",
to = category)
)
# Vertices of the graph.
widget.vertices = bind_rows(
# One vertex for each widget.
widgets.df %>%
mutate(name = paste(id, fill.hex, category, sep = ""),
fill.to.plot = fill.hex,
color.to.plot = "#000000") %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each color/category.
widgets.df %>%
mutate(name = paste(fill.hex, category, sep = ""),
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each category.
widgets.df %>%
mutate(name = category,
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One root vertex.
data.frame(name = "root",
fill.to.plot = "#FFFFFF",
color.to.plot = "#BBBBBB",
num.widgets = 1,
stringsAsFactors = F)
)
# UI logic.
ui <- fluidPage(
# Application title
titlePanel("Widget Data"),
# Make sure the cursor has the default shape, even when using tooltips
tags$head(tags$style(HTML("#widgetPlot { cursor: default; }"))),
# Main panel for plot.
mainPanel(
# Circle-packing plot.
div(
style = "position:relative",
plotOutput(
"widgetPlot",
width = "700px",
height = "400px",
hover = hoverOpts("widget_plot_hover", delay = 20, delayType = "debounce")
),
uiOutput("widgetHover")
)
)
)
# Server logic.
server <- function(input, output) {
# Create the graph.
widget.ggraph = reactive({
widget.igraph = graph_from_data_frame(widget.edges, vertices = widget.vertices)
widget.ggraph = ggraph(widget.igraph,
layout = "circlepack", weight = "num.widgets") +
geom_node_circle(aes(fill = fill.to.plot, color = color.to.plot)) +
scale_fill_manual(values = sort(unique(widget.vertices$fill.to.plot))) +
scale_color_manual(values = sort(unique(widget.vertices$color.to.plot))) +
theme_void() +
guides(fill = F, color = F, size = F) +
theme(aspect.ratio = 1) +
facet_nodes(~ category, scales = "free")
widget.ggraph
})
# Render the graph.
output$widgetPlot = renderPlot({
widget.ggraph()
})
# Tooltip for the widget graph.
# https://gitlab.com/snippets/16220
output$widgetHover = renderUI({
# Get the hover options.
hover = input$widget_plot_hover
# Find the data point that corresponds to the circle the mouse is hovering
# over.
if(!is.null(hover)) {
point = widget.ggraph()$data %>%
filter(leaf) %>%
filter(r >= (((x - hover$x) ^ 2) + ((y - hover$y) ^ 2)) ^ .5)
} else {
return(NULL)
}
if(nrow(point) != 1) {
return(NULL)
}
# Calculate how far from the left and top the center of the circle is, as a
# percent of the total graph size.
left_pct = (point$x - hover$domain$left) / (hover$domain$right - hover$domain$left)
top_pct <- (hover$domain$top - point$y) / (hover$domain$top - hover$domain$bottom)
# Convert the percents into pixels.
left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)
# Set the style of the tooltip.
style = paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
"left:", left_px, "px; top:", top_px, "px;")
# Create the actual tooltip as a wellPanel.
wellPanel(
style = style,
p(HTML(paste("Widget id and color:", point$name)))
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
这是一种解决方案，但可能不是最好的解决方案。让我们从
开始
gb <- ggplot_build(widget.ggraph)
gb$layout$layout <- gb$layout$layout[-1, ]
gb$layout$layout$COL <- gb$layout$layout$COL - 1
我们以这种方式删除了第一个方面。但是，我们还需要修复gb里面的数据。特别是，我们使用
library(scales)
gb$data[[1]] <- within(gb$data[[1]], {
x[PANEL == 3] <- rescale(x[PANEL == 3], to = range(x[PANEL == 2]))
x[PANEL == 2] <- rescale(x[PANEL == 2], to = range(x[PANEL == 1]))
y[PANEL == 3] <- rescale(y[PANEL == 3], to = range(y[PANEL == 2]))
y[PANEL == 2] <- rescale(y[PANEL == 2], to = range(y[PANEL == 1]))
})
将面板 3 和面板 2 中的 x 和 y 分别重新调整为面板 2 和面板 1 中的面板。最后，
gb$data[[1]] <- gb$data[[1]][gb$data[[1]]$PANEL %in% 2:3, ]
gb$data[[1]]$PANEL <- factor(as.numeric(as.character(gb$data[[1]]$PANEL)) - 1)
删除第一个面板并相应地更改面板名称。这给出
library(grid)
grid.draw(ggplot_gtable(gb))
这是另一种方法。使用 ggraph 创建 widget.ggraph，但不要绘制它。相反，拉出 widget.ggraph$data，其中每个圆圈包含 x0、y0 和 r。过滤掉根节点并重新缩放，以便每个面的圆圈以 (0, 0) 为中心并处于相同的比例。将其反馈给 ggplot 并用 geom_circle.
绘制圆圈
此解决方案不是最佳解决方案，因为它涉及两次绘制数据图形，但至少它与 Shiny 工具提示兼容。
library(dplyr)
library(shiny)
library(ggplot2)
library(igraph)
library(ggraph)
# Toy dataset. Each widget has a unique ID, a fill color, a category, and a
# count. Most widgets are blue.
widgets.df = data.frame(
id = seq(1:200),
fill.hex = sample(c("#0055BF", "#237841", "#81007B"), 200, replace = T,
prob = c(0.6, 0.2, 0.2)),
category = c(rep("a", 100), rep("b", 100)),
num.widgets = ceiling(rexp(200, 0.3)),
stringsAsFactors = F
)
# Edges of the graph.
widget.edges = bind_rows(
# One edge from each color/category to each related widget.
widgets.df %>%
mutate(from = paste(fill.hex, category, sep = ""),
to = paste(id, fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from each category to each related color.
widgets.df %>%
mutate(from = category,
to = paste(fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from the root node to each category.
widgets.df %>%
mutate(from = "root",
to = category)
)
# Vertices of the graph.
widget.vertices = bind_rows(
# One vertex for each widget.
widgets.df %>%
mutate(name = paste(id, fill.hex, category, sep = ""),
fill.to.plot = fill.hex,
color.to.plot = "#000000") %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each color/category.
widgets.df %>%
mutate(name = paste(fill.hex, category, sep = ""),
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each category.
widgets.df %>%
mutate(name = category,
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One root vertex.
data.frame(name = "root",
fill.to.plot = "#FFFFFF",
color.to.plot = "#BBBBBB",
num.widgets = 1,
stringsAsFactors = F)
)
# UI logic.
ui <- fluidPage(
# Application title
titlePanel("Widget Data"),
# Make sure the cursor has the default shape, even when using tooltips
tags$head(tags$style(HTML("#widgetPlot { cursor: default; }"))),
# Main panel for plot.
mainPanel(
# Circle-packing plot.
div(
style = "position:relative",
plotOutput(
"widgetPlot",
width = "700px",
height = "400px",
hover = hoverOpts("widget_plot_hover", delay = 20, delayType = "debounce")
),
uiOutput("widgetHover")
)
)
)
# Server logic.
server <- function(input, output) {
# Create the graph.
widget.graph = reactive({
# Use ggraph to create the circlepack plot.
widget.igraph = graph_from_data_frame(widget.edges, vertices = widget.vertices)
widget.ggraph = ggraph(widget.igraph,
layout = "circlepack", weight = "num.widgets") +
geom_node_circle()
# Pull out x, y, and r for each category.
facet.centers = widget.ggraph$data %>%
filter(as.character(name) == as.character(category)) %>%
mutate(x.center = x, y.center = y, r.center = r) %>%
dplyr::select(x.center, y.center, r.center, category)
# Rescale x, y, and r for each non-root so that each category (facet) is
# centered at (0, 0) and on the same scale.
faceted.data = widget.ggraph$data %>%
filter(!is.na(category)) %>%
group_by(category) %>%
left_join(facet.centers, by = c("category")) %>%
mutate(x.faceted = (x - x.center) / r.center,
y.faceted = (y - y.center) / r.center,
r.faceted = r / r.center)
# Feed the rescaled dataset into geom_circle.
widget.facet.graph = ggplot(faceted.data,
aes(x0 = x.faceted,
y0 = y.faceted,
r = r.faceted,
fill = fill.to.plot,
color = color.to.plot)) +
geom_circle() +
scale_fill_manual(values = sort(unique(as.character(faceted.data$fill.to.plot)))) +
scale_color_manual(values = sort(unique(as.character(faceted.data$color.to.plot)))) +
facet_grid(~ category) +
coord_equal() +
guides(fill = F, color = F, size = F) +
theme_void()
widget.facet.graph
})
# Render the graph.
output$widgetPlot = renderPlot({
widget.graph()
})
# Tooltip for the widget graph.
# https://gitlab.com/snippets/16220
output$widgetHover = renderUI({
# Get the hover options.
hover = input$widget_plot_hover
# Find the data point that corresponds to the circle the mouse is hovering
# over.
if(!is.null(hover)) {
point = widget.graph()$data %>%
filter(leaf) %>%
filter(r.faceted >= (((x.faceted - hover$x) ^ 2) + ((y.faceted - hover$y) ^ 2)) ^ .5 &
as.character(category) == hover$panelvar1)
} else {
return(NULL)
}
if(nrow(point) != 1) {
return(NULL)
}
# Calculate how far from the left and top the center of the circle is, as a
# percent of the total graph size.
left_pct = (point$x.faceted - hover$domain$left) / (hover$domain$right - hover$domain$left)
top_pct <- (hover$domain$top - point$y.faceted) / (hover$domain$top - hover$domain$bottom)
# Convert the percents into pixels.
left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)
# Set the style of the tooltip.
style = paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
"left:", left_px, "px; top:", top_px, "px;")
# Create the actual tooltip as a wellPanel.
wellPanel(
style = style,
p(HTML(paste("Widget id and color:", point$name)))
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
我有 table 个小部件；每个小部件都有唯一的 ID、颜色和类别。我想在 ggraph 中制作此 table 的 circlepack 图表，该图表在类别方面具有层次结构类别 > 颜色 > 小部件 ID：
问题出在根节点上。在此 MWE 中，根节点没有类别，因此它有自己的分面。
library(igraph)
library(ggraph)
# Toy dataset. Each widget has a unique ID, a fill color, a category, and a
# count. Most widgets are blue.
widgets.df = data.frame(
id = seq(1:200),
fill.hex = sample(c("#0055BF", "#237841", "#81007B"), 200, replace = T,
prob = c(0.6, 0.2, 0.2)),
category = c(rep("a", 100), rep("b", 100)),
num.widgets = ceiling(rexp(200, 0.3)),
stringsAsFactors = F
)
# Edges of the graph.
widget.edges = bind_rows(
# One edge from each color/category to each related widget.
widgets.df %>%
mutate(from = paste(fill.hex, category, sep = ""),
to = paste(id, fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from each category to each related color.
widgets.df %>%
mutate(from = category,
to = paste(fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from the root node to each category.
widgets.df %>%
mutate(from = "root",
to = category)
)
# Vertices of the graph.
widget.vertices = bind_rows(
# One vertex for each widget.
widgets.df %>%
mutate(name = paste(id, fill.hex, category, sep = ""),
fill.to.plot = fill.hex,
color.to.plot = "#000000") %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each color/category.
widgets.df %>%
mutate(name = paste(fill.hex, category, sep = ""),
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each category.
widgets.df %>%
mutate(name = category,
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One root vertex.
data.frame(name = "root",
category = "",
fill.to.plot = "#FFFFFF",
color.to.plot = "#BBBBBB",
num.widgets = 1,
stringsAsFactors = F)
)
# Make the graph.
widget.igraph = graph_from_data_frame(widget.edges, vertices = widget.vertices)
widget.ggraph = ggraph(widget.igraph,
layout = "circlepack", weight = "num.widgets") +
geom_node_circle(aes(fill = fill.to.plot, color = color.to.plot)) +
scale_fill_manual(values = sort(unique(widget.vertices$fill.to.plot))) +
scale_color_manual(values = sort(unique(widget.vertices$color.to.plot))) +
theme_void() +
guides(fill = F, color = F, size = F) +
theme(aspect.ratio = 1) +
facet_nodes(~ category, scales = "free")
widget.ggraph
如果我完全省略根节点，ggraph 会发出警告，指出该图有多个组件并且只绘制第一个类别。
如果我将根节点分配给第一个类别，第一个类别的图就会缩小（因为整个根节点也被绘制出来，而 scales="free" 会根据需要显示所有其他类别） .
我也试过在geom_node_circle的aes中添加filter = !is.na(category)，在facet_nodes中添加drop = T，但这似乎没有任何效果.
作为最后的手段，我可以保留根节点的分面但将其完全空白（将类别名称设为空字符串，将圆圈颜色更改为白色）。如果根节点面总是在最后，那么那里的无关紧要的东西就不那么明显了。但我很想找到更好的解决方案。
我愿意使用 ggraph 以外的东西，但我有以下技术限制：
我需要用小部件的实际颜色填充每个小部件的圆圈。我相信这排除了
circlepackeR.我需要在每个图表中设置两个级别（颜色和小部件 ID）；我相信这排除了
packcircles+ggiraph，如 here. 所述
图表是我正在使用的 Shiny 应用程序的一部分 this solution to add tooltips (the ID for each widget; this has to be a tooltip rather than a label because in the real dataset, the circles are small and the IDs are very long). I believe this is incompatible with making separate graphs for each category and plotting them with
grid.arrange. I've never usedd3, so I don't know whether
编辑： 另一个包含 Shiny 部分的 MWE：
library(dplyr)
library(shiny)
library(igraph)
library(ggraph)
# Toy dataset. Each widget has a unique ID, a fill color, a category, and a
# count. Most widgets are blue.
widgets.df = data.frame(
id = seq(1:200),
fill.hex = sample(c("#0055BF", "#237841", "#81007B"), 200, replace = T,
prob = c(0.6, 0.2, 0.2)),
category = c(rep("a", 100), rep("b", 100)),
num.widgets = ceiling(rexp(200, 0.3)),
stringsAsFactors = F
)
# Edges of the graph.
widget.edges = bind_rows(
# One edge from each color/category to each related widget.
widgets.df %>%
mutate(from = paste(fill.hex, category, sep = ""),
to = paste(id, fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from each category to each related color.
widgets.df %>%
mutate(from = category,
to = paste(fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from the root node to each category.
widgets.df %>%
mutate(from = "root",
to = category)
)
# Vertices of the graph.
widget.vertices = bind_rows(
# One vertex for each widget.
widgets.df %>%
mutate(name = paste(id, fill.hex, category, sep = ""),
fill.to.plot = fill.hex,
color.to.plot = "#000000") %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each color/category.
widgets.df %>%
mutate(name = paste(fill.hex, category, sep = ""),
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each category.
widgets.df %>%
mutate(name = category,
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One root vertex.
data.frame(name = "root",
fill.to.plot = "#FFFFFF",
color.to.plot = "#BBBBBB",
num.widgets = 1,
stringsAsFactors = F)
)
# UI logic.
ui <- fluidPage(
# Application title
titlePanel("Widget Data"),
# Make sure the cursor has the default shape, even when using tooltips
tags$head(tags$style(HTML("#widgetPlot { cursor: default; }"))),
# Main panel for plot.
mainPanel(
# Circle-packing plot.
div(
style = "position:relative",
plotOutput(
"widgetPlot",
width = "700px",
height = "400px",
hover = hoverOpts("widget_plot_hover", delay = 20, delayType = "debounce")
),
uiOutput("widgetHover")
)
)
)
# Server logic.
server <- function(input, output) {
# Create the graph.
widget.ggraph = reactive({
widget.igraph = graph_from_data_frame(widget.edges, vertices = widget.vertices)
widget.ggraph = ggraph(widget.igraph,
layout = "circlepack", weight = "num.widgets") +
geom_node_circle(aes(fill = fill.to.plot, color = color.to.plot)) +
scale_fill_manual(values = sort(unique(widget.vertices$fill.to.plot))) +
scale_color_manual(values = sort(unique(widget.vertices$color.to.plot))) +
theme_void() +
guides(fill = F, color = F, size = F) +
theme(aspect.ratio = 1) +
facet_nodes(~ category, scales = "free")
widget.ggraph
})
# Render the graph.
output$widgetPlot = renderPlot({
widget.ggraph()
})
# Tooltip for the widget graph.
# https://gitlab.com/snippets/16220
output$widgetHover = renderUI({
# Get the hover options.
hover = input$widget_plot_hover
# Find the data point that corresponds to the circle the mouse is hovering
# over.
if(!is.null(hover)) {
point = widget.ggraph()$data %>%
filter(leaf) %>%
filter(r >= (((x - hover$x) ^ 2) + ((y - hover$y) ^ 2)) ^ .5)
} else {
return(NULL)
}
if(nrow(point) != 1) {
return(NULL)
}
# Calculate how far from the left and top the center of the circle is, as a
# percent of the total graph size.
left_pct = (point$x - hover$domain$left) / (hover$domain$right - hover$domain$left)
top_pct <- (hover$domain$top - point$y) / (hover$domain$top - hover$domain$bottom)
# Convert the percents into pixels.
left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)
# Set the style of the tooltip.
style = paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
"left:", left_px, "px; top:", top_px, "px;")
# Create the actual tooltip as a wellPanel.
wellPanel(
style = style,
p(HTML(paste("Widget id and color:", point$name)))
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
这是一种解决方案，但可能不是最好的解决方案。让我们从
开始gb <- ggplot_build(widget.ggraph)
gb$layout$layout <- gb$layout$layout[-1, ]
gb$layout$layout$COL <- gb$layout$layout$COL - 1
我们以这种方式删除了第一个方面。但是，我们还需要修复gb里面的数据。特别是，我们使用
library(scales)
gb$data[[1]] <- within(gb$data[[1]], {
x[PANEL == 3] <- rescale(x[PANEL == 3], to = range(x[PANEL == 2]))
x[PANEL == 2] <- rescale(x[PANEL == 2], to = range(x[PANEL == 1]))
y[PANEL == 3] <- rescale(y[PANEL == 3], to = range(y[PANEL == 2]))
y[PANEL == 2] <- rescale(y[PANEL == 2], to = range(y[PANEL == 1]))
})
将面板 3 和面板 2 中的 x 和 y 分别重新调整为面板 2 和面板 1 中的面板。最后，
gb$data[[1]] <- gb$data[[1]][gb$data[[1]]$PANEL %in% 2:3, ]
gb$data[[1]]$PANEL <- factor(as.numeric(as.character(gb$data[[1]]$PANEL)) - 1)
删除第一个面板并相应地更改面板名称。这给出
library(grid)
grid.draw(ggplot_gtable(gb))
这是另一种方法。使用 ggraph 创建 widget.ggraph，但不要绘制它。相反，拉出 widget.ggraph$data，其中每个圆圈包含 x0、y0 和 r。过滤掉根节点并重新缩放，以便每个面的圆圈以 (0, 0) 为中心并处于相同的比例。将其反馈给 ggplot 并用 geom_circle.
此解决方案不是最佳解决方案，因为它涉及两次绘制数据图形，但至少它与 Shiny 工具提示兼容。
library(dplyr)
library(shiny)
library(ggplot2)
library(igraph)
library(ggraph)
# Toy dataset. Each widget has a unique ID, a fill color, a category, and a
# count. Most widgets are blue.
widgets.df = data.frame(
id = seq(1:200),
fill.hex = sample(c("#0055BF", "#237841", "#81007B"), 200, replace = T,
prob = c(0.6, 0.2, 0.2)),
category = c(rep("a", 100), rep("b", 100)),
num.widgets = ceiling(rexp(200, 0.3)),
stringsAsFactors = F
)
# Edges of the graph.
widget.edges = bind_rows(
# One edge from each color/category to each related widget.
widgets.df %>%
mutate(from = paste(fill.hex, category, sep = ""),
to = paste(id, fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from each category to each related color.
widgets.df %>%
mutate(from = category,
to = paste(fill.hex, category, sep = "")) %>%
select(from, to) %>%
distinct(),
# One edge from the root node to each category.
widgets.df %>%
mutate(from = "root",
to = category)
)
# Vertices of the graph.
widget.vertices = bind_rows(
# One vertex for each widget.
widgets.df %>%
mutate(name = paste(id, fill.hex, category, sep = ""),
fill.to.plot = fill.hex,
color.to.plot = "#000000") %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each color/category.
widgets.df %>%
mutate(name = paste(fill.hex, category, sep = ""),
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One vertex for each category.
widgets.df %>%
mutate(name = category,
fill.to.plot = "#FFFFFF",
color.to.plot = "#000000",
num.widgets = 1) %>%
select(name, category, fill.to.plot, color.to.plot, num.widgets) %>%
distinct(),
# One root vertex.
data.frame(name = "root",
fill.to.plot = "#FFFFFF",
color.to.plot = "#BBBBBB",
num.widgets = 1,
stringsAsFactors = F)
)
# UI logic.
ui <- fluidPage(
# Application title
titlePanel("Widget Data"),
# Make sure the cursor has the default shape, even when using tooltips
tags$head(tags$style(HTML("#widgetPlot { cursor: default; }"))),
# Main panel for plot.
mainPanel(
# Circle-packing plot.
div(
style = "position:relative",
plotOutput(
"widgetPlot",
width = "700px",
height = "400px",
hover = hoverOpts("widget_plot_hover", delay = 20, delayType = "debounce")
),
uiOutput("widgetHover")
)
)
)
# Server logic.
server <- function(input, output) {
# Create the graph.
widget.graph = reactive({
# Use ggraph to create the circlepack plot.
widget.igraph = graph_from_data_frame(widget.edges, vertices = widget.vertices)
widget.ggraph = ggraph(widget.igraph,
layout = "circlepack", weight = "num.widgets") +
geom_node_circle()
# Pull out x, y, and r for each category.
facet.centers = widget.ggraph$data %>%
filter(as.character(name) == as.character(category)) %>%
mutate(x.center = x, y.center = y, r.center = r) %>%
dplyr::select(x.center, y.center, r.center, category)
# Rescale x, y, and r for each non-root so that each category (facet) is
# centered at (0, 0) and on the same scale.
faceted.data = widget.ggraph$data %>%
filter(!is.na(category)) %>%
group_by(category) %>%
left_join(facet.centers, by = c("category")) %>%
mutate(x.faceted = (x - x.center) / r.center,
y.faceted = (y - y.center) / r.center,
r.faceted = r / r.center)
# Feed the rescaled dataset into geom_circle.
widget.facet.graph = ggplot(faceted.data,
aes(x0 = x.faceted,
y0 = y.faceted,
r = r.faceted,
fill = fill.to.plot,
color = color.to.plot)) +
geom_circle() +
scale_fill_manual(values = sort(unique(as.character(faceted.data$fill.to.plot)))) +
scale_color_manual(values = sort(unique(as.character(faceted.data$color.to.plot)))) +
facet_grid(~ category) +
coord_equal() +
guides(fill = F, color = F, size = F) +
theme_void()
widget.facet.graph
})
# Render the graph.
output$widgetPlot = renderPlot({
widget.graph()
})
# Tooltip for the widget graph.
# https://gitlab.com/snippets/16220
output$widgetHover = renderUI({
# Get the hover options.
hover = input$widget_plot_hover
# Find the data point that corresponds to the circle the mouse is hovering
# over.
if(!is.null(hover)) {
point = widget.graph()$data %>%
filter(leaf) %>%
filter(r.faceted >= (((x.faceted - hover$x) ^ 2) + ((y.faceted - hover$y) ^ 2)) ^ .5 &
as.character(category) == hover$panelvar1)
} else {
return(NULL)
}
if(nrow(point) != 1) {
return(NULL)
}
# Calculate how far from the left and top the center of the circle is, as a
# percent of the total graph size.
left_pct = (point$x.faceted - hover$domain$left) / (hover$domain$right - hover$domain$left)
top_pct <- (hover$domain$top - point$y.faceted) / (hover$domain$top - hover$domain$bottom)
# Convert the percents into pixels.
left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)
# Set the style of the tooltip.
style = paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
"left:", left_px, "px; top:", top_px, "px;")
# Create the actual tooltip as a wellPanel.
wellPanel(
style = style,
p(HTML(paste("Widget id and color:", point$name)))
)
})
}
# Run the application
shinyApp(ui = ui, server = server)