ggplotly 中的第二个 x 轴具有不可见的第二个轨迹

Second x axis in ggplotly with invisible second trace

我正在尝试在 ggplotly 图上添加第二个 x 轴,不是为了容纳第二条轨迹,而是为了更好的可视化。

我发现我确实需要为它添加一个跟踪,但问题是如何。我发现添加简单、透明轨迹的示例不适用于我在 y 轴上有因子的绘图。

请认为出于我的目的,我需要使用 ggplotly 并且需要第二个轴。我将要提供的示例只是最小的,实际应用程序有 ggplotly 满足的其他要求(而不是直接 plotly 或 ggplot2)。想象一下,如果人们滚动浏览 100 种不同的鸢尾花,并且顶部的轴最初提供了一个很好的指南。使用 ggplot2,这是我想用 ggplotly 实现的示例:

library(tidyverse)
library(plotly)

dat <- iris %>% 
  group_by(Species) %>% 
  summarise(meanSL = mean(Sepal.Length, na.rm = TRUE),
            count = n()) 


labels_dup = c("low", "medium", "high")
labels = c("low", "medium\n\nmeans to the right\nof this line are\nso cool", "high")
breaks = c(5,6,7)
limits = c(4,8)

p <- ggplot(dat, aes(x = reorder(as.character(Species),meanSL), y = meanSL)) +
  geom_point() + 
  geom_hline(yintercept = 6, lty = 2) +
  coord_flip() +
  ggtitle("Means of sepal length by species") +
  
  theme_classic()+
  
  theme(axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.line.y = element_blank(),
        plot.title = element_text(size = 10, hjust = 0.5))

p + scale_y_continuous(breaks = breaks, labels = labels, limits = limits, sec.axis = dup_axis(labels = labels_dup)) +
  geom_text(aes(y = 4,label = paste0("n=",count)), size = 3)
  
  


这是输出:

这是 ggplotly 解决方案的开始:

ax <- list(
  side = "bottom",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels)


ax2 <- list(
  overlaying = "x",
  side = "top",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels_dup)

ggplotly(p) %>% 
  #<need a trace here e.g. add_lines, add_segment.  It could either be transparent, or use the vertical line or count text in the plot as shown in the example>  %>%
  layout(
    xaxis = ax,
    xaxis2 = ax2)

编辑:这里是当我使用建议的修复时产生警告的最少代码。出于与悬停文本相关的原因,我使用 geom_pointrange 而不是 stat_summary:

library(boot)
library(tidyverse)
library(plotly)

boot_sd <- function(x, fun=mean, R=1001) {
  fun <- match.fun(fun)
  bfoo <- function(data, idx) {
    fun(data[idx])
  }
  b <- boot(x, bfoo, R=R)
  sd(b$t)
}  

#Summarise the data for use with geom_pointrange and add some hover text for use with plotly:

dat <- iris %>% 
  mutate(flower_colour = c(rep(c("blue", "purple"), 25), rep(c("blue", "white"), 25), rep(c("white", "purple"), 25))) %>% 
  group_by(Species) %>% 
  summarise(meanSL = mean(Sepal.Length, na.rm = TRUE),
            countSL = n(),
            meSL = qt(0.975, countSL-1) * boot_sd(Sepal.Length, mean, 1001),
            lowerCI_SL = meanSL - meSL,
            upperCI_SL = meanSL + meSL,
            group = "Mean &\nConfidence Interval",
            colours_in_species = paste0(sort(unique(flower_colour)), collapse = ",")) %>% 
  as.data.frame() %>% 
  mutate(colours_in_species = paste0("colours: ", colours_in_species))
  
  
  
#Some plotting variables
purple <- "#8f11e7"
plot_title_colour <- "#35373b"
axis_text_colour <- "#3c4042"
legend_text_colour <- "#3c4042"
annotation_colour <- "#3c4042"

labels_dup = c("low", "medium", "high")
labels = c("low", "medium\n\nmeans to the right\nof this line are\nso cool", "high")
breaks = c(5,6,7)
limits = c(4,8)

