代码：

Question

我想改进已经出现在这个论坛中的Shiny应用程序。我希望达到这样的效果，例如，通过选择Category1“ a ”，还会显示类别“ a，b ”。同样，在选择“c”类别1时，所有其他包含“ c ”的类别都应该可见，在本例中为“ c，b ”。

代码：

library(shiny)

data.input <- data.frame(
  Category1 = rep(sample(c("a,b","a","c,b","b", "c"), 45, replace = T)),
  Info = paste("Text info", 1:45),
  Category2 = sample(letters[15:20], 45, replace = T),
  Size = sample(1:100, 45),
  MoreStuff = paste("More Stuff", 1:45)
)
ui <- fluidPage(titlePanel("Test Explorer"),
                sidebarLayout(
                  sidebarPanel(
                    selectizeInput(
                      "show_vars",
                      "Columns to show:",
                      choices = colnames(data.input),  # edit
                      multiple = TRUE,
                      selected = c("Category1", "Info", "Category2")
                    ),
                    actionButton("button", "An action button"),
                    uiOutput("category1"),
                    uiOutput("category2"),
                    uiOutput("sizeslider")
                  ),
                  mainPanel(tableOutput("table"))
                ))

server <- function(input, output, session) {
  data.react <- eventReactive(input$button, {
    data.input[, input$show_vars]
  })
  observeEvent(input$button, {
    output$category1 <- renderUI({
      data.sel <- data.react()
      selectizeInput('cat1',
                     'Choose Cat 1',
                     choices = c("All", sort(as.character(
                       unique(data.sel$Category1)
                     ))),
                     selected = "All")
    })

    df_subset <- eventReactive(input$cat1, {
      data.sel <- data.react()
      if (input$cat1 == "All") {
        data.sel
      }
      else{
        data.sel[data.sel$Category1 == input$cat1,]
      }
    })

    output$category2 <- renderUI({
      selectizeInput(
        'cat2',
        'Choose Cat 2 (optional):',
        choices = sort(as.character(unique(
          df_subset()$Category2
        ))),
        multiple = TRUE,
        options = NULL
      )
    })

    df_subset1 <- reactive({
      if (is.null(input$cat2)) {
        df_subset()
      } else {
        df_subset()[df_subset()$Category2 %in% input$cat2,]
      }
    })

    output$sizeslider <- renderUI({
      sliderInput(
        "size",
        label = "Size Range",
        min = min(data.input$Size),
        max = max(data.input$Size),
        value = c(min(data.input$Size), max(data.input$Size))
      )
    })

    df_subset2 <- reactive({
      if (is.null(input$size)) {
        df_subset1()
      } else {
        df_subset1()[data.input$Size >= input$size[1] &
                       data.input$Size <= input$size[2],]
      }
    })
    output$table <- renderTable({
      df_subset2()

    })
  })
}

shinyApp(ui, server)

预期效果：

更改版本：

我希望 abc 不会出现在 bc 中。

Answer 1

一种方法是使用grepl和sapply。你可以使用：

slt <- sapply(X = data.sel$Category1, FUN = grepl, pattern = input$cat1 ) 所以你会得到catergory 1中包含字符串的所有行。

在您的代码中，它将是这样的：

