添加一个交互按钮来切换映射哪个变量来填充ggplotly in r

Question

使用同一组数据，我制作了两个不同的图块图，如下所示：

数据：

> dput(coupler.graph)
structure(list(Category = c("HBC", "TC", "BSC", "GSC", "GSC", 
"SSC", "SSC", "GSC", "GSC", "SSC", "SSC", "SSC", "HBC", "TC", 
"BSC", "BSC", "GSC", "GSC", "SSC", "HBC", "HBC", "TC", "TC", 
"BSC", "GSC", "GSC", "GSC", "GSC", "GSC", "TC", "BSC", "BSC", 
"GSC", "GSC"), `Bar Size` = c("No. 5", "No. 5", "No. 5", "No. 5", 
"No. 5", "No. 6", "No. 6", "No. 6", "No. 6", "No. 8", "No. 8", 
"No. 8", "No. 8", "No. 8", "No. 8", "No. 8", "No. 8", "No. 8", 
"No. 10", "No. 10", "No. 10", "No. 10", "No. 10", "No. 10", "No. 10", 
"No. 10", "No. 10", "No. 11", "No. 11", "No. 18", "No. 18", "No. 18", 
"No. 18", "No. 18"), `No. Bars` = c(3, 9, 3, 6, 6, 85, 85, 7, 
7, 90, 90, 90, 7, 9, 6, 6, 21, 21, 9, 22, 22, 27, 27, 13, 25, 
25, 25, 8, 8, 4, 4, 4, 4, 4), Failure = c("Bar fracture", "Bar fracture", 
"Bar fracture", "Bar pullout", "Bar fracture", "Bar pullout", 
"Bar fracture", "Coupler failure", "Bar fracture", "Coupler failure", 
"Bar pullout", "Bar fracture", "Bar fracture", "Bar fracture", 
"Bar pullout", "Bar fracture", "Bar fracture", "Bar pullout", 
"Coupler failure", "Coupler failure", "Bar fracture", "Coupler failure", 
"Bar fracture", "Bar fracture", "Bar pullout", "Bar fracture", 
"Coupler failure", "Bar fracture", "Coupler failure", "Coupler failure", 
"Bar fracture", "Bar pullout", "Bar fracture", "Coupler failure"
), x = c("1-3", "7-9", "1-3", "5-7", "5-7", "30-90", "30-90", 
"5-7", "5-7", "30-90", "30-90", "30-90", "5-7", "7-9", "5-7", 
"5-7", "20-30", "20-30", "7-9", "20-30", "20-30", "20-30", "20-30", 
"11-15", "20-30", "20-30", "20-30", "7-9", "7-9", "3-5", "3-5", 
"3-5", "3-5", "3-5")), row.names = c(NA, -34L), class = c("tbl_df", 
"tbl", "data.frame"))

第一个图显示样本数量为：

labels1 <- factor(c("0", "1-3", "3-5", "5-7", "7-9",
            "9-11", "11-15",  "15-20","20-90"), levels = 
              c("0", "1-3", "3-5", "5-7", "7-9",
            "9-11", "11-15",  "15-20","20-30","30-90"))
values1 <- c("white", "#ffffd9", "#edf8b1", "#c7e9b4", "#7fcdbb",
            "#41b6c4", "#1d91c0",  "#225ea8", "#253494","#081d58")

bar_list = c("No. 5", "No. 6",  "No. 8",  "No. 10", "No. 11", "No. 14", "No. 18")

