Shiny scatterplot with real-time Kaplan-Meier - r

Question

I have constructed an interactive scatterplot in Shiny. Using plotly, I can select groups of points and render the annotations for this group in a table next to the plot.
library(survival)
library(survminer)
mtcars <- get(data("mtcars"))
attach(mtcars)
mtcars$OS <- sample(100, size = nrow(mtcars), replace = TRUE)
mtcars$status <- sample(0:1, size = nrow(mtcars), replace = TRUE)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Test1", tabName = "test1"),
menuItem("Test2", tabName = "test2"),
menuItem("Test3", tabName = "test3"),
radioButtons("radio", h3("Choose groups"),
choices = list("Group 1" = 1, "Group 2" = 2,
"Group 3" = 3),selected = 1),
actionButton("action", "Reset")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "test1",
fluidRow(
column(6,plotlyOutput("plot")),
column(width = 6, offset = 0,
DT::dataTableOutput("brush"),
tags$head(tags$style("#brush{font-size:11px;}")))
)
)
)
)
)
server <- shinyServer(function(input, output, session) {
output$plot <- renderPlotly({
key <- row.names(mtcars)
p <- ggplot(data=mtcars, aes(x=wt,y=mpg,key=key)) +
geom_point(colour="grey", size=2, alpha=1, stroke=0.5)
ggplotly(p) %>% layout(height = 500, width = 500, dragmode = "select")
})
output$brush <- DT::renderDataTable({
d <- event_data("plotly_selected")
req(d)
DT::datatable(mtcars[unlist(d$key), c("mpg", "cyl", "OS", "status")],
options = list(lengthMenu = c(5, 30, 50), pageLength = 30))
}
)
})
shinyApp(ui, server)
Example:
enter image description here
I would like to be able to select (lasso or rectangle) groups of points and display the survival curves between these groups (and p-value if possible) in a separate plot below the table. For example, the user would select 'Group1' on the menu to the left, then outline the desired groups of points, then selct 'Group 2' and select a second group of points, and so on. After each selection, the survival curves appear below the table. Once finished (and would like to restart a new comparison, the user hits 'Reset'). Here's an example output:
Example:
Expected Shiny output
I really don't know where to begin with how to incorporate this. Any help would be great, thank you

Answer 1

See the code below for one possible way to implement this. Throughout, rv is a reactiveValues object holding the data in a data.frame data_df. The group column in data_df tracks group membership as points are selected in the plot, and takes values of 1, 2, 3, or NA depending on whether the row is in one of the three groups. (Note: the groups are assumed to be non-overlapping.)
When the user changes the radio button selection, the plotly selection rectangle should disappear in order to prepare for the selection of the next set of points - the code below uses the shinyjs library to accomplish this, as well as to reset plotly_selected to NULL (otherwise the next rectangular selection will fail to register if it selects the same set of points as the previous one).
library(survival)
library(survminer)
library(plotly)
library(shiny)
library(shinydashboard)
library(shinyjs)
mtcars <- get(data("mtcars"))
attach(mtcars)
mtcars$OS <- sample(100, size = nrow(mtcars), replace = TRUE)
mtcars$status <- sample(0:1, size = nrow(mtcars), replace = TRUE)
jsCode <- "shinyjs.resetSel = function() { Plotly.restyle(plot, {selectedpoints: [null]});}"
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
menuItem("Test1", tabName = "test1"),
menuItem("Test2", tabName = "test2"),
menuItem("Test3", tabName = "test3"),
radioButtons("radio", h3("Choose groups"),
choices = list("Group 1" = 1, "Group 2" = 2,
"Group 3" = 3), selected = 1),
actionButton("action", "Reset all Groups"),
br(),
uiOutput("currentSelections")
)
),
dashboardBody(
useShinyjs(),
extendShinyjs(text = jsCode, functions = c("resetSel")),
tabItems(
tabItem(tabName = "test1",
fluidRow(
column(6,plotlyOutput("plot")),
column(width = 6, offset = 0,
DT::dataTableOutput("brush"),
tags$head(tags$style("#brush{font-size:11px;}")))
),
fluidRow(
column(6),
column(6, plotOutput("survivalCurve"))
)
)
)
)
)
server <- shinyServer(function(input, output, session) {
## mtcars data.frame with an extra group column (initially set to NA)
rv <- reactiveValues(data_df = mtcars %>% mutate(group = NA))
## when a selection is made, assign group values to data_df based on selected radio button
observeEvent(
event_data("plotly_selected"), {
d <- event_data("plotly_selected")
## reset values for this group
rv$data_df$group <- ifelse(rv$data_df$group == input$radio, NA, rv$data_df$group)
## then re-assign values:
rv$data_df[d$key,"group"] <- input$radio
}
)
## when reset button is pressed, reset the selection rectangle
## and also reset the group column of data_df to NA
observeEvent(input$action, {
js$resetSel()
rv$data_df$group <- NA
})
## when radio button changes, reset the selection rectangle and reset plotly_selected
## (otherwise selecting the same set of points for two groups consecutively will
## not register the selection the second time)
observeEvent(input$radio, {
js$resetSel()
runjs("Shiny.setInputValue('plotly_selected-A', null);")
})
## draw the main plot
output$plot <- renderPlotly({
key <- row.names(mtcars)
p <- ggplot(data=mtcars, aes(x=wt,y=mpg,key=key)) +
geom_point(colour="grey", size=2, alpha=1, stroke=0.5)
ggplotly(p) %>% layout(height = 500, width = 500, dragmode = "select")
})
## for each group, show the number of selected points
## (not required by the rest of the app but useful for debugging)
output$currentSelections <- renderUI({
number_by_class <- summary(factor(rv$data_df$group, levels = c("1","2","3")))
tagList(
h5("Current Selections:"),
p(paste0("Group 1: ",number_by_class[1], " points selected")),
p(paste0("Group 2: ",number_by_class[2], " points selected")),
p(paste0("Group 3: ",number_by_class[3], " points selected"))
)
})
output$brush <- DT::renderDataTable({
d <- event_data("plotly_selected")
req(d)
DT::datatable(mtcars[unlist(d$key), c("mpg", "cyl", "OS", "status")],
options = list(lengthMenu = c(5, 30, 50), pageLength = 30))
})
## draw survival curves if a point has been selected
## if none have been selected then draw a blank plot with matching background color
output$survivalCurve <- renderPlot({
if (any(c(1,2,3) %in% rv$data_df$group)) {
fit <- survfit(Surv(mpg, status) ~ group,
data = rv$data_df)
ggsurvplot(fit, data = rv$data_df, risk.table = FALSE)
} else {
par(bg = "#ecf0f5")
plot.new()
}
})
})
shinyApp(ui, server)