向下钻取图中的单击事件
Click event in drill down plots
我正在尝试使用 RShiny 中的 plotly_click 选项来使用点击事件。我想要做的是：单击绘图时，将显示与单击事件对应的数据集。因此，当我在图中的类别中单击 'Office Supplies' 时，会显示与类别列='Office Supplies' 对应的数据集。同样，当我向下钻取到子类别级别并单击图中的任何子类别时，将显示与该子类别对应的数据集。但我无法实现的是：当我点击 'Back' 操作按钮时，我看到一个空数据 table 而不是对应于键 'Office Supplies' 的数据 table 即单击后退按钮时，我看到一个空的 table，这是我不想要的。我应该怎么做？任何帮助，将不胜感激。下面是我的代码：
library(shiny)
library(plotly)
library(dplyr)
library(readr)
sales <- read_csv("https://plotly-r.com/data-raw/sales.csv")
categories <- unique(sales$category)
sub_categories <- unique(sales$sub_category)
ids <- unique(sales$id)
ui <- fluidPage(
uiOutput("history"),
plotlyOutput("bars", height = 200),
plotlyOutput("lines", height = 300),
uiOutput('back'),
uiOutput("back1"),
dataTableOutput("click1")
)
server <- function(input, output, session) {
# These reactive values keep track of the drilldown state
# (NULL means inactive)
drills <- reactiveValues(category = NULL,
sub_category = NULL,
id = NULL)
# filter the data based on active drill-downs
# also create a column, value, which keeps track of which
# variable we're interested in
sales_data <- reactive({
if (!length(drills$category)) {
return(mutate(sales, value = category))
}
sales <- filter(sales, category %in% drills$category)
if (!length(drills$sub_category)) {
return(mutate(sales, value = sub_category))
}
sales <- filter(sales, sub_category %in% drills$sub_category)
mutate(sales, value = id)
})
# bar chart of sales by 'current level of category'
output$bars <- renderPlotly({
a<- sales
render_value(a)
d <- count(sales_data(), value, wt = sales)
p <- plot_ly(d,
x = ~ value,
y = ~ n,
source = "bars",key=~value) %>%
layout(yaxis = list(title = "Total Sales"),
xaxis = list(title = ""))
if (!length(drills$sub_category)) {
add_bars(p, color = ~ value,key=~value)
} else if (!length(drills$id)) {
add_bars(p,key=~value) %>%
layout(hovermode = "x",
xaxis = list(showticklabels = FALSE))
} else {
# add a visual cue of which ID is selected
add_bars(p,key=~value) %>%
filter(value %in% drills$id) %>%
add_bars(color = I("black")) %>%
layout(
hovermode = "x",
xaxis = list(showticklabels = FALSE),
showlegend = FALSE,
barmode = "overlay"
)
}
})
# control the state of the drilldown by clicking the bar graph
observeEvent(event_data("plotly_click", source = "bars"), {
x <- event_data("plotly_click", source = "bars")$x
if (!length(x))
return()
if (!length(drills$category)) {
drills$category <- x
} else if (!length(drills$sub_category)) {
drills$sub_category <- x
} else {
drills$id <- x
}
})
output$back <- renderUI({
if (!is.null(drills$category) && is.null(drills$sub_category)) {
actionButton("clear", "Back", icon("chevron-left"))
}
})
output$back1 <- renderUI({
if (!is.null(drills$sub_category)) {
actionButton("clear1", "Back", icon("chevron-left"))
}
})
observeEvent(input$clear,
drills$category <- NULL)
observeEvent(input$clear1,
drills$sub_category <- NULL)
render_value=function(df_1){
output$click1<- DT::renderDataTable({
s <- event_data("plotly_click",source="bars")
if (is.null(s)){
return(NULL)
}
else if(!is.null(drills$category) && is.null(drills$sub_category)){
ad<- df_1[df_1$category %in% s$key,]
return(DT::datatable(ad))
}
else if(!is.null(drills$sub_category)){
print(s$key)
ad<- df_1[df_1$sub_category %in% s$key,]
return(DT::datatable(ad))
}
})
}
}
shinyApp(ui, server)
由于你没有提供样本数据，我用gapminder的数据来测试。当您单击 sub_category 的 'back' 按钮时，它无法识别图上的单击事件。或者，您可以只输出 sales_data()，如下所示。
library(shiny)
library(plotly)
library(dplyr)
library(readr)
library(gapminder)
#sales <- read_csv("https://plotly-r.com/data-raw/sales.csv")
sales <- gapminder
sales$category <- sales$continent
sales$sub_category <- sales$country
sales$id <- sales$year
sales$n <- sales$lifeExp
sales$sales <- sales$gdpPercap
categories <- unique(sales$category)
sub_categories <- unique(sales$sub_category)
ids <- unique(sales$id)
ui <- fluidPage(
# uiOutput("history"),
plotlyOutput("bars", height = 200),
# plotlyOutput("lines", height = 300),
uiOutput('back'),
uiOutput("back1"),
DTOutput("t1") ## working
,DTOutput("click1") ## not working
)
server <- function(input, output, session) {
# These reactive values keep track of the drilldown state
# (NULL means inactive)
drills <- reactiveValues(category = NULL,
sub_category = NULL,
id = NULL)
# filter the data based on active drill-downs
# also create a column, value, which keeps track of which
# variable we're interested in
sales_data <- reactive({
if (!length(drills$category)) {
return(mutate(sales, value = category))
}
sales <- filter(sales, category %in% drills$category)
if (!length(drills$sub_category)) {
return(mutate(sales, value = sub_category))
}
sales <- filter(sales, sub_category %in% drills$sub_category)
mutate(sales, value = id)
})
output$t1 <- renderDT({
if (is.null(drills$category) & is.null(drills$sub_category) ) return(NULL) ## comment out this line if you want all data to be displayed initially
sales_data()
})
# bar chart of sales by 'current level of category'
output$bars <- renderPlotly({
a<- sales
render_value(a)
d <- count(sales_data(), value, wt = sales)
p <- plot_ly(d,
x = ~ value,
y = ~ n,
source = "bars",key=~value) %>%
layout(yaxis = list(title = "Total Sales"),
xaxis = list(title = ""))
if (!length(drills$sub_category)) {
add_bars(p, color = ~ value,key=~value)
} else if (!length(drills$id)) {
add_bars(p,key=~value) %>%
layout(hovermode = "x",
xaxis = list(showticklabels = FALSE))
} else {
# add a visual cue of which ID is selected
add_bars(p,key=~value) %>%
filter(value %in% drills$id) %>%
add_bars(color = I("black")) %>%
layout(
hovermode = "x",
xaxis = list(showticklabels = FALSE),
showlegend = FALSE,
barmode = "overlay"
)
}
})
# control the state of the drilldown by clicking the bar graph
observeEvent(event_data("plotly_click", source = "bars"), {
x <- event_data("plotly_click", source = "bars")$x
if (!length(x))
return()
if (!length(drills$category)) {
drills$category <- x
} else if (!length(drills$sub_category)) {
drills$sub_category <- x
}else {
drills$id <- x
}
})
output$back <- renderUI({
if (!is.null(drills$category) && is.null(drills$sub_category)) {
actionButton("clear", "Back", icon("chevron-left"))
}
})
output$back1 <- renderUI({
if (!is.null(drills$sub_category)) {
actionButton("clear1", "Back", icon("chevron-left"))
}
})
observeEvent(input$clear,
{drills$category <- NULL})
observeEvent(input$clear1, {
drills$sub_category <- NULL})
render_value=function(df_1){
output$click1<- DT::renderDataTable({
s <- event_data("plotly_click",source="bars")
if (is.null(s)){
return(NULL)
}else if((!is.null(drills$category) && is.null(drills$sub_category))){
print(s$key)
ad<- df_1[df_1$category %in% s$key,]
return(DT::datatable(ad))
}else if(!is.null(drills$sub_category)){
#print(s$key)
ad<- df_1[df_1$sub_category %in% s$key,]
return(DT::datatable(ad))
}
})
}
}
shinyApp(ui, server)
我正在尝试使用 RShiny 中的 plotly_click 选项来使用点击事件。我想要做的是：单击绘图时，将显示与单击事件对应的数据集。因此，当我在图中的类别中单击 'Office Supplies' 时，会显示与类别列='Office Supplies' 对应的数据集。同样，当我向下钻取到子类别级别并单击图中的任何子类别时，将显示与该子类别对应的数据集。但我无法实现的是：当我点击 'Back' 操作按钮时，我看到一个空数据 table 而不是对应于键 'Office Supplies' 的数据 table 即单击后退按钮时，我看到一个空的 table，这是我不想要的。我应该怎么做？任何帮助，将不胜感激。下面是我的代码：
library(shiny)
library(plotly)
library(dplyr)
library(readr)
sales <- read_csv("https://plotly-r.com/data-raw/sales.csv")
categories <- unique(sales$category)
sub_categories <- unique(sales$sub_category)
ids <- unique(sales$id)
ui <- fluidPage(
uiOutput("history"),
plotlyOutput("bars", height = 200),
plotlyOutput("lines", height = 300),
uiOutput('back'),
uiOutput("back1"),
dataTableOutput("click1")
)
server <- function(input, output, session) {
# These reactive values keep track of the drilldown state
# (NULL means inactive)
drills <- reactiveValues(category = NULL,
sub_category = NULL,
id = NULL)
# filter the data based on active drill-downs
# also create a column, value, which keeps track of which
# variable we're interested in
sales_data <- reactive({
if (!length(drills$category)) {
return(mutate(sales, value = category))
}
sales <- filter(sales, category %in% drills$category)
if (!length(drills$sub_category)) {
return(mutate(sales, value = sub_category))
}
sales <- filter(sales, sub_category %in% drills$sub_category)
mutate(sales, value = id)
})
# bar chart of sales by 'current level of category'
output$bars <- renderPlotly({
a<- sales
render_value(a)
d <- count(sales_data(), value, wt = sales)
p <- plot_ly(d,
x = ~ value,
y = ~ n,
source = "bars",key=~value) %>%
layout(yaxis = list(title = "Total Sales"),
xaxis = list(title = ""))
if (!length(drills$sub_category)) {
add_bars(p, color = ~ value,key=~value)
} else if (!length(drills$id)) {
add_bars(p,key=~value) %>%
layout(hovermode = "x",
xaxis = list(showticklabels = FALSE))
} else {
# add a visual cue of which ID is selected
add_bars(p,key=~value) %>%
filter(value %in% drills$id) %>%
add_bars(color = I("black")) %>%
layout(
hovermode = "x",
xaxis = list(showticklabels = FALSE),
showlegend = FALSE,
barmode = "overlay"
)
}
})
# control the state of the drilldown by clicking the bar graph
observeEvent(event_data("plotly_click", source = "bars"), {
x <- event_data("plotly_click", source = "bars")$x
if (!length(x))
return()
if (!length(drills$category)) {
drills$category <- x
} else if (!length(drills$sub_category)) {
drills$sub_category <- x
} else {
drills$id <- x
}
})
output$back <- renderUI({
if (!is.null(drills$category) && is.null(drills$sub_category)) {
actionButton("clear", "Back", icon("chevron-left"))
}
})
output$back1 <- renderUI({
if (!is.null(drills$sub_category)) {
actionButton("clear1", "Back", icon("chevron-left"))
}
})
observeEvent(input$clear,
drills$category <- NULL)
observeEvent(input$clear1,
drills$sub_category <- NULL)
render_value=function(df_1){
output$click1<- DT::renderDataTable({
s <- event_data("plotly_click",source="bars")
if (is.null(s)){
return(NULL)
}
else if(!is.null(drills$category) && is.null(drills$sub_category)){
ad<- df_1[df_1$category %in% s$key,]
return(DT::datatable(ad))
}
else if(!is.null(drills$sub_category)){
print(s$key)
ad<- df_1[df_1$sub_category %in% s$key,]
return(DT::datatable(ad))
}
})
}
}
shinyApp(ui, server)
由于你没有提供样本数据，我用gapminder的数据来测试。当您单击 sub_category 的 'back' 按钮时，它无法识别图上的单击事件。或者，您可以只输出 sales_data()，如下所示。
library(shiny)
library(plotly)
library(dplyr)
library(readr)
library(gapminder)
#sales <- read_csv("https://plotly-r.com/data-raw/sales.csv")
sales <- gapminder
sales$category <- sales$continent
sales$sub_category <- sales$country
sales$id <- sales$year
sales$n <- sales$lifeExp
sales$sales <- sales$gdpPercap
categories <- unique(sales$category)
sub_categories <- unique(sales$sub_category)
ids <- unique(sales$id)
ui <- fluidPage(
# uiOutput("history"),
plotlyOutput("bars", height = 200),
# plotlyOutput("lines", height = 300),
uiOutput('back'),
uiOutput("back1"),
DTOutput("t1") ## working
,DTOutput("click1") ## not working
)
server <- function(input, output, session) {
# These reactive values keep track of the drilldown state
# (NULL means inactive)
drills <- reactiveValues(category = NULL,
sub_category = NULL,
id = NULL)
# filter the data based on active drill-downs
# also create a column, value, which keeps track of which
# variable we're interested in
sales_data <- reactive({
if (!length(drills$category)) {
return(mutate(sales, value = category))
}
sales <- filter(sales, category %in% drills$category)
if (!length(drills$sub_category)) {
return(mutate(sales, value = sub_category))
}
sales <- filter(sales, sub_category %in% drills$sub_category)
mutate(sales, value = id)
})
output$t1 <- renderDT({
if (is.null(drills$category) & is.null(drills$sub_category) ) return(NULL) ## comment out this line if you want all data to be displayed initially
sales_data()
})
# bar chart of sales by 'current level of category'
output$bars <- renderPlotly({
a<- sales
render_value(a)
d <- count(sales_data(), value, wt = sales)
p <- plot_ly(d,
x = ~ value,
y = ~ n,
source = "bars",key=~value) %>%
layout(yaxis = list(title = "Total Sales"),
xaxis = list(title = ""))
if (!length(drills$sub_category)) {
add_bars(p, color = ~ value,key=~value)
} else if (!length(drills$id)) {
add_bars(p,key=~value) %>%
layout(hovermode = "x",
xaxis = list(showticklabels = FALSE))
} else {
# add a visual cue of which ID is selected
add_bars(p,key=~value) %>%
filter(value %in% drills$id) %>%
add_bars(color = I("black")) %>%
layout(
hovermode = "x",
xaxis = list(showticklabels = FALSE),
showlegend = FALSE,
barmode = "overlay"
)
}
})
# control the state of the drilldown by clicking the bar graph
observeEvent(event_data("plotly_click", source = "bars"), {
x <- event_data("plotly_click", source = "bars")$x
if (!length(x))
return()
if (!length(drills$category)) {
drills$category <- x
} else if (!length(drills$sub_category)) {
drills$sub_category <- x
}else {
drills$id <- x
}
})
output$back <- renderUI({
if (!is.null(drills$category) && is.null(drills$sub_category)) {
actionButton("clear", "Back", icon("chevron-left"))
}
})
output$back1 <- renderUI({
if (!is.null(drills$sub_category)) {
actionButton("clear1", "Back", icon("chevron-left"))
}
})
observeEvent(input$clear,
{drills$category <- NULL})
observeEvent(input$clear1, {
drills$sub_category <- NULL})
render_value=function(df_1){
output$click1<- DT::renderDataTable({
s <- event_data("plotly_click",source="bars")
if (is.null(s)){
return(NULL)
}else if((!is.null(drills$category) && is.null(drills$sub_category))){
print(s$key)
ad<- df_1[df_1$category %in% s$key,]
return(DT::datatable(ad))
}else if(!is.null(drills$sub_category)){
#print(s$key)
ad<- df_1[df_1$sub_category %in% s$key,]
return(DT::datatable(ad))
}
})
}
}
shinyApp(ui, server)