Question

我有以下Web应用程序示例：

library(shiny)

ui <- shinyUI(pageWithSidebar(
  headerPanel("Add Features"),
  sidebarPanel(width=4,
               fluidRow(column(12,
                               h3('Features'),
                               uiOutput('uiOutpt')
               )), # END fluidRow
               fluidRow(
                 column(4,div()),
                 column(4,actionButton("add", "Add!")),
                 column(4,actionButton("remove", "Remove!")),
                 column(4,actionButton('goButton',"Analyze"))
               ) # END fluidRow
  ), # END sidebarPanel
  mainPanel(
    textOutput("text2"),
    tableOutput('tbl')
  )
))

server <- shinyServer(function(input, output) {
  features <- reactiveValues(renderd=c(1),
                             conv=c(50),
                             inlabels=c('A'),
                             outlabels=c('B'))

  df <- eventReactive(input$goButton, {
    out <- lapply(features$renderd,function(i){
      fv <- paste0('numInp_',i)
      vn <- paste0('InLabel',i)
      data.frame(Variable=input[[vn]], Value=input[[fv]] )
    })
    do.call(rbind,out)
  })

  output$nText <- renderText({
    ntext()
  })
  output$text2 <- renderText({ 
    paste(sprintf("You have selected feature: %s", paste(features$renderd,collapse=", ")))
  })

  output$tbl <- renderTable({
    df()
  })

  # Increment reactive values array used to store how may rows we have rendered
  observeEvent(input$add,{
    out <- lapply(features$renderd,function(i){
      fv <- paste0('numInp_',i)
      vn <- paste0('InLabel',i)
      vo <- paste0('OutLabel',i)
      data.frame(inlabels=input[[vn]],outlabels=input[[vo]], conv=input[[fv]] )
    })
    df<-do.call(rbind,out)
    print(df)
    features$inlabels <- c(as.character(df$inlabels),' ')
    features$outlabels <- c(as.character(df$outlabels),' ')
    print(c(features$inlabels,features$outlabels))

    features$renderd <- c(features$renderd, length(features$renderd)+1)
    print(features$renderd)
    print(names(features))
    features$conv<-c(df$conv,51-length(features$renderd))
  })

  observeEvent(input$remove,{
    features$renderd <- features$renderd[-length(features$renderd)]
  })

  # If reactive vector updated we render the UI again
  observe({
    output$uiOutpt <- renderUI({
      # Create rows
      rows <- lapply(features$renderd,function(i){
        fluidRow(
          # duplicate choices make selectize poop the bed, use unique():
          column(4,  selectizeInput(paste0('InLabel',i), 
                                 label = 'Input Name',selected=features$inlabels[i-1],
                                 choices=unique(c(features$inlabels[i-1],features$outlabels[!features$outlabels %in% features$inlabels])),
                                 options = list(create = TRUE))),
          column(4,  sliderInput(paste0('numInp_',i), label="Conversion",min = 0, max = 100, value = features$conv[i-1])),
          column(4, selectizeInput(paste0('OutLabel',i), 
                                label = "Output Name", selected=features$outlabels[i-1],
                                choices=unique(c(features$inlabels,features$outlabels)),
                                options = list(create = TRUE)))
        )
      })
      do.call(shiny::tagList,rows)
    })
  })
})

shinyApp(ui=ui,server=server)

问题在于，每当我们通过点击按钮添加新的fluidRow时，添加＆＃34;，刷新前一个fluidRow中的选定值。我想改变这一点。如果我选择了例如inputName =＆＃39; B＆＃39;，Conversion = 50，outputName =＆＃39; A＆＃39;，我希望它们在我添加或删除行时保持不变。

我试过了，但它没有用：

library(shiny)

ui <- shinyUI(pageWithSidebar(
  headerPanel("Add Features"),
  sidebarPanel(width=4,
               fluidRow(column(12,
                               h3('Features'),
                               uiOutput('uiOutpt')
               )), # END fluidRow
               fluidRow(
                 column(4,div()),
                 column(4,actionButton("add", "Add!")),
                 column(4,actionButton("remove", "Remove!")),
                 column(4,actionButton('goButton',"Analyze"))
               ) # END fluidRow
  ), # END sidebarPanel
  mainPanel(
    textOutput("text2"),
    tableOutput('tbl')
  )
))

