如何禁用和启用闪亮模块中的反应性？
我正在尝试找到一种方法来禁用最近生成的输出的反应性，但启用当前正在渲染的输出的反应性。
在此示例中，我单击New开始新绘图并选择输入。然后，我New再次单击，这将在第一个图下方创建一个新图。但是，当我更改输入时，所有输出图都会发生变化。我只想改变当前的新情节。
为了解决这个问题，我想单击New禁用旧图的反应性但保持当前新图的反应性的按钮。
library(dplyr)
library(rlang)
library(ggplot2)
scatter_plot <- function(dataset, xvar, yvar) {
x <- rlang::sym(xvar)
y <- rlang::sym(yvar)
p <- ggplot(dataset, aes(x = !!x, y = !!y)) +
geom_point() +
theme(axis.title = element_text(size = rel(1.2)),
axis.text = element_text(size = rel(1.1)))
return(p)
}
regress <- function(dataset, xvar, yvar) {
# lefts <- rlang::sym(xvar)
# rights <- rlang::sym(yvar)
lefts <- xvar
rights <- yvar
lefts <- paste(lefts, " ~ ")
rights <- paste(rights, collapse = " + ")
formula <- paste(lefts, rights)
r <- summary(lm(formula, data = dataset))
return(r)
}
importUI <- function(id) {
ns <- NS(id)
tagList(
fileInput(ns("file1"), "Choose CSV File", accept = ".csv"),
checkboxInput(ns("header"), "Header", TRUE),
# tableOutput(ns("contents"))
)
}
importSE <- function(id) {
moduleServer(id,
function(input, output, session) {
dtreact <- reactive({
file <- input$file1
if (is.null(file))
return(NULL)
read.csv(file$datapath, header = input$header)
})
output$contents <- renderTable({
dtreact()
})
return(dtreact)
}
)
}
varselect_ui <- function(id) {
ns <- NS(id)
var_choices <- ""
tagList(selectInput(ns("xvar"), "Select X variable", choices = var_choices, selected = NULL),
selectInput(ns("yvar"), "Select Y variable", choices = var_choices, selected = NULL))
}
varselect_server <- function(id, dataset) {
moduleServer(id,
function(input, output, session) {
observeEvent(dataset(), {
updateSelectInput(session,
"xvar",
choices = names(dataset()))
updateSelectInput(session,
"yvar",
choices = names(dataset()))
})
return(
list(
xvar = reactive({input$xvar}),
yvar = reactive({input$yvar})
)
)
}
)
}
regselect_ui <- function(id) {
ns <- NS(id)
var_choices <- ""
tagList(selectInput(ns("xvar"), "Select X variable", choices = var_choices, selected = NULL),
selectInput(ns("yvar"), "Select Y variable", choices = var_choices, selected = NULL, multiple = TRUE))
}
regselect_server <- function(id, dataset) {
moduleServer(id,
function(input, output, session) {
observeEvent(dataset(), {
updateSelectInput(session,
"xvar",
choices = names(dataset()))
updateSelectInput(session,
"yvar",
choices = names(dataset()))
})
return(
list(
xvar = reactive({input$xvar}),
yvar = reactive({input$yvar})
)
)
}
)
}
scatterplot_ui <- function(id) {
ns <- NS(id)
plotOutput(ns("plot1"))
}
scatterplot_server <- function(id, dataset, xvar, yvar) {
moduleServer(id,
function(input, output, session) {
plot1_obj <- reactive({
req(dataset())
p <- scatter_plot(dataset(), xvar = xvar(), yvar = yvar())
return(p)
})
output$plot1 <- renderPlot({
plot1_obj()
})
}
)
}
regressUI <- function(id) {
ns <- NS(id)
verbatimTextOutput(ns("regout"))
}
regressSE <- function(id, dataset, xvar, yvar) {
moduleServer(id,
function(input, output, session) {
reg_obj <- reactive({
req(dataset())
r <- regress(dataset(), xvar = xvar(), yvar = yvar())
return(r)
})
output$regout <- renderPrint({
reg_obj()
})
})
}
ui <- fluidPage(
wellPanel(selectInput(inputId = "input1", label = NULL, choices = c(" ", "Import", "Select", "Regress"))),
sidebarLayout(
sidebarPanel(
conditionalPanel(condition = "input.input1 == 'Import'", importUI("import")),
conditionalPanel(condition = "input.input1 == 'Select'", actionButton("run1", "New"), varselect_ui("select")),
conditionalPanel(condition = "input.input1 == 'Regress'", actionButton("run2", "New "), regselect_ui("select1"))),
mainPanel(div(id = "add_here"))))
server <- function(input, output, session) {
dataset <- importSE("import")
df <- dataset
plotvars <- varselect_server("select", dataset = dataset)
plotvars2 <- regselect_server("select1", dataset = dataset)
# regressSE("regress1", dataset = df, xvar = plotvars2$xvar, yvar = plotvars2$yvar)
# output$contents <- renderTable({
# dataset()
# })
counter <- 1
observeEvent(input$run1, {
current_id <- paste0("out_", counter)
scatterplot_server(id = current_id,
dataset = df,
xvar = plotvars$xvar,
yvar = plotvars$yvar)
insertUI(selector = "#add_here",
ui = scatterplot_ui(current_id))
counter <<- counter + 1
})
observeEvent(input$run2, {
current_id <- paste0("out_", counter)
r <- regressSE(id = current_id,
dataset = df,
xvar = plotvars2$xvar,
yvar = plotvars2$yvar)
output$out <- renderPrint({
r
})
insertUI(selector = "#add_here",
ui = regressUI(current_id))
counter <<- counter + 1
})
}
shinyApp(ui, server)
如您所见，更改输入会更改所有输出。但我只希望第二个输出根据输入而改变。
您可以将当前绘图 ID 保存在reactiveVal主server函数中的 a 中，并将该无功值作为参数提供给模块。然后，模块可以将创建时获得的 ID 与当前 ID 进行比较，并仅在两个 ID 匹配时更新绘图。
整个事情的代码如下。（我只添加了几行 - 每行都用“NEW”注释突出显示。）您可以很好地概述 RStudio 文档大纲中的更改：
library(dplyr)
library(rlang)
library(ggplot2)
scatter_plot <- function(dataset, xvar, yvar) {
x <- rlang::sym(xvar)
y <- rlang::sym(yvar)
p <- ggplot(dataset, aes(x = !!x, y = !!y)) +
geom_point() +
theme(axis.title = element_text(size = rel(1.2)),
axis.text = element_text(size = rel(1.1)))
return(p)
}
regress <- function(dataset, xvar, yvar) {
# lefts <- rlang::sym(xvar)
# rights <- rlang::sym(yvar)
lefts <- xvar
rights <- yvar
lefts <- paste(lefts, " ~ ")
rights <- paste(rights, collapse = " + ")
formula <- paste(lefts, rights)
r <- summary(lm(formula, data = dataset))
return(r)
}
importUI <- function(id) {
ns <- NS(id)
tagList(
fileInput(ns("file1"), "Choose CSV File", accept = ".csv"),
checkboxInput(ns("header"), "Header", TRUE),
# tableOutput(ns("contents"))
)
}
importSE <- function(id) {
moduleServer(id,
function(input, output, session) {
dtreact <- reactive({
file <- input$file1
if (is.null(file))
return(NULL)
read.csv(file$datapath, header = input$header)
})
output$contents <- renderTable({
dtreact()
})
return(dtreact)
}
)
}
varselect_ui <- function(id) {
ns <- NS(id)
var_choices <- ""
tagList(selectInput(ns("xvar"), "Select X variable", choices = var_choices, selected = NULL),
selectInput(ns("yvar"), "Select Y variable", choices = var_choices, selected = NULL))
}
varselect_server <- function(id, dataset) {
moduleServer(id,
function(input, output, session) {
observeEvent(dataset(), {
updateSelectInput(session,
"xvar",
choices = names(dataset()))
updateSelectInput(session,
"yvar",
choices = names(dataset()))
})
return(
list(
xvar = reactive({input$xvar}),
yvar = reactive({input$yvar})
)
)
}
)
}
regselect_ui <- function(id) {
ns <- NS(id)
var_choices <- ""
tagList(selectInput(ns("xvar"), "Select X variable", choices = var_choices, selected = NULL),
selectInput(ns("yvar"), "Select Y variable", choices = var_choices, selected = NULL, multiple = TRUE))
}
regselect_server <- function(id, dataset) {
moduleServer(id,
function(input, output, session) {
observeEvent(dataset(), {
updateSelectInput(session,
"xvar",
choices = names(dataset()))
updateSelectInput(session,
"yvar",
choices = names(dataset()))
})
return(
list(
xvar = reactive({input$xvar}),
yvar = reactive({input$yvar})
)
)
}
)
}
scatterplot_ui <- function(id) {
ns <- NS(id)
plotOutput(ns("plot1"))
}
########## NEW parameter 'active_plot_id' in function##########
scatterplot_server <- function(id, dataset, xvar, yvar, active_plot_id) {
moduleServer(id,
function(input, output, session) {
plot1_obj <- reactive({
########## NEW check if IDs match##########
req(id == active_plot_id(), cancelOutput = TRUE)
req(dataset())
p <- scatter_plot(dataset(), xvar = xvar(), yvar = yvar())
return(p)
})
output$plot1 <- renderPlot({
plot1_obj()
})
}
)
}
regressUI <- function(id) {
ns <- NS(id)
verbatimTextOutput(ns("regout"))
}
regressSE <- function(id, dataset, xvar, yvar) {
moduleServer(id,
function(input, output, session) {
reg_obj <- reactive({
req(dataset())
r <- regress(dataset(), xvar = xvar(), yvar = yvar())
return(r)
})
output$regout <- renderPrint({
reg_obj()
})
})
}
ui <- fluidPage(
wellPanel(selectInput(inputId = "input1", label = NULL, choices = c(" ", "Import", "Select", "Regress"))),
sidebarLayout(
sidebarPanel(
conditionalPanel(condition = "input.input1 == 'Import'", importUI("import")),
conditionalPanel(condition = "input.input1 == 'Select'", actionButton("run1", "New"), varselect_ui("select")),
conditionalPanel(condition = "input.input1 == 'Regress'", actionButton("run2", "New "), regselect_ui("select1"))),
mainPanel(div(id = "add_here"))))
server <- function(input, output, session) {
dataset <- importSE("import")
df <- dataset
plotvars <- varselect_server("select", dataset = dataset)
plotvars2 <- regselect_server("select1", dataset = dataset)
# regressSE("regress1", dataset = df, xvar = plotvars2$xvar, yvar = plotvars2$yvar)
# output$contents <- renderTable({
# dataset()
# })
########## NEW reactive value to store current id##########
active_plot_id <- reactiveVal()
counter <- 1
observeEvent(input$run1, {
current_id <- paste0("out_", counter)
########## NEW update current ID and give reactive value to module##########
active_plot_id(current_id)
scatterplot_server(id = current_id,
dataset = df,
xvar = plotvars$xvar,
yvar = plotvars$yvar,
active_plot_id = active_plot_id)
insertUI(selector = "#add_here",
ui = scatterplot_ui(current_id))
counter <<- counter + 1
})
observeEvent(input$run2, {
current_id <- paste0("out_", counter)
r <- regressSE(id = current_id,
dataset = df,
xvar = plotvars2$xvar,
yvar = plotvars2$yvar)
output$out <- renderPrint({
r
})
insertUI(selector = "#add_here",
ui = regressUI(current_id))
counter <<- counter + 1
})
}
shinyApp(ui, server)
| 归档时间： |
|
| 查看次数： |
770 次 |
| 最近记录： |