Category partition in Shiny: R

r dataframe shiny categories

71 观看

1回复

57 作者的声誉

I would like to improve a Shiny application that already appeared in this forum. I would like to achieve such an effect that, for example, by choosing Category1 "a", the category "a, b" was also shown. Similarly, when selecting the "c" Category1, all other categories containing "c" should be visible, in this case "c, b".

Code:

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)

Expected effect:

enter image description here

Changed version:

enter image description here

I would like the abc not to show up in bc.

作者: Kim 的来源 发布者: 2017 年 12 月 27 日

回应 1


1

4873 作者的声誉

决定

One way to do that is using grepl and sapply. You could use:

slt <- sapply(X = data.sel$Category1, FUN = grepl, pattern = input$cat1 ) So you would get all the rows in catergory 1 that has the string.

In your code it would be something like this:

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()

      })
    })
  }

With this modification your output would look like thisenter image description here

Hope it helps!

EDIT1:

Since comma separated words was you actually wanted I guess this approach would maybe help you.

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: Here is the full code:

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()

      })
    })
  }
作者: SBista 发布者: 2017 年 12 月 28 日
32x32