代码之家 › 专栏 › 技术社区 › A. S. K.

使用CirclePack在ggraph中创建面时隐藏根节点

ggraph facet igraph r

A. S. K. · 技术社区 · 6 年前

我有一个小部件表;每个小部件都有一个唯一的ID、一个颜色和一个类别。我想做一个 circlepack 此表的图表 ggraph 类别上的方面,具有层次结构类别>颜色>小部件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

如果完全忽略根节点, 图形 发出警告,表示该图有多个组件,并且只绘制第一个类别。

如果我将根节点分配给第一个类别,那么第一个类别的图就会缩小(因为整个根节点也正在被绘制,而 scales="free" 根据需要显示所有其他类别)。

我也试着补充 filter = !is.na(category) 到 aes 属于 geom_node_circle 和 drop = T 到 facet_nodes 但这似乎没有任何效果。

最后,我可以保留根节点的方面,但使其完全空白(使类别名称为空字符串,将圆颜色更改为白色)。如果根节点方面总是最后一个,那么不太明显的是有一些无关的东西存在。但我希望找到更好的解决方案。

我愿意使用除 图形 但我有以下技术限制:

我需要用小部件的实际颜色填充每个小部件的圆。我相信这是不可能的 circlepackeR .
我需要在每个图表中有两个级别(颜色和小部件ID);我相信这可以排除 packcircles + ggiraph ,如所描述的 here .
这些图表是我使用的闪亮应用程序的一部分。 this solution 要添加工具提示(每个小部件的ID;这必须是工具提示而不是标签,因为在实际的数据集中,圆很小,ID很长)。我认为这与为每个类别绘制单独的图表和绘制它们是不相容的。 grid.arrange . 我从未使用过 d3 所以我不知道 this approach 可以修改以适应刻面和工具提示。

编辑: 另一个包括闪亮部分的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)

2 回复 | 直到 6 年前

Julius Vainora 6 年前

这里有一个解决方案,尽管可能不是最好的。让我们从

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]))
})

重新调整 x 和 y 分别在面板3和面板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))

A. S. K. 6 年前

这是另一种方法。使用 ggraph 创造 widget.ggraph 但不要画出来。相反,拉出来 widget.ggraph$data ,其中包含 x0 , y0 和 r 对于每个圆。过滤出根节点并重新缩放,以使每个面的圆在(0,0)处居中,并且在相同的比例上。把它反馈给 ggplot 并绘制圆圈 geom_circle .

这个解决方案是非最佳的,因为它涉及两次绘制数据,但至少它与闪亮的工具提示兼容。

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)