带有实时 Kaplan-Meier 的闪亮散点图
Shiny scatterplot with real-time Kaplan-Meier
我在 Shiny 中构建了一个交互式散点图。使用 plotly，我可以 select 组点并在图旁边的 table 中呈现该组的注释。
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
我希望能够 select（套索或矩形）点组，并在 [=30 下面的单独图中显示这些组之间的生存曲线（如果可能的话还有 p 值） =].例如，用户将 select 'Group1' 在左侧的菜单上，然后勾勒出所需的点组，然后选择 'Group 2' 和 select 第二组点，等等。在每个 select 离子后，生存曲线出现在 table 下方。完成后（并想重新开始新的比较，用户点击 'Reset'）。这是一个示例输出：
示例：
Expected Shiny output
我真的不知道从哪里开始如何合并它。任何帮助都会很棒，谢谢
请参阅下面的代码，了解一种可能的实现方式。自始至终，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)
我在 Shiny 中构建了一个交互式散点图。使用 plotly，我可以 select 组点并在图旁边的 table 中呈现该组的注释。
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
我希望能够 select（套索或矩形）点组，并在 [=30 下面的单独图中显示这些组之间的生存曲线（如果可能的话还有 p 值） =].例如，用户将 select 'Group1' 在左侧的菜单上，然后勾勒出所需的点组，然后选择 'Group 2' 和 select 第二组点，等等。在每个 select 离子后，生存曲线出现在 table 下方。完成后（并想重新开始新的比较，用户点击 'Reset'）。这是一个示例输出：
示例： Expected Shiny output
我真的不知道从哪里开始如何合并它。任何帮助都会很棒，谢谢
请参阅下面的代码，了解一种可能的实现方式。自始至终，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)