时间戳

首页 > 解决方案 > ggplotly 中的第二个 x 轴，第二个轨迹不可见

r - ggplotly 中的第二个 x 轴，第二个轨迹不可见

问题描述

我正在尝试在 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', '标记'，'选中'，'未选中'，'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'ycalendar'、'xaxis'、'yaxis'、'idssrc'、'customdatasrc'、'metasrc'、'hoverinfosrc'、'xsrc'、'ysrc'、'textsrc'、'texttemplatesrc'、'hovertextsrc'、'hovertemplatesrc' 、'textpositionsrc'、'rsrc'、'tsrc'、'key'、'set'、'frame'、'transforms'、'_isNestedKey'、'_isSimpleKey'、'_isGraticule'、'_bbox'ycalendar'、'xaxis'、'yaxis'、'idssrc'、'customdatasrc'、'metasrc'、'hoverinfosrc'、'xsrc'、'ysrc'、'textsrc'、'texttemplatesrc'、'hovertextsrc'、'hovertemplatesrc' 、'textpositionsrc'、'rsrc'、'tsrc'、'key'、'set'、'frame'、'transforms'、'_isNestedKey'、'_isSimpleKey'、'_isGraticule'、'_bbox'变换'，'_isNestedKey'，'_isSimpleKey'，'_isGraticule'，'_bbox'变换'，'_isNestedKey'，'_isSimpleKey'，'_isGraticule'，'_bbox'

标签： rplotlyggplotly

解决方案

我只需添加：

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

更新

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

警告：“分散”对象没有这些属性：“标签”

该图使用两个 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)
        )
      
    })
  }
)

推荐阅读