plot1 <- ggplot(coupler.graph) + aes(x = Category, y = fct_inorder(`Bar Size`), fill = factor(x, 
                                    levels = c("0", "1-3", "3-5", "5-7", "7-9",
                                               "9-11", "11-15",  "15-20","20-30", "30-90"))) +
 geom_tile(width=0.9, height=0.9) + theme_classic() + scale_fill_manual(labels = factor(labels1), values = values1) +
 labs(x = "Splicer Type", y = "Bar Size") + scale_y_discrete(limits = bar_list) +
 theme(plot.title = element_blank(), axis.text =  element_text(color = "black", size = 12), axis.ticks.x = element_blank(),
       axis.line = element_line(color = "black", size = 0.2), axis.ticks.y = element_line(color = "black", size = 0.2),
       axis.title.y = element_text(color = "black", size = 16, margin = margin(0,40,0,0)), 
       axis.title.x = element_text(color = "black", size = 16, margin = margin(35,0,0,0)),
       legend.title = element_blank(), legend.text = element_text(color = "black", size = 12)) 

ggplotly(
  p = ggplot2::last_plot(),
  width = NULL,
  height = NULL,
  tooltip = c("Category", "Failure"),
  dynamicTicks = FALSE,
  layerData = 1,
  originalData = TRUE,) %>% add_annotations( text="Number of\nSpecimens", xref="paper", yref="paper",
                  x=1.1, xanchor="left", y=0.8, yanchor="bottom", font = list(size = 18),
                  legendtitle=TRUE, showarrow=FALSE ) %>%
  layout(yaxis = list(title = list(text = "Bar Size", standoff = 30L)),
             xaxis = list(title = list(text = "Bar Size",standoff = 30L)),
             legend = list(orientation = "v", x = 1.1, y = 0.13))

结果图是：

第二个图显示故障类型：

values2 <-  c("Bar fracture" = "red", "Bar pullout" = "blue", "Coupler failure" = "yellow")

plot2 <- ggplot(coupler.graph) + aes(x = Category, y = fct_inorder(`Bar Size`), fill = Failure) +
 geom_tile(width=0.9, height=0.9) + theme_classic() + scale_fill_manual(values = values2) +
 labs(x = "Splicer Type", y = "Bar Size") + scale_y_discrete(limits = bar_list) +
 theme(plot.title = element_blank(), axis.text =  element_text(color = "black", size = 12), axis.ticks.x = element_blank(),
       axis.line = element_line(color = "black", size = 0.2), axis.ticks.y = element_line(color = "black", size = 0.2),
       axis.title.y = element_text(color = "black", size = 16, margin = margin(0,40,0,0)), 
       axis.title.x = element_text(color = "black", size = 16, margin = margin(35,0,0,0)),
       legend.title = element_blank(), legend.text = element_text(color = "black", size = 12)) 

ggplotly(
  p = ggplot2::last_plot(),
  width = NULL,
  height = NULL,
  tooltip = c("Category", "Failure"),
  dynamicTicks = FALSE,
  layerData = 1,
  originalData = TRUE,) %>%
  layout(yaxis = list(title = list(text = "Bar Size", standoff = 30L)),
             xaxis = list(title = list(text = "Bar Size",standoff = 30L)),
             legend = list(orientation = "v", x = 1.1, y = 0.13))

结果图如下所示：

我想向 HTML 输出添加一个按钮，例如 the example here 为不同的图表类型所做的，但在这两个图之间切换。

Answer 1

如果您愿意考虑使用 {shiny}，这里有一种方法 select 根据按钮点击显示的绘图。

视觉

代码

library(shiny)
library(ggplot2)
library(plotly)
library(forcats)



