调整 ggplot2 中旋转的 x 轴标签的垂直空间和 Shiny 应用程序的绘图

Question

tl;博士版本： 对于多面情节，我需要一种方法来

1. 估计图表元素的相对大小（绘图区域、标签）
2. 操纵 relative 空间允许在 plotly 中的不同元素
3. 基于标准，例如最小绘图区域大小，定义绘图的绝对大小。

我目前正在构建一个 Shiny 应用程序，用于对各种数据集执行基本的探索性数据分析。我正在使用 ggplot2 和 plotly 来为不同的因素创建直方图。但是，当涉及到在 x 轴上显示长因子名称时，我遇到了一个问题。我尝试旋转标签以使它们更合适，但 plotly 似乎没有为它们分配足够的垂直空间，导致标签与绘图区域相交。这是一个屏幕截图，可以更好地说明我的问题：

所以我的问题是：

1. 如何调整标签的垂直间距？
2. 如何根据最长因子名称的长度动态执行此操作？

也许我问错了问题。完全手动弄乱绘图尺寸是个坏主意吗？我应该尝试其他方法吗？

另外，我注意到在某些情况下绘图区域变得非常小。 所以这是一个额外的问题：我怎样才能估计整个地块需要的大小，这样我就可以动态地缩放总高度，这样就不会被切断。

下面是一个最小的工作示例，其中包含来自

synthpop

包的虚拟数据：

library(shiny)
library(tidyverse)
library(plotly)
library(synthpop) # for example data

# generate example data frame
data <- synthpop::SD2011 |>
  select(where(is.factor)) |>
  slice(1:6)

ui <- fluidPage(
    sidebarLayout(
        sidebarPanel(),
        mainPanel(
           plotlyOutput("hist_plot")
        )
    )
)

server <- function(input, output) {
  hist_plot <- reactive({
    data |>
      pivot_longer(cols=everything(), names_to = "key", values_to = "value") |>
      ggplot(aes(x=value)) +
      geom_bar() +
      facet_wrap(~key, nrow = 2, scales = "free_x") +
      theme(
        axis.text.x = element_text(angle = 90))
  })

    output$hist_plot <- renderPlotly({
      req(hist_plot)
      ggplotly(hist_plot())
    })
}
shinyApp(ui = ui, server = server)

以下是我尝试/考虑过的一些事情：

• 不使用 plotly，而是坚持使用 ggplot2 并使用

  renderPlot()

  。然而，这会使绘图在应用程序中显得模糊，并且它有自己的缩放和重叠问题。
• 更改标签旋转并通过增加默认应用程序宽度来允许更多水平空间。但是，对于我的用例，我需要能够使用 Rstudio 中的运行应用程序按钮运行应用程序，这不允许更改默认大小，请参见here
• 手动调整地块的高度，例如与

  plotlyOutput("hist_plot", height = "1000px")

  。当我知道我需要的总大小时，这在一定程度上解决了问题，但它也增加了绘图区域和标签的大小。理想情况下，我们应该能够独立控制整体图表大小和绘图的大小。
• 我考虑了这个伟大指南中解释的所有内容这里，但没有一个适用于我的情况。

编辑：添加 tl:dr 部分

Answer 1

因为我不知道你的应用程序中还有什么，我怀疑这是一个“一次性”答案。在你完成它之后，如果它不适合你，请告诉我你的想法。我确定这 not 完美。有太多的静态尺寸无法发生。

一些需要注意的事情，与这个答案相关

• 当你把它从

  ggplot

  带到

  plotly

  时，它做了一些矫揉造作，但预料之中的事情
• facet标签是

  plotly.annotations

• facet标签框是

  plotly.shapes

• 个别地块设置在y轴域的相对端
  • 默认情况下，每个轴的定义域为 [0, 1]（您可以更改它，但为什么呢？？）
  • 在域底部的最后一行图，您的标签永远不会被轻易解决......

这就是我做的

在造型上

• 我向 x 轴标签添加了缩放文本大小（基于屏幕大小）
• 我没有为构面标签、y 轴标签或轴标题添加缩放文本大小调整
• 我将情节高度更改为动态（基于视屏高度）

在

fixer()

功能

• 捕获图在 y 轴域中位置的顶部
• 修改了所有控制或与底部地块位置相关的特征的位置
  • 形状

    yanchor

  • 注释

    y

    位置
  • “底部”行图的各个域位置

代码

大部分代码没有从您问题中的代码更改。在代码中查找我的注释以注意更改。如果您有任何疑问，我只是发表评论。

library(shiny)
library(tidyverse)
library(plotly)
library(synthpop) # for example data

# generate example data frame
data <- synthpop::SD2011 |>
  select(where(is.factor)) |>
  slice(1:6)

fixer <- function(pt) {                              # <--- I added
  rg <- pt$x$layout$yaxis2$domain[2]                           # graph size based on domain
  lapply(1:length(pt$x$layout$shapes), function(i) {           # modify shapes
    if(isTRUE(pt$x$layout$shapes[[i]]$yanchor == rg)) {        # isTRUE for errors
      pt$x$layout$shapes[[i]]$yanchor <<- 2.5 * rg             # move grey squares up
    }
  })
  lapply(1:length(pt$x$layout$annotations), function(j) {      # modify annotations
    if(isTRUE(round(pt$x$layout$annotations[[j]]$y, 6) == round(rg, 6))) { ## isTRUE for errors
      pt$x$layout$annotations[[j]]$y <<- 2.5 * rg              # move facet labels up
    }
  })
  pt$x$layout$yaxis2$domain <- c(1.5 * rg, 2.5 * rg)          # modify plot positions
  pt
}

ui <- fluidPage(
  tags$head(                                        # <--- I added
    tags$style(HTML(  # dynamic x-axis labels' size; dynamic plot height
      ".xaxislayer-above text{
        font-size: calc(6px + 6 * ((100vw - 300px) / (1600 - 300))) !important;
      }
      #hist_plot{
        height: 75vh !important;
      }"))
  ),
  sidebarLayout(
    sidebarPanel(),
    mainPanel(
      plotlyOutput("hist_plot")
    )
  )
)

server <- function(input, output) {
  hist_plot <- reactive({
    data |>
      pivot_longer(cols=everything(), names_to = "key", values_to = "value") |>
      ggplot(aes(x=value)) +
      geom_bar() +
      facet_wrap(~key, nrow = 2, scales = "free_x") +
      theme(
        axis.text.x = element_text(angle = 90))
  })
  
  output$hist_plot <- renderPlotly({
    req(hist_plot)
    ggplotly(hist_plot()) %>% 
      layout(margin = list(b = 100)) %>% fixer()        # <--- I added
  })
}
shinyApp(ui = ui, server = server)