Category partition in Shiny: R - r

Question

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:
Changed version:
I would like the abc not to show up in bc.

Answer 1

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