p <- ggplot(dat, aes(x = reorder(as.character(Species),meanSL), text = colours_in_species)) +
  geom_text(aes(y = 4.2,label = paste0("n=",countSL)), color = annotation_colour, size = 3) +
 geom_pointrange(aes(y = meanSL, ymin=lowerCI_SL, ymax=upperCI_SL,color = group, fill = group), size = 1) +
  scale_fill_manual(values = "#f4a01f", name = "Mean &\nConfidence Interval") +
  scale_color_manual(values = "#f4a01f", name = "Mean &\nConfidence Interval") +
  
  geom_hline(yintercept = 5, colour = "dark grey", linetype = "dashed") +
  geom_hline(yintercept = 6, colour = purple, linetype = "dashed") +
  coord_flip() +
  
  ggtitle("Means of sepal length by species") +
  
  theme_classic()+
  
  theme(axis.text.y=element_text(size=10, colour = axis_text_colour),
        axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.line.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(size = 12, hjust = 0, colour = plot_title_colour), 
        legend.justification=c("right", "top"),
        legend.box.just = "center",
        legend.position ="top",
        legend.title.align = "left",
        legend.text=element_text(size = 8, hjust = 0.5, colour = legend_text_colour),
        legend.title=element_blank())



ax <- list(
  side = "top",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels_dup)

ay <- list(
  side = "right")


ax2 <- list(
  overlaying = "x",
  side = "bottom",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels_dup,
  tickfont = list(size = 11))




ggplotly(p, tooltip = 'text') %>% 
  add_markers(data = NULL, inherit = TRUE, xaxis = "x2") %>% 
  layout(
    xaxis = ax,
    xaxis2 = ax2,
    yaxis = ay,
    legend = list(orientation = "v", itemclick = FALSE, x = 1.2, y = 1.04),
    margin = list(t = 120, l = 60)
  )

    

警告是这样的: 警告信息: 'scatter' 对象没有这些属性:'label' 有效属性包括: 'type'、'visible'、'showlegend'、'legendgroup'、'opacity'、'name'、'uid'、'ids'、'customdata', 'meta', 'selectedpoints', 'hoverinfo', 'hoverlabel', 'stream', 'transforms', 'uirevision', 'x', 'x0', 'dx', 'y', 'y0', 'dy', 'stackgroup', 'orientation', 'groupnorm', 'stackgaps', 'text', 'texttemplate', 'hovertext', 'mode', 'hoveron', 'hovertemplate', 'line', 'connectgaps', 'cliponaxis', 'fill', 'fillcolor', 'marker', 'selected', 'unselected', 'textposition', 'textfont', 'r', 't', 'error_x', 'error_y', 'xcalendar', 'ycalendar', 'xaxis', 'yaxis', 'idssrc', 'customdatasrc', 'metasrc', 'hoverinfosrc', 'xsrc', 'ysrc', 'textsrc', 'texttemplatesrc', 'hovertextsrc', 'hovertemplatesrc', 'textpositionsrc', 'rsrc', 'tsrc', 'key', 'set', 'frame', 'transforms', '_isNestedKey', '_isSimpleKey', '_isGraticule', '_bbox'

我只需添加:

add_markers(data = NULL, inherit = TRUE, xaxis = "x2")

我也确实将你的第二个轴的 tickfont 大小设置为 11 以匹配你原始轴的字体大小。

虽然可以正常工作,但有时更改缩放比例(尤其是单击“自动缩放”时)会弄乱 x 轴的缩放比例,使它们不再同步。可能最好的选择是限制图标栏中的可用选项。

这是您编辑后的代码,已放入 运行 闪亮的应用程序中:

library(tidyverse)
library(plotly)
library(shiny)

dat <- iris %>% 
  group_by(Species) %>% 
  summarise(meanSL = mean(Sepal.Length, na.rm = TRUE),
            count = n()) 


labels_dup = c("low", "medium", "high")
labels = c("low", "medium\n\nmeans to the right\nof this line are\nso cool", "high")
breaks = c(5,6,7)
limits = c(4,8)

p <- ggplot(dat, aes(x = reorder(as.character(Species),meanSL), y = meanSL)) +
  geom_point() + 
  geom_hline(yintercept = 6, lty = 2) +
  coord_flip() +
  ggtitle("Means of sepal length by species") +
  
  theme_classic() +
  
  theme(axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.line.y = element_blank(),
        plot.title = element_text(size = 10, hjust = 0.5))

p + scale_y_continuous(breaks = breaks, labels = labels, limits = limits, sec.axis = dup_axis(labels = labels_dup)) +
  geom_text(aes(y = 4,label = paste0("n=",count)), size = 3)


ax <- list(
  side = "bottom",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels)


ax2 <- list(
  overlaying = "x",
  side = "top",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels_dup,
  tickfont = list(size = 11)) # I added this line


