具有实时 Kaplan-Meier 的闪亮散点图

Question

我在 Shiny 中构建了一个交互式散点图。使用 plotly，我可以选择点组并在绘图旁边的表格中呈现该组的注释。

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)

示例： enter image description here

我希望能够选择（套索或矩形）点组，并在表格下方的单独图中显示这些组之间的生存曲线（以及 p 值，如果可能）。例如，用户将选择左侧菜单上的“Group1”，然后勾勒出所需的点组，然后选择“Group 2”并选择第二组点，依此类推。每次选择后，生存曲线出现在表格下方。一旦完成（并且想要重新开始新的比较，用户点击“重置”）。这是一个示例输出：

示例： Expected Shiny output

我真的不知道从哪里开始如何合并它。任何帮助都会很棒，谢谢

Answer 1

请参阅下面的代码，了解实现此功能的一种可能方式。在整个过程中，rv 是一个 reactiveValues 对象，将数据保存在 data.frame data_df 中。 data_df 中的 group 列跟踪组成员身份，因为在图中选择了点，并根据行是否在三个组之一中取值 1、2、3 或 NA。 （注意：假设这些组不重叠。）

当用户更改单选按钮选择时，绘图选择矩形应该消失，以便为选择下一组点做准备 - 下面的代码使用 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)