我有一个带有侧边栏的 Shinyapp,你可以选择两个选项并在 Plot 选项卡中显示结果。在“单击绘图”选项卡中,当您单击“绘图”选项卡中的图形中的点时显示结果。因此,我希望当我单击点时打开“单击绘图”选项卡,以及如何配置获取每个选项卡的 href 的 url?我想我需要一些关于 Javascript 的东西,但我不确定。
# Libraries
library(shiny)
library(bs4Dash)
library(plotly)
# function navbar menu and navbar tab
menu <- function(..., id = NULL) {
if (is.null(id)) id <- paste0("tabs_", round(stats::runif(1, min = 0, max = 1e9)))
tags$ul(
...,
status = "primary",
class = "navbar-nav dropdown sidebar-menu",
role = "menu",
div(
id = id,
class = "sidebarMenuSelectedTabItem",
`data-value` = "null",
)
)
}
tab <- function(tabName, ..., icon = NULL) {
tags$li(
class = "nav-item",
tags$a(
class = "nav-link",
id = paste0("tab-", tabName),
href = paste0("#shiny-tab-", tabName),
`data-toggle` = "tab",
`data-value` = tabName,
icon,
tags$p(...)
)
)
}
ui <- dashboardPage(
dark = NULL,
header = dashboardHeader(
menu(
tab(tabName = "plot_", "Plot"),
tab(tabName = "click", "Click Plot")
)
),
# sidebar ------------------------------------------------------------
sidebar = dashboardSidebar(
skin = "light",
elevation = 3,
radioButtons("plotType", "Plot Type:", choices = c("ggplotly", "plotly"))
),
# dashboard body ----------------------------------------------------------
body = dashboardBody(
tabItems(
# plot ---------------------------------------------------------------
tabItem(
tabName = "plot_",
fluidRow(
plotlyOutput("plot")
)
),
# click ---------------------------------------------------------------
tabItem(tabName = "click",
fluidRow(
verbatimTextOutput("click")
)
)
)
)
)
server <- function(input, output, session) {
nms <- row.names(mtcars)
output$plot <- renderPlotly({
p <- if (identical(input$plotType, "ggplotly")) {
ggplotly(ggplot(mtcars, aes(x = mpg, y = wt, customdata = nms)) + geom_point())
} else {
plot_ly(mtcars, x = ~mpg, y = ~wt, customdata = nms)
}
p %>%
layout(dragmode = "select") %>%
event_register("plotly_selecting")
})
output$click <- renderPrint({
d <- event_data("plotly_click")
if (is.null(d)) "Select an event" else unique(d$x)
})
}
shinyApp(ui, server)