# Load data
coupler.graph <- structure(list(Category = c(
  "HBC", "TC", "BSC", "GSC", "GSC",
  "SSC", "SSC", "GSC", "GSC", "SSC", "SSC", "SSC", "HBC", "TC",
  "BSC", "BSC", "GSC", "GSC", "SSC", "HBC", "HBC", "TC", "TC",
  "BSC", "GSC", "GSC", "GSC", "GSC", "GSC", "TC", "BSC", "BSC",
  "GSC", "GSC"
), `Bar Size` = c(
  "No. 5", "No. 5", "No. 5", "No. 5",
  "No. 5", "No. 6", "No. 6", "No. 6", "No. 6", "No. 8", "No. 8",
  "No. 8", "No. 8", "No. 8", "No. 8", "No. 8", "No. 8", "No. 8",
  "No. 10", "No. 10", "No. 10", "No. 10", "No. 10", "No. 10", "No. 10",
  "No. 10", "No. 10", "No. 11", "No. 11", "No. 18", "No. 18", "No. 18",
  "No. 18", "No. 18"
), `No. Bars` = c(
  3, 9, 3, 6, 6, 85, 85, 7,
  7, 90, 90, 90, 7, 9, 6, 6, 21, 21, 9, 22, 22, 27, 27, 13, 25,
  25, 25, 8, 8, 4, 4, 4, 4, 4
), Failure = c(
  "Bar fracture", "Bar fracture",
  "Bar fracture", "Bar pullout", "Bar fracture", "Bar pullout",
  "Bar fracture", "Coupler failure", "Bar fracture", "Coupler failure",
  "Bar pullout", "Bar fracture", "Bar fracture", "Bar fracture",
  "Bar pullout", "Bar fracture", "Bar fracture", "Bar pullout",
  "Coupler failure", "Coupler failure", "Bar fracture", "Coupler failure",
  "Bar fracture", "Bar fracture", "Bar pullout", "Bar fracture",
  "Coupler failure", "Bar fracture", "Coupler failure", "Coupler failure",
  "Bar fracture", "Bar pullout", "Bar fracture", "Coupler failure"
), x = c(
  "1-3", "7-9", "1-3", "5-7", "5-7", "30-90", "30-90",
  "5-7", "5-7", "30-90", "30-90", "30-90", "5-7", "7-9", "5-7",
  "5-7", "20-30", "20-30", "7-9", "20-30", "20-30", "20-30", "20-30",
  "11-15", "20-30", "20-30", "20-30", "7-9", "7-9", "3-5", "3-5",
  "3-5", "3-5", "3-5"
)), row.names = c(NA, -34L), class = c(
  "tbl_df",
  "tbl", "data.frame"
))



# make plot 1
labels1 <- factor(
  c("0", "1-3", "3-5", "5-7", "7-9", "9-11", "11-15", "15-20", "20-90"),
  levels = c("0", "1-3", "3-5", "5-7", "7-9", "9-11", "11-15", "15-20", "20-30", "30-90")
)

values1 <- c(
  "white", "#ffffd9", "#edf8b1", "#c7e9b4", "#7fcdbb",
  "#41b6c4", "#1d91c0", "#225ea8", "#253494", "#081d58"
)

bar_list <- c("No. 5", "No. 6", "No. 8", "No. 10", "No. 11", "No. 14", "No. 18")

ggplot1 <- ggplot(
  coupler.graph,
  aes(
    x = Category,
    y = fct_inorder(`Bar Size`),
    fill = factor(x, levels = c("0", "1-3", "3-5", "5-7", "7-9", "9-11", "11-15", "15-20", "20-30", "30-90"))
  )
) +
  geom_tile(width = 0.9, height = 0.9) +
  theme_classic() +
  scale_fill_manual(labels = factor(labels1), values = values1) +
  labs(x = "Splicer Type", y = "Bar Size") +
  scale_y_discrete(limits = bar_list) +
  theme(
    plot.title = element_blank(), axis.text = element_text(color = "black", size = 12), axis.ticks.x = element_blank(),
    axis.line = element_line(color = "black", size = 0.2), axis.ticks.y = element_line(color = "black", size = 0.2),
    axis.title.y = element_text(color = "black", size = 16, margin = margin(0, 40, 0, 0)),
    axis.title.x = element_text(color = "black", size = 16, margin = margin(35, 0, 0, 0)),
    legend.title = element_blank(), legend.text = element_text(color = "black", size = 12)
  )

ggplotly1 <- ggplotly(
  p = ggplot1,
  width = NULL,
  height = NULL,
  tooltip = c("Category", "Failure"),
  dynamicTicks = FALSE,
  layerData = 1,
  originalData = TRUE,
) %>%
  add_annotations(
    text = "Number of\nSpecimens", xref = "paper", yref = "paper",
    x = 1.1, xanchor = "left", y = 0.8, yanchor = "bottom", font = list(size = 18),
    legendtitle = TRUE, showarrow = FALSE
  ) %>%
  layout(
    yaxis = list(title = list(text = "Bar Size", standoff = 30L)),
    xaxis = list(title = list(text = "Bar Size", standoff = 30L)),
    legend = list(orientation = "v", x = 1.1, y = 0.13)
  )



# make plot 2
values2 <- c("Bar fracture" = "red", "Bar pullout" = "blue", "Coupler failure" = "yellow")

ggplot2 <- ggplot(coupler.graph) +
  aes(x = Category, y = fct_inorder(`Bar Size`), fill = Failure) +
  geom_tile(width = 0.9, height = 0.9) +
  theme_classic() +
  scale_fill_manual(values = values2) +
  labs(x = "Splicer Type", y = "Bar Size") +
  scale_y_discrete(limits = bar_list) +
  theme(
    plot.title = element_blank(), axis.text = element_text(color = "black", size = 12), axis.ticks.x = element_blank(),
    axis.line = element_line(color = "black", size = 0.2), axis.ticks.y = element_line(color = "black", size = 0.2),
    axis.title.y = element_text(color = "black", size = 16, margin = margin(0, 40, 0, 0)),
    axis.title.x = element_text(color = "black", size = 16, margin = margin(35, 0, 0, 0)),
    legend.title = element_blank(), legend.text = element_text(color = "black", size = 12)
  )

ggplotly2 <- ggplotly(
  p = ggplot2,
  width = NULL,
  height = NULL,
  tooltip = c("Category", "Failure"),
  dynamicTicks = FALSE,
  layerData = 1,
  originalData = TRUE,
) %>%
  layout(
    yaxis = list(title = list(text = "Bar Size", standoff = 30L)),
    xaxis = list(title = list(text = "Bar Size", standoff = 30L)),
    legend = list(orientation = "v", x = 1.1, y = 0.13)
  )



ui <- fluidPage(
    titlePanel("Swap Plotlies"),
    sidebarLayout(
        sidebarPanel(
            flowLayout(
                actionButton("show_plot_1", "Show Plot 1"),
                actionButton("show_plot_2", "Show Plot 2")
            )
        ),
        mainPanel(
            uiOutput("plot_hole")
        )
    )
)

server <- function(input, output) {
    
    observeEvent(input$show_plot_1, { 
        output$plot_hole <- renderUI({ plotlyOutput("plot_1") })
    })
    
    observeEvent(input$show_plot_2, { 
        output$plot_hole <- renderUI({ plotlyOutput("plot_2") })
    })
    
    output$plot_1 <- renderPlotly({ ggplotly1 })
    
    output$plot_2 <- renderPlotly({ ggplotly2 })
}

shinyApp(ui = ui, server = server)

Answer 2

如果你想创建一个静态 html 文件，你可以使用一些自定义 js 和 html 来做你想做的。为此，您首先需要一个小辅助函数，您可以将其添加到降价文件中：

<script type="text/javascript">
<!--
    function showSolution(){
        first=document.getElementById('first')
        second=document.getElementById('second')
        if(first.style.visibility=='visible'){
            first.style.visibility='hidden';
            first.style.display='none';
            second.style.visibility="visible";
            second.style.display='block';
        }else{
            first.style.visibility="visible";
            first.style.display='block';
            second.style.visibility='hidden';
            second.style.display='none';
        }
    }

    -->

那么您需要一个使用辅助功能的按钮：

<input type='button' value='Change plot' onclick='showSolution();'/>

最后，您只需将图形创建块包装到一些 div 标签中：

