In the shiny app below I use plotly_click_event on one of the 3 linecharts to pick a point and then subset the other 2 linecharts based on that point. Then I reset using the RESET button. What I would like to improve is to be able to pick more than one points and then decide when to subset after pressing another actionButton() called SUBSET.
library(shiny)
library(shinydashboard)
library(plotly)
library(dplyr)
library(ggplot2)
library(bupaR)
pr59<-structure(list(case_id = c("WC4120721", "WC4120667", "WC4120689",
"WC4121068", "WC4120667", "WC4120666", "WC4120667", "WC4121068",
"WC4120667", "WC4121068"), lifecycle = c(110, 110, 110, 110,
120, 110, 130, 120, 10, 130), action = c("WC4120721-CN354877",
"WC4120667-CN354878", "WC4120689-CN356752", "WC4121068-CN301950",
"WC4120667-CSW310", "WC4120666-CN354878", "WC4120667-CSW308",
"WC4121068-CSW303", "WC4120667-CSW309", "WC4121068-CSW308"),
activity = c("Forged Wire, Medium (Sport)", "Forged Wire, Medium (Sport)",
"Forged Wire, Medium (Sport)", "Forged Wire, Medium (Sport)",
"BBH-1&2", "Forged Wire, Medium (Sport)", "TCE Cleaning",
"SOLO Oil", "Tempering", "TCE Cleaning"), resource = c("3419",
"3216", "3409", "3201", "C3-100", "3216", "C3-080", "C3-030",
"C3-090", "C3-080"), timestamp = structure(c(1606964400,
1607115480, 1607435760, 1607568120, 1607630220, 1607670780,
1607685420, 1607710800, 1607729520, 1607744100), tzone = "", class = c("POSIXct",
"POSIXt")), .order = 1:10), row.names = c(NA, -10L), class = c("eventlog",
"log", "tbl_df", "tbl", "data.frame"), spec = structure(list(
cols = list(case_id = structure(list(), class = c("collector_character",
"collector")), lifecycle = structure(list(), class = c("collector_double",
"collector")), action = structure(list(), class = c("collector_character",
"collector")), activity = structure(list(), class = c("collector_character",
"collector")), resource = structure(list(), class = c("collector_character",
"collector")), timestamp = structure(list(), class = c("collector_character",
"collector"))), default = structure(list(), class = c("collector_guess",
"collector")), delim = ";"), class = "col_spec"), case_id = "case_id", activity_id = "activity", activity_instance_id = "action", lifecycle_id = "lifecycle", resource_id = "resource", timestamp = "timestamp")
ui <- tags$body(
dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(
actionButton("sub","SUBSET"),
actionButton("res","RESET")
),
body = dashboardBody(
plotlyOutput("plot1"),
plotlyOutput("plot2"),
plotlyOutput("plot3")
)
)
)
server <- function(input, output, session) {
output$plot1 <- renderPlotly({
if (!is.null(myPlotEventData2())) {
displaydat <- subset(pr59, as.Date(timestamp) %in% as.Date(myPlotEventData2()$customdata))
} else if (!is.null(myPlotEventData3())){
displaydat <- subset(pr59, as.Date(timestamp) %in% as.Date(myPlotEventData3()$customdata))
} else {
displaydat <- pr59
}
dat <- displaydat |> group_by(date = as.Date(timestamp)) |> bupaR::n_cases()
p <- ggplot(data = dat, aes(x = date, y = n_cases, customdata = date)) +
geom_area(fill = "#69b3a2", alpha = 0.4) +
geom_line(color = "#69b3a2", size = 0.5) +
geom_point(size = 1, color = "#69b3a2") + scale_color_grey() + theme_classic() +
labs(title = "Cases per month", x = "timestamp", y = "Cases")
ggplotly(p, source = "myPlotSource1")
})
output$plot2 <- renderPlotly({
if (!is.null(myPlotEventData1())) {
displaydat <- subset(pr59, as.Date(timestamp) %in% as.Date(myPlotEventData1()$customdata))
} else if (!is.null(myPlotEventData3())){
displaydat <- subset(pr59, as.Date(timestamp) %in% as.Date(myPlotEventData3()$customdata))
} else {
displaydat <- pr59
}
dat <- displaydat|> group_by(date = as.Date(timestamp)) |> bupaR::n_cases()
p <- ggplot(data = dat, aes(x = date, y = n_cases, customdata = date)) +
geom_area(fill = "#69b3a2", alpha = 0.4) +
geom_line(color = "#69b3a2", size = 0.5) +
geom_point(size = 1, color = "#69b3a2") + scale_color_grey() + theme_classic() +
labs(title = "Cases per month", x = "timestamp", y = "events")
ggplotly(p, source = "myPlotSource2")
})
output$plot3 <- renderPlotly({
if (!is.null(myPlotEventData1())) {
displaydat <- subset(pr59, as.Date(timestamp) %in% as.Date(myPlotEventData1()$customdata))
} else if (!is.null(myPlotEventData2())){
displaydat <- subset(pr59, as.Date(timestamp) %in% as.Date(myPlotEventData2()$customdata))
} else {
displaydat <- pr59
}
dat <- displaydat |> group_by(date = as.Date(timestamp)) |> bupaR::n_cases()
p <- ggplot(data = dat, aes(x =date, y = n_cases, customdata = date)) +
geom_area(fill = "#69b3a2", alpha = 0.4) +
geom_line(color = "#69b3a2", size = 0.5) +
geom_point(size = 1, color = "#69b3a2") + scale_color_grey() + theme_classic() +
labs(title = "Cases per month", x = "timestamp", y = "objects")
ggplotly(p, source = "myPlotSource3")
})
myPlotEventData1 <- reactiveVal()
myPlotEventData2 <- reactiveVal()
myPlotEventData3 <- reactiveVal()
observe({
myPlotEventData1(event_data(event = "plotly_click", source = "myPlotSource1"))
})
observe({
myPlotEventData2(event_data(event = "plotly_click", source = "myPlotSource2"))
})
observe({
myPlotEventData3(event_data(event = "plotly_click", source = "myPlotSource3"))
})
observeEvent(input$res, {
myPlotEventData1(NULL)
myPlotEventData2(NULL)
myPlotEventData3(NULL)
})
}
shinyApp(ui, server)
Your example is by far not minimal, so I created a POC of how this can be achieved.
The idea is as follows:
reactiveValues list.subset you use this list to select the relevant points.reset resets this reactiveList and all data is returned.As it was not clear how clicks on different graphs should be handled, I decided on the follwoing logic: a click to a point in any graph panel adds this point to the filter criterion. Upon subset all data are subset w.r.t. to this filter criterion.
library(shiny)
library(dplyr)
library(plotly)
## sample data
sample_dat <- expand.grid(
when = seq.Date(as.Date("2022-1-1"), as.Date("2022-1-31"), by = "days"),
grp = factor(paste("Group", 1:3))
) %>%
as_tibble() %>%
mutate(y = scales::rescale((9496.5 - as.numeric(when)), c(-2, 2)) ^
as.numeric(grp))
make_plotly <- function(dat, wh = levels(dat$grp)) {
wh <- match.arg(wh)
dat %>%
filter(grp == wh) %>%
plot_ly(source = sub(" ", "_", wh)) %>%
add_trace(x = ~ when, y = ~ y, type = "scatter", mode = "lines+markers")
}
grph_ht <- "300px"
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("reset", "RESET"),
actionButton("subset", "SUBSET"),
verbatimTextOutput("dbg")
),
mainPanel(
plotlyOutput("plot1", height = grph_ht),
plotlyOutput("plot2", height = grph_ht),
plotlyOutput("plot3", height = grph_ht)
)
)
)
server <- function(input, output, session) {
get_clicked_points <- reactive({
res <- Reduce(rbind, reactiveValuesToList(clicked_points))
if (!is.null(res)) {
res %>%
distinct()
} else {
res
}
})
get_rel_data <- reactive({
clicked_pts <- get_clicked_points()
dat <- sample_dat
if (!is.null(clicked_pts)) {
dat <- dat %>%
inner_join(clicked_pts %>%
transmute(when = as.Date(x)),
"when")
}
dat
})
## store clicked points in reactive
clicked_points <- reactiveValues(Group_1 = NULL,
Group_2 = NULL,
Group_3 = NULL)
trigger_regraph <- reactive({
list(input$reset, input$subset)
})
## In this loop we create the render functions and the click observers
for (idx in 1:3) {
local({
idx <- idx
## Render plotly
output[[paste0("plot", idx)]] <<- renderPlotly({
trigger_regraph()
make_plotly(isolate(get_rel_data()), paste("Group", idx))
})
## Click handler
nm <- paste0("Group_", idx)
observe({
trg <- event_data("plotly_click", nm, priority = "event") %>%
req() %>%
mutate(src = nm)
op <- isolate(clicked_points[[nm]])
clicked_points[[nm]] <<- rbind(op, trg) %>%
distinct()
})
})
}
## clear selected points
observeEvent(input$reset, {
nms <- names(clicked_points)
for (nm in nms) {
local({
nm <- nm
clicked_points[[nm]] <<- NULL
})
}
})
output$dbg <- renderPrint(get_clicked_points())
}
shinyApp(ui, server)