server <- shinyServer(function(input, output) {
  features <- reactiveValues(renderd=c(1),
                             conv=c(50),
                             inlabels=c('A'),
                             outlabels=c('B'))

  df <- eventReactive(input$goButton, {
    out <- lapply(features$renderd,function(i){
      fv <- paste0('numInp_',i)
      vn <- paste0('InLabel',i)
      data.frame(Variable=input[[vn]], Value=input[[fv]] )
    })
    do.call(rbind,out)
  })

  output$nText <- renderText({
    ntext()
  })
  output$text2 <- renderText({ 
    paste(sprintf("You have selected feature: %s", paste(features$renderd,collapse=", ")))
  })

  output$tbl <- renderTable({
    df()
  })

  # Increment reactive values array used to store how may rows we have rendered
  observeEvent(input$add,{
    out <- lapply(features$renderd,function(i){
      fv <- paste0('numInp_',i)
      vn <- paste0('InLabel',i)
      vo <- paste0('OutLabel',i)
      data.frame(inlabels=input[[vn]],outlabels=input[[vo]], conv=input[[fv]] )
    })
    df<-do.call(rbind,out)
    print(df)
    features$inlabels <- c(as.character(df$inlabels),' ')
    features$outlabels <- c(as.character(df$outlabels),' ')
    print(c(features$inlabels,features$outlabels))

    features$renderd <- c(features$renderd, length(features$renderd)+1)
    print(features$renderd)
    print(names(features))
    features$conv<-c(df$conv,51-length(features$renderd))
  })

  observeEvent(input$remove,{
    features$renderd <- features$renderd[-length(features$renderd)]
  })

  # If reactive vector updated we render the UI again
  observe({
    output$uiOutpt <- renderUI({
      # Create rows
      rows <- lapply(features$renderd,function(i){
        fluidRow(
          # duplicate choices make selectize poop the bed, use unique():
          column(4,  selectizeInput(paste0('InLabel',i), 
                                 label = 'Input Name',selected=features$inlabels[i],
                                 choices=c('A','B','C'),
                                 options = list(create = TRUE))),
          column(4,  sliderInput(paste0('numInp_',i), label="Conversion",min = 0, max = 100, value = features$conv[i])),
          column(4, selectizeInput(paste0('OutLabel',i), 
                                label = "Output Name", selected=features$outlabels[i],
                                choices=c('A','B','C'),
                                options = list(create = TRUE)))
        )
      })
      do.call(shiny::tagList,rows)
    })
  })
})

shinyApp(ui=ui,server=server)

我确信很容易搞清楚，但我不知道。

感谢您的回复。

Answer 1

我找到了问题的答案。我认为这可能对某些人有用，这就是为什么我发布下面的例子：

library(shiny)

ui <- shinyUI(
  fluidPage(

    actionButton("addFilter", "Add filter", icon=icon("plus", class=NULL, lib="font-awesome")),

    uiOutput("filterPage1")
  )
)

server <- function(input, output){
  i <- 0

  observeEvent(input$addFilter, {
    i <<- i + 1
    output[[paste("filterPage",i,sep="")]] = renderUI({
      list(
        fluidPage(
          fluidRow(
            column(6, selectInput(paste("filteringFactor",i,sep=""), "Choose factor to filter by:",
                                choices=c("factor A", "factor B", "factor C"), selected="factor B",
                                width="100%")),
            column(6, actionButton(paste("removeFactor",i,sep=""), "",
                                 icon=icon("times", class = NULL, lib = "font-awesome"),
                                 onclick = paste0("Shiny.onInputChange('remove', ", i, ")")))
          )
        ),
        uiOutput(paste("filterPage",i + 1,sep=""))
      )
    })
  })

  observeEvent(input$remove, {
    i <- input$remove

    output[[paste("filterPage",i,sep="")]] <- renderUI({uiOutput(paste("filterPage",i + 1,sep=""))})
  })
}

shinyApp(ui, server)

度过愉快的一天。

添加/删除闪亮的Web应用程序中的字段而不更改选项

1 个答案: