我正在写一个闪亮的应用程序，里面有一个有阴谋的日光浴图表
在我提供了适当格式的数据帧之后，我必须单击sunburst图表以"；往下钻">
可以模仿这种鼠标"；点击"；事件来控制"；向下钻取"；从诸如selectInput((之类的用户输入？
如何链接selectInput((，以便它也能控制闪亮的阳光？也许是某种观察事件？谢谢你的帮助。
这里有一个代表：
library(shiny)
library(plotly)
library(DT)
d <- data.frame(
ids = c(
"North America", "Europe", "Australia", "North America - Football", "Soccer",
"North America - Rugby", "Europe - Football", "Rugby",
"Europe - American Football","Australia - Football", "Association",
"Australian Rules", "Autstralia - American Football", "Australia - Rugby",
"Rugby League", "Rugby Union"
),
labels = c(
"North<br>America", "Europe", "Australia", "Football", "Soccer", "Rugby",
"Football", "Rugby", "American<br>Football", "Football", "Association",
"Australian<br>Rules", "American<br>Football", "Rugby", "Rugby<br>League",
"Rugby<br>Union"
),
parents = c(
"", "", "", "North America", "North America", "North America", "Europe",
"Europe", "Europe","Australia", "Australia - Football", "Australia - Football",
"Australia - Football", "Australia - Football", "Australia - Rugby",
"Australia - Rugby"
),
stringsAsFactors = FALSE
)
ui <- fluidPage(
mainPanel(
# would like to be able to override or mimic mouse click even with this user input
selectInput(
"make_selection", label = h5("Make selection:"),
choices = c("all" = " ", setNames(nm = d$ids)),
selectize = TRUE,
selected = "all"
),
plotlyOutput("p"),
textOutput("mytext")
)
)
server <- function(input, output, session) {
output$p <- renderPlotly({
plot_ly(d, ids = ~ids, labels = ~labels, parents = ~parents, customdata = ~ids,
level = input$make_selection, type = 'sunburst',
source = "mysource")
})
hoverClick <- reactive({
currentEventData <- unlist(event_data(event = "plotly_click", source = "mysource", priority = "event"))
})
output$mytext <- renderText({
hoverClick()
})
observe({
x <- input$make_selection
# Can use character(0) to remove all choices
if (is.null(hoverClick())){
x <- "all"
} else {
x <- as.character(hoverClick()[3])
}
updateSelectInput(session, "make_selection",
selected = x
# can I add something here so that it just updates the selector without actually
# triggering a selector event? (Otherwise both plotly and the selector are trying to
# choose the level and it is very jerky)
)
})
}
shinyApp(ui = ui, server = server)
您可以使用level参数来指定应显示的级别。我下面的解决方案需要解决两个问题：
- 更改没有动画化(也许您可以使用
plotly.animate找到解决方案或将其作为起点( - 当点击绘图时，
make_selection不会更新(也许你可以玩plotly_sunburstclick事件来更新它
library(shiny)
library(plotly)
d <- data.frame(
ids = c(
"North America", "Europe", "Australia", "North America - Football", "Soccer",
"North America - Rugby", "Europe - Football", "Rugby",
"Europe - American Football","Australia - Football", "Association",
"Australian Rules", "Autstralia - American Football", "Australia - Rugby",
"Rugby League", "Rugby Union"
),
labels = c(
"North<br>America", "Europe", "Australia", "Football", "Soccer", "Rugby",
"Football", "Rugby", "American<br>Football", "Football", "Association",
"Australian<br>Rules", "American<br>Football", "Rugby", "Rugby<br>League",
"Rugby<br>Union"
),
parents = c(
"", "", "", "North America", "North America", "North America", "Europe",
"Europe", "Europe","Australia", "Australia - Football", "Australia - Football",
"Australia - Football", "Australia - Football", "Australia - Rugby",
"Australia - Rugby"
),
stringsAsFactors = FALSE
)
ui <- fluidPage(
mainPanel(
# would like to be able to override or mimic mouse click even with this user input
selectInput(
"make_selection", label = h5("Make selection:"),
choices = c("all" = " ", setNames(nm = d$ids)),
selectize = TRUE,
selected = "all"
),
plotlyOutput("p")
)
)
server <- function(input, output, session) {
output$p <- renderPlotly({
plot_ly(d, ids = ~ids, labels = ~labels, parents = ~parents,
level = input$make_selection, type = 'sunburst') %>%
event_register("plotly_sunburstclick")
})
observeEvent(event_data("plotly_sunburstclick"), {
# get the name of the id and update "make_selection"
})
}
shinyApp(ui = ui, server = server)