shinyApp(
  ui = fluidPage(
      plotlyOutput("plot")
  ),
  
  server = function(input, output) {
    
    output$plot <- renderPlotly({
      
      ggplotly(p) %>% 
        add_markers(data = NULL, inherit = TRUE, xaxis = "x2") %>% # new line
        layout(
          xaxis = ax,
          xaxis2 = ax2)
    })
  }
)

更新

下面是一个 运行 闪亮的应用程序,带有额外的示例代码。虽然它显示警告

Warning: 'scatter' objects don't have these attributes: 'label'

绘图在两个 x 轴上都正确显示。

我认为未正确显示的情节与上述警告无关。

library(boot)
library(tidyverse)
library(plotly)
library(shiny)

boot_sd <- function(x, fun=mean, R=1001) {
  fun <- match.fun(fun)
  bfoo <- function(data, idx) {
    fun(data[idx])
  }
  b <- boot(x, bfoo, R=R)
  sd(b$t)
}  

#Summarise the data for use with geom_pointrange and add some hover text for use with plotly:

dat <- iris %>% 
  mutate(flower_colour = c(rep(c("blue", "purple"), 25), rep(c("blue", "white"), 25), rep(c("white", "purple"), 25))) %>% 
  group_by(Species) %>% 
  summarise(meanSL = mean(Sepal.Length, na.rm = TRUE),
            countSL = n(),
            meSL = qt(0.975, countSL-1) * boot_sd(Sepal.Length, mean, 1001),
            lowerCI_SL = meanSL - meSL,
            upperCI_SL = meanSL + meSL,
            group = "Mean &\nConfidence Interval",
            colours_in_species = paste0(sort(unique(flower_colour)), collapse = ",")) %>% 
  as.data.frame() %>% 
  mutate(colours_in_species = paste0("colours: ", colours_in_species))



#Some plotting variables
purple <- "#8f11e7"
plot_title_colour <- "#35373b"
axis_text_colour <- "#3c4042"
legend_text_colour <- "#3c4042"
annotation_colour <- "#3c4042"

labels_dup = c("low", "medium", "high")
labels = c("low", "medium\n\nmeans to the right\nof this line are\nso cool", "high")
breaks = c(5,6,7)
limits = c(4,8)

p <- ggplot(dat, aes(x = reorder(as.character(Species),meanSL), text = colours_in_species)) +
  geom_text(aes(y = 4.2,label = paste0("n=",countSL)), color = annotation_colour, size = 3) +
  geom_pointrange(aes(y = meanSL, ymin=lowerCI_SL, ymax=upperCI_SL,color = group, fill = group), size = 1) +
  scale_fill_manual(values = "#f4a01f", name = "Mean &\nConfidence Interval") +
  scale_color_manual(values = "#f4a01f", name = "Mean &\nConfidence Interval") +
  
  geom_hline(yintercept = 5, colour = "dark grey", linetype = "dashed") +
  geom_hline(yintercept = 6, colour = purple, linetype = "dashed") +
  coord_flip() +
  
  ggtitle("Means of sepal length by species") +
  
  theme_classic()+
  
  theme(axis.text.y=element_text(size=10, colour = axis_text_colour),
        axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        axis.line.y = element_blank(),
        axis.ticks.y = element_blank(),
        plot.title = element_text(size = 12, hjust = 0, colour = plot_title_colour), 
        legend.justification=c("right", "top"),
        legend.box.just = "center",
        legend.position ="top",
        legend.title.align = "left",
        legend.text=element_text(size = 8, hjust = 0.5, colour = legend_text_colour),
        legend.title=element_blank())



ax <- list(
  side = "top",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels_dup)

ay <- list(
  side = "right")


ax2 <- list(
  overlaying = "x",
  side = "bottom",
  showticklabels = TRUE,
  range = limits,
  tickmode = "array", 
  tickvals = breaks,
  ticktext = labels_dup,
  tickfont = list(size = 11))



shinyApp(
  ui = fluidPage(
    plotlyOutput("plot")
  ),
  
  server = function(input, output) {
    
    output$plot <- renderPlotly({
      
      ggplotly(p, tooltip = 'text') %>% 
        add_markers(data = NULL, inherit = TRUE, xaxis = "x2") %>% 
        layout(
          xaxis = ax,
          xaxis2 = ax2,
          yaxis = ay,
          legend = list(orientation = "v", itemclick = FALSE, x = 1.2, y = 1.04),
          margin = list(t = 120, l = 60)
        )
      
    })
  }
)