r语言 - 实时Kaplan-Meier的闪亮散点图

Question

我在Shiny中构建了一个交互式散点图。使用plot，我可以选择点组，并在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)

的例子:输入图片描述

我希望能够选择(套索或矩形)点组，并在表下的单独绘图中显示这些组之间的生存曲线(如果可能的话还有p值)。例如，用户将在左侧菜单上选择"Group1"，然后勾勒出所需的点组，然后选择"group2"并选择第二组点，以此类推。每次选择后，生存曲线出现在表下。一旦完成(并想重新开始一个新的比较，用户点击"重置")。下面是一个输出示例:

的例子:预期输出

我真的不知道从哪里开始，如何结合这一点。任何帮助将是伟大的，谢谢你

Answer 1

请参阅下面的代码，了解实现此功能的一种可能方法。在整个过程中，rv是一个reactiveValues对象，它保存着数据帧data_df中的数据。data_df中的group列在图中选择点时跟踪组成员关系，并根据行是否在三个组中的一个中取值为1、2、3或NA。(注意:组被假定为不重叠)

当用户改变单选按钮选择时，plot选择矩形应该消失，以便为下一组点的选择做准备-下面的代码使用shinyjs库来完成此操作，并将plotly_selected重置为NULL(否则，如果下一个矩形选择与前一个相同的点集，则将无法注册)。

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)