r - 如何在 renderUI 中重新启动 lapply 循环
问题描述
我正在尝试创建一个能够过滤非预定次数的表的闪亮代码。当用户上传不同的(新)表时,不幸的是代码中断,因为我需要以某种方式重新启动 lapply 循环,从而丢弃以前存储的列名。
我想为 Shiny 中的表创建一个非预定义的过滤选项。用户可以选择一列并过滤表,在该列中选择不同的分类变量。可以通过按“添加”按钮添加其他选择字段。
用户界面:
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- shinyUI(
pageWithSidebar(
headerPanel("testing of dynamic number of selection"),
sidebarPanel(
uiOutput("buttons")),
mainPanel(
uiOutput("drops")
,tableOutput("table")
)
))
服务器:
表 (test.csv) 自动存储在反应值中,第一个搜索字段出现 3 个按钮(添加 = 通过读取 colnames 和存储来自该列的唯一变量的多选来添加新的搜索字段。过滤功能由计算按钮激活)
server<-function(input, output, session) {
###### read in test file
values<-reactiveValues(number = 1,
upload = NULL,
input = NULL)
values$upload<-read.csv("test.csv")
#just the "add" button, in this instance it shouldn't be a uiOutput
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"), actionButton(inputId = "calc", label = "Calculate"),
actionButton(inputId = "new", label = "new table")
)
})
#pressing the add button
observeEvent(input$add, {
cat("i adding a new record\n")
values$number <- values$number + 1L })
daStuff <- function(i){
inputName<-paste0("drop", i)
inputName2<-paste0("select", i)
inputText<-if(values$number>0){input[[paste0("drop",i)]]}else{F} # previously selected value for dropdown
inputSelect <- if(values$number>1){input[[paste0("select",i)]]}else{F} # previously selected value for dropdown
fluidRow(
column(6,selectInput(inputName, inputName, c(colnames(values$upload)), selected = inputText)),
column(6,selectInput(inputName2, inputName2,
na.omit(unique(as.vector(values$upload[,input[[paste0("drop",i)]]]))),
multiple=TRUE, selectize=TRUE, selected=inputSelect)) )}
output$drops<- renderUI({
lapply(seq_len(values$number), daStuff)})
通过按下“计算”按钮,上传的表格将根据所选的唯一值进行过滤,并显示在 output$table 中
observeEvent(input$calc, {
values$input<-NULL
for (i in 1:values$number){
if(!is.null(input[[paste0("select",i)]])){
if(is.null(values$input)){
values$input<- filter(values$upload,values$upload[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
else{
values$input<- filter(values$input,values$input[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
} }
if (is.null(values$input)){values$input<-values$upload}
output$table <- renderTable({values$input})
})
我的问题是当我上传一个新表(test2.csv)时,我不知道如何删除以前存储的选择(drop* 和 select* 值)并返回一条错误消息。
observeEvent(input$new,{
values$upload<-read.csv("test2.csv")
})
}
shinyApp(ui=ui, server = server)
我想我应该以某种方式停止lapply
循环并重新启动它,因此先前存储的值将根据新的选择被替换,但我对如何实现这一点有点坚持。
解决方案
以防万一您可能仍在寻找解决方案,我想分享一些类似的并且可能适合您的需求的东西。
这observeEvent
用于所有选择输入。如果它检测到任何更改,它将更新所有输入,包括select
基于drop
.
此外,当读取一个新文件时,selectInput
fordrop
和select
被重置为第一个值。
编辑:我忘了保留selected = input[[paste0("drop",i)]]
下拉菜单(请参阅修改后的代码)。当添加新过滤器时,它现在似乎保留了这些值 - 如果这是您的想法,请告诉我。
library(shiny)
library(shinydashboard)
library(dplyr)
myDataFrame <- read.csv("test.csv")
ui <- shinyUI(
pageWithSidebar(
headerPanel("Testing of dynamic number of selection"),
sidebarPanel(
fileInput("file1", "Choose file to upload", accept = ".csv"),
uiOutput("buttons")
),
mainPanel(
uiOutput("inputs"),
tableOutput("table")
)
)
)
server <- function(input, output, session) {
myInputs <- reactiveValues(rendered = c(1))
myData <- reactive({
inFile <- input$file1
if (is.null(inFile)) {
d <- myDataFrame
} else {
d <- read.csv(inFile$datapath)
}
d
})
observeEvent(lapply(paste0("drop", myInputs$rendered), function(x) input[[x]]), {
for (i in myInputs$rendered) {
updateSelectInput(session,
paste0('select', i),
choices = myData()[input[[paste0('drop', i)]]],
selected = input[[paste0("select",i)]])
}
})
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"),
actionButton(inputId = "calc", label = "Calculate")
)
})
observeEvent(input$add, {
myInputs$rendered <- c(myInputs$rendered, max(myInputs$rendered)+1)
})
observeEvent(input$calc, {
showData <- NULL
for (i in 1:length(myInputs$rendered)) {
if(!is.null(input[[paste0("select",i)]])) {
if(is.null(showData)) {
showData <- filter(myData(), myData()[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
else {
showData <- filter(showData, showData[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
}
}
if (is.null(showData)) { showData <- myData() }
output$table <- renderTable({showData})
})
observe({
output$inputs <- renderUI({
rows <- lapply(myInputs$rendered, function(i){
fluidRow(
column(6, selectInput(paste0('drop',i),
label = "",
choices = colnames(myData()),
selected = input[[paste0("drop",i)]])),
column(6, selectInput(paste0('select',i),
label = "",
choices = myData()[1],
multiple = TRUE,
selectize = TRUE))
)
})
do.call(shiny::tagList, rows)
})
})
}
shinyApp(ui, server)
推荐阅读
- mysql - 当我将数据从 servlet 存储到 mysql 数据库时,像“<”、“>”这样的字符被存储为像 u003c 这样的 unicode 格式,而不是实际的符号
- typescript - 未找到插件“建模器”。Autorest 生成 TypeScript 代理
- python - 如何正确检索从 POST 请求接收到的 XML 数据
- postman - Postman 6.7.3 - 如何使用登录用户进行授权/NTLM 身份验证?
- java - 如何为 OAUTH Spring Boot 进行模拟测试
- http - Nativescript http post失败,没有抛出异常
- python - Holoview,更改图表的样式选项
- laravel-5 - 管理员创建用户,不希望用户在管理员使用 Laravel 的默认身份验证系统注册后自动登录
- c++ - 为什么 CoCreateInstance 可以在完全相同的上下文中返回两个不同的 HRESULT?
- css - 状态更改时如何将css文件从服务器添加到角度组件