server <- function(input, output, session) {
    data.react <- eventReactive(input$button, {
      data.input[, input$show_vars]
    })
    observeEvent(input$button, {
      output$category1 <- renderUI({
        data.sel <- data.react()
        selectizeInput('cat1',
                       'Choose Cat 1',
                       choices = c("All", sort(as.character(
                         unique(data.sel$Category1)
                       ))),
                       selected = "All")
      })

      df_subset <- eventReactive(input$cat1, {
        data.sel <- data.react()
        if (input$cat1 == "All") {


            data.sel
            }
            else{
###########################This part has been added#######################
                  slt <- sapply(X = data.sel$Category1, FUN = grepl, pattern = input$cat1 )
                  data.sel[slt,]
##################################################################
    # data.sel[data.sel$Category1 == input$cat1,]
            }
          })

      output$category2 <- renderUI({
        selectizeInput(
          'cat2',
          'Choose Cat 2 (optional):',
          choices = sort(as.character(unique(
            df_subset()$Category2
          ))),
          multiple = TRUE,
          options = NULL
        )
      })

      df_subset1 <- reactive({
        if (is.null(input$cat2)) {
          df_subset()
        } else {
          df_subset()[df_subset()$Category2 %in% input$cat2,]
        }
      })

      output$sizeslider <- renderUI({
        sliderInput(
          "size",
          label = "Size Range",
          min = min(data.input$Size),
          max = max(data.input$Size),
          value = c(min(data.input$Size), max(data.input$Size))
        )
      })

      df_subset2 <- reactive({
        if (is.null(input$size)) {
          df_subset1()
        } else {
          df_subset1()[data.input$Size >= input$size[1] &
                         data.input$Size <= input$size[2],]
        }
      })
      output$table <- renderTable({
        df_subset2()

      })
    })
  }

通过此修改，您的输出将如下所示

希望它有所帮助！

<强> EDIT1：

由于逗号分隔的单词是你真的想要我猜这种方法可能对你有所帮助。

slt <- sapply(X= data.sel$Category1, FUN = function(x, y){
                ele1 <-  unique(unlist(strsplit(as.character(x), split = ",")))
                ele2 <-  unique(unlist(strsplit(y, split = ",")))
                if(any(ele1 == ele2))
                  return(TRUE)
                else
                  return(FALSE)

              },y=input$cat1

              )

<强> EDIT2：这是完整的代码：

server <- function(input, output, session) {
    data.react <- eventReactive(input$button, {
      data.input[, input$show_vars]
    })
    observeEvent(input$button, {
      output$category1 <- renderUI({
        data.sel <- data.react()
        selectizeInput('cat1',
                       'Choose Cat 1',
                       choices = c("All", sort(as.character(
                         unique(data.sel$Category1)
                       ))),
                       selected = "All")
      })

      df_subset <- eventReactive(input$cat1, {
        data.sel <- data.react()
        if (input$cat1 == "All") {


          data.sel
        }
        else{
          ###########################This part has been added#######################
          # slt <- sapply(X = data.sel$Category1, FUN = grepl, pattern = input$cat1 )
          slt <- sapply(X= data.sel$Category1, FUN = function(x, y){
            ele1 <-  unique(unlist(strsplit(as.character(x), split = ",")))
            ele2 <-  unique(unlist(strsplit(y, split = ",")))
            if(any(ele1 == ele2))
              return(TRUE)
            else
              return(FALSE)

          },y=input$cat1

          )
          data.sel[slt,]
          ##################################################################
          # data.sel[data.sel$Category1 == input$cat1,]
        }
      })

      output$category2 <- renderUI({
        selectizeInput(
          'cat2',
          'Choose Cat 2 (optional):',
          choices = sort(as.character(unique(
            df_subset()$Category2
          ))),
          multiple = TRUE,
          options = NULL
        )
      })

      df_subset1 <- reactive({
        if (is.null(input$cat2)) {
          df_subset()
        } else {
          df_subset()[df_subset()$Category2 %in% input$cat2,]
        }
      })

      output$sizeslider <- renderUI({
        sliderInput(
          "size",
          label = "Size Range",
          min = min(data.input$Size),
          max = max(data.input$Size),
          value = c(min(data.input$Size), max(data.input$Size))
        )
      })

      df_subset2 <- reactive({
        if (is.null(input$size)) {
          df_subset1()
        } else {
          df_subset1()[data.input$Size >= input$size[1] &
                         data.input$Size <= input$size[2],]
        }
      })
      output$table <- renderTable({
        df_subset2()

      })
    })
  }

Shiny中的类别分区：R

代码：

预期效果：

更改版本：

1 个答案: