闪亮：如何仅在单击 actionButton() 时打印带有绘图的整个 Tabset()？
shiny: How to print an entire Tabset() with plots only when actionButton() is clicked?
我对 shiny 完全陌生，我正尝试通过构建这个简单的 app 来学习它。
它目前在单击 actionButton() 后根据特定的 input 值打印两个不同的 ggplots。但是，当两个图并排打印时，我发现图形有点偏离。
问题： 我怎样才能集成一个 Tabset 当 actionButton() 被点击时 只有 打印出来？ Tabset 应该包含两个选项卡 - 每个图一个。
我的应用目前看起来像这样
单击 actionButton() 时打印两个图：
我想打印这样的东西：
和
在 ui 中，我尝试了多种变体：
tabsetPanel(type = "tabs",
tabPanel("Plot1", plotOutput("surv_plot")), .....
没有预期的输出。
我的 shinyapp 是用（欢迎一般评论和脚本改进）编写的：
library(shiny)
library(shinyjs)
library(survminer)
library(shinycustomloader)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
br(),
titlePanel(
h1("Text", align="center")
),
br(),
div(HTML("Text, <em>et al.</em>: <strong>Text</strong>" )),
div(HTML("DOI: " )),
br(), br(),
fluidRow(
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_fjernet", "Lymph Nodal Yield",
min = 2, max = 120, value = 40)
)
),
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_sygdom", "Number of positive lymph nodes",
min = 0, max = 40, value = 0)
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("ecs", "Extracapsular extension", c("No","Yes"))
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("contra_pos", "Neck involvement", c("Contra.","Ipsi."))
)
)
),
fluidRow(align="center", br(), actionBttn("do", "Submit", style = "material-flat")),
br(), br(),
h3(textOutput("starttext"), align="center"),
tags$head(tags$style("#starttext{color: grey20;
font-size: 20px;
font-style: plain;
}"
)
),
fluidRow(br(),
column(12, align="center",
withLoader(plotOutput("load_plot", width = "1%", height="10px"),
type="html", loader="dnaspin")
),
column(6, align="center",
textOutput("nomtext"),
tags$head(tags$style("#nomtext{color: grey20;
font-size: 40px;
font-style: plain;
}"
)
),
plotOutput("surv_nom", width = "105%", height="600px")
),
column(6, align="center",
textOutput("survtext"),
tags$head(tags$style("#survtext{color: grey20;
font-size: 40px;
font-style: plain;
}"
)
),
plotOutput("surv_plot", width = "95%", height="600px")
)
)
)
server <- function(input, output, session) {
observeEvent(input[["n_sygdom"]], {
if(input[["n_sygdom"]] < 1){
disable("ecs")
disable("contra_pos")
}else{
enable("ecs")
enable("contra_pos")
}
})
rvs <- reactiveValues(n_sygdom = 0)
observeEvent(input$n_sygdom, {
if ((input$n_sygdom == 0)) {
updateRadioButtons(session, "ecs", selected = "No")
updateRadioButtons(session, "contra_pos", selected = "Contra.")
}
rvs$n_sygdom <- input$n_sygdom
})
observe(
updateSliderInput(
session = session,
inputId = "n_sygdom",
max = min(40, input$n_fjernet),
value = min(input$n_fjernet, input$n_sygdom)
)
)
reactive_nom_text <- eventReactive(input$do, {
paste0("Individualized pN-score")
})
output$nomtext <- renderText({
reactive_nom_text()
})
reactive_surv_text <- eventReactive(input$do, {
paste0("Survival probability")
})
output$survtext <- renderText({
reactive_surv_text()
})
reactive_start <- eventReactive(input$do, {
paste0("Such patient yield a pN-score of ")
})
output$starttext <- renderText({
reactive_start()
})
reactive_surv_plot <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_plot <- renderPlot({
reactive_surv_plot()
})
reactive_surv_nom <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_nom <- renderPlot({
reactive_surv_nom()
})
reactive_load <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$load_plot <- renderPlot({
reactive_load()
})
}
shinyApp(ui, server)
您可以在ui中使用uiOutput，在server中使用renderUI，仅在单击按钮时生成具有两个选项卡的选项卡集。
这是你的例子：
library(shiny)
library(shinyjs)
library(survminer)
library(shinycustomloader)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
br(),
titlePanel(
h1("Text", align="center")
),
br(),
div(HTML("Text, <em>et al.</em>: <strong>Text</strong>" )),
div(HTML("DOI: " )),
br(), br(),
fluidRow(
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_fjernet", "Lymph Nodal Yield",
min = 2, max = 120, value = 40)
)
),
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_sygdom", "Number of positive lymph nodes",
min = 0, max = 40, value = 0)
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("ecs", "Extracapsular extension", c("No","Yes"))
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("contra_pos", "Neck involvement", c("Contra.","Ipsi."))
)
)
),
fluidRow(align="center", br(), actionBttn("do", "Submit", style = "material-flat")),
br(), br(),
h3(textOutput("starttext"), align="center"),
tags$head(tags$style("#starttext{color: grey20;
font-size: 20px;
font-style: plain;
}"
)
),
fluidRow(br(),
column(12, align="center",
withLoader(plotOutput("load_plot", width = "1%", height="10px"),
type="html", loader="dnaspin"),
uiOutput("test")
)
)
)
server <- function(input, output, session) {
observeEvent(input$do, {
output$test <- renderUI({
tabsetPanel(id = "something",
tabPanel(title = "Panel 1",
plotOutput("surv_nom")),
tabPanel(title = "Panel 2",
plotOutput("surv_plot"))
)
})
})
observeEvent(input[["n_sygdom"]], {
if(input[["n_sygdom"]] < 1){
disable("ecs")
disable("contra_pos")
}else{
enable("ecs")
enable("contra_pos")
}
})
rvs <- reactiveValues(n_sygdom = 0)
observeEvent(input$n_sygdom, {
if ((input$n_sygdom == 0)) {
updateRadioButtons(session, "ecs", selected = "No")
updateRadioButtons(session, "contra_pos", selected = "Contra.")
}
rvs$n_sygdom <- input$n_sygdom
})
observe(
updateSliderInput(
session = session,
inputId = "n_sygdom",
max = min(40, input$n_fjernet),
value = min(input$n_fjernet, input$n_sygdom)
)
)
reactive_nom_text <- eventReactive(input$do, {
paste0("Individualized pN-score")
})
output$nomtext <- renderText({
reactive_nom_text()
})
reactive_surv_text <- eventReactive(input$do, {
paste0("Survival probability")
})
output$survtext <- renderText({
reactive_surv_text()
})
reactive_start <- eventReactive(input$do, {
paste0("Such patient yield a pN-score of ")
})
output$starttext <- renderText({
reactive_start()
})
reactive_surv_plot <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_plot <- renderPlot({
reactive_surv_plot()
})
reactive_surv_nom <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_nom <- renderPlot({
reactive_surv_nom()
})
reactive_load <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$load_plot <- renderPlot({
reactive_load()
})
}
shinyApp(ui, server)
我对 shiny 完全陌生，我正尝试通过构建这个简单的 app 来学习它。
它目前在单击 actionButton() 后根据特定的 input 值打印两个不同的 ggplots。但是，当两个图并排打印时，我发现图形有点偏离。
问题： 我怎样才能集成一个 Tabset 当 actionButton() 被点击时 只有 打印出来？ Tabset 应该包含两个选项卡 - 每个图一个。
我的应用目前看起来像这样
单击 actionButton() 时打印两个图：
我想打印这样的东西：
和
在 ui 中，我尝试了多种变体：
tabsetPanel(type = "tabs",
tabPanel("Plot1", plotOutput("surv_plot")), .....
没有预期的输出。
我的 shinyapp 是用（欢迎一般评论和脚本改进）编写的：
library(shiny)
library(shinyjs)
library(survminer)
library(shinycustomloader)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
br(),
titlePanel(
h1("Text", align="center")
),
br(),
div(HTML("Text, <em>et al.</em>: <strong>Text</strong>" )),
div(HTML("DOI: " )),
br(), br(),
fluidRow(
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_fjernet", "Lymph Nodal Yield",
min = 2, max = 120, value = 40)
)
),
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_sygdom", "Number of positive lymph nodes",
min = 0, max = 40, value = 0)
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("ecs", "Extracapsular extension", c("No","Yes"))
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("contra_pos", "Neck involvement", c("Contra.","Ipsi."))
)
)
),
fluidRow(align="center", br(), actionBttn("do", "Submit", style = "material-flat")),
br(), br(),
h3(textOutput("starttext"), align="center"),
tags$head(tags$style("#starttext{color: grey20;
font-size: 20px;
font-style: plain;
}"
)
),
fluidRow(br(),
column(12, align="center",
withLoader(plotOutput("load_plot", width = "1%", height="10px"),
type="html", loader="dnaspin")
),
column(6, align="center",
textOutput("nomtext"),
tags$head(tags$style("#nomtext{color: grey20;
font-size: 40px;
font-style: plain;
}"
)
),
plotOutput("surv_nom", width = "105%", height="600px")
),
column(6, align="center",
textOutput("survtext"),
tags$head(tags$style("#survtext{color: grey20;
font-size: 40px;
font-style: plain;
}"
)
),
plotOutput("surv_plot", width = "95%", height="600px")
)
)
)
server <- function(input, output, session) {
observeEvent(input[["n_sygdom"]], {
if(input[["n_sygdom"]] < 1){
disable("ecs")
disable("contra_pos")
}else{
enable("ecs")
enable("contra_pos")
}
})
rvs <- reactiveValues(n_sygdom = 0)
observeEvent(input$n_sygdom, {
if ((input$n_sygdom == 0)) {
updateRadioButtons(session, "ecs", selected = "No")
updateRadioButtons(session, "contra_pos", selected = "Contra.")
}
rvs$n_sygdom <- input$n_sygdom
})
observe(
updateSliderInput(
session = session,
inputId = "n_sygdom",
max = min(40, input$n_fjernet),
value = min(input$n_fjernet, input$n_sygdom)
)
)
reactive_nom_text <- eventReactive(input$do, {
paste0("Individualized pN-score")
})
output$nomtext <- renderText({
reactive_nom_text()
})
reactive_surv_text <- eventReactive(input$do, {
paste0("Survival probability")
})
output$survtext <- renderText({
reactive_surv_text()
})
reactive_start <- eventReactive(input$do, {
paste0("Such patient yield a pN-score of ")
})
output$starttext <- renderText({
reactive_start()
})
reactive_surv_plot <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_plot <- renderPlot({
reactive_surv_plot()
})
reactive_surv_nom <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_nom <- renderPlot({
reactive_surv_nom()
})
reactive_load <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$load_plot <- renderPlot({
reactive_load()
})
}
shinyApp(ui, server)
您可以在ui中使用uiOutput，在server中使用renderUI，仅在单击按钮时生成具有两个选项卡的选项卡集。
这是你的例子：
library(shiny)
library(shinyjs)
library(survminer)
library(shinycustomloader)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
br(),
titlePanel(
h1("Text", align="center")
),
br(),
div(HTML("Text, <em>et al.</em>: <strong>Text</strong>" )),
div(HTML("DOI: " )),
br(), br(),
fluidRow(
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_fjernet", "Lymph Nodal Yield",
min = 2, max = 120, value = 40)
)
),
column(
3,
wellPanel(
style = "height:150px",
sliderInput("n_sygdom", "Number of positive lymph nodes",
min = 0, max = 40, value = 0)
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("ecs", "Extracapsular extension", c("No","Yes"))
)
),
column(
3,
wellPanel(
style = "height:150px",
radioButtons("contra_pos", "Neck involvement", c("Contra.","Ipsi."))
)
)
),
fluidRow(align="center", br(), actionBttn("do", "Submit", style = "material-flat")),
br(), br(),
h3(textOutput("starttext"), align="center"),
tags$head(tags$style("#starttext{color: grey20;
font-size: 20px;
font-style: plain;
}"
)
),
fluidRow(br(),
column(12, align="center",
withLoader(plotOutput("load_plot", width = "1%", height="10px"),
type="html", loader="dnaspin"),
uiOutput("test")
)
)
)
server <- function(input, output, session) {
observeEvent(input$do, {
output$test <- renderUI({
tabsetPanel(id = "something",
tabPanel(title = "Panel 1",
plotOutput("surv_nom")),
tabPanel(title = "Panel 2",
plotOutput("surv_plot"))
)
})
})
observeEvent(input[["n_sygdom"]], {
if(input[["n_sygdom"]] < 1){
disable("ecs")
disable("contra_pos")
}else{
enable("ecs")
enable("contra_pos")
}
})
rvs <- reactiveValues(n_sygdom = 0)
observeEvent(input$n_sygdom, {
if ((input$n_sygdom == 0)) {
updateRadioButtons(session, "ecs", selected = "No")
updateRadioButtons(session, "contra_pos", selected = "Contra.")
}
rvs$n_sygdom <- input$n_sygdom
})
observe(
updateSliderInput(
session = session,
inputId = "n_sygdom",
max = min(40, input$n_fjernet),
value = min(input$n_fjernet, input$n_sygdom)
)
)
reactive_nom_text <- eventReactive(input$do, {
paste0("Individualized pN-score")
})
output$nomtext <- renderText({
reactive_nom_text()
})
reactive_surv_text <- eventReactive(input$do, {
paste0("Survival probability")
})
output$survtext <- renderText({
reactive_surv_text()
})
reactive_start <- eventReactive(input$do, {
paste0("Such patient yield a pN-score of ")
})
output$starttext <- renderText({
reactive_start()
})
reactive_surv_plot <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_plot <- renderPlot({
reactive_surv_plot()
})
reactive_surv_nom <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$surv_nom <- renderPlot({
reactive_surv_nom()
})
reactive_load <- eventReactive(input$do, {
set.seed(1)
df <- data.frame(y=sample(1:17,1000, replace=TRUE), x=sample(0:100, 1000, replace=TRUE))
ggplot(df, aes(x=x, y=y))
})
output$load_plot <- renderPlot({
reactive_load()
})
}
shinyApp(ui, server)