<div id='first' style='visibility:visible;display:block'>
```{r}
labels1 <- factor(c("0", "1-3", "3-5", "5-7", "7-9",
            "9-11", "11-15",  "15-20","20-90"), levels = 
              c("0", "1-3", "3-5", "5-7", "7-9",
            "9-11", "11-15",  "15-20","20-30","30-90"))
values1 <- c("white", "#ffffd9", "#edf8b1", "#c7e9b4", "#7fcdbb",
            "#41b6c4", "#1d91c0",  "#225ea8", "#253494","#081d58")

bar_list = c("No. 5", "No. 6",  "No. 8",  "No. 10", "No. 11", "No. 14", "No. 18")

plot1 <- ggplot(coupler.graph) + aes(x = Category, y = fct_inorder(`Bar Size`), fill = factor(x, 
                                    levels = c("0", "1-3", "3-5", "5-7", "7-9",
                                               "9-11", "11-15",  "15-20","20-30", "30-90"))) +
 geom_tile(width=0.9, height=0.9) + theme_classic() + scale_fill_manual(labels = factor(labels1), values = values1) +
 labs(x = "Splicer Type", y = "Bar Size") + scale_y_discrete(limits = bar_list) +
 theme(plot.title = element_blank(), axis.text =  element_text(color = "black", size = 12), axis.ticks.x = element_blank(),
       axis.line = element_line(color = "black", size = 0.2), axis.ticks.y = element_line(color = "black", size = 0.2),
       axis.title.y = element_text(color = "black", size = 16, margin = margin(0,40,0,0)), 
       axis.title.x = element_text(color = "black", size = 16, margin = margin(35,0,0,0)),
       legend.title = element_blank(), legend.text = element_text(color = "black", size = 12)) 

ggplotly(
  p = ggplot2::last_plot(),
  width = NULL,
  height = NULL,
  tooltip = c("Category", "Failure"),
  dynamicTicks = FALSE,
  layerData = 1,
  originalData = TRUE,) %>% add_annotations( text="Number of\nSpecimens", xref="paper", yref="paper",
                  x=1.1, xanchor="left", y=0.8, yanchor="bottom", font = list(size = 18),
                  legendtitle=TRUE, showarrow=FALSE ) %>%
  layout(yaxis = list(title = list(text = "Bar Size", standoff = 30L)),
             xaxis = list(title = list(text = "Bar Size",standoff = 30L)),
             legend = list(orientation = "v", x = 1.1, y = 0.13))
```

</div>


<div id='second' style='visibility:hidden;display:none'>
```{r}
values2 <-  c("Bar fracture" = "red", "Bar pullout" = "blue", "Coupler failure" = "yellow")

plot2 <- ggplot(coupler.graph) + aes(x = Category, y = fct_inorder(`Bar Size`), fill = Failure) +
 geom_tile(width=0.9, height=0.9) + theme_classic() + scale_fill_manual(values = values2) +
 labs(x = "Splicer Type", y = "Bar Size") + scale_y_discrete(limits = bar_list) +
 theme(plot.title = element_blank(), axis.text =  element_text(color = "black", size = 12), axis.ticks.x = element_blank(),
       axis.line = element_line(color = "black", size = 0.2), axis.ticks.y = element_line(color = "black", size = 0.2),
       axis.title.y = element_text(color = "black", size = 16, margin = margin(0,40,0,0)), 
       axis.title.x = element_text(color = "black", size = 16, margin = margin(35,0,0,0)),
       legend.title = element_blank(), legend.text = element_text(color = "black", size = 12)) 

ggplotly(
  p = ggplot2::last_plot(),
  width = NULL,
  height = NULL,
  tooltip = c("Category", "Failure"),
  dynamicTicks = FALSE,
  layerData = 1,
  originalData = TRUE,) %>%
  layout(yaxis = list(title = list(text = "Bar Size", standoff = 30L)),
             xaxis = list(title = list(text = "Bar Size",standoff = 30L)),
             legend = list(orientation = "v", x = 1.1, y = 0.13))
```
</div>

这将导致 html 像这样：

添加一个交互按钮来切换映射哪个变量来填充ggplotly in r

Add an interactive button to switch which variable is mapped to fill in ggplotly in r

r

ggplot2

plotly

ggplotly

视觉

代码