I have a shiny app with a reactive ggvis plot that updates with user specified variables and filters much like the shiny app seen here:
http://shiny.rstudio.com/gallery/movie-explorer.html
I have a column that contains about 130 names of people, and when I ask the legend displaying the fill to reflect those names, it lists every name in the data frame even if that name has been filtered out and is not being displayed in the plot. This results in a huge list of names in the legend even when there are only 5 people who haven't been filtered out. The legend does automatically update based on gender for fill, and I have no idea why that would auto update like I want it to and the names do not. Any help you can provide is appreciated. I have provided a simplified code that replicates the issue for the iris data frame as well as a screenshot showing only the setosa data on the plot, but all three species still on the legend screenshot of issue.
#Check packages to use in library
{
library('shiny') #allows for the shiny app to be used
library('RODBC') #allows for data to be loaded from the database
library('stringr') #string opperator
library('ggvis') #allows for interactive ploting
library('dplyr')
library('RSQLite')
}
alldata <- iris
#adds a column of a unique ID for each row
alldata$ID <- 1:nrow(alldata)
#establish options for drop down menus & Variable fixes
{
specieschoices <- unique(as.character(alldata$Species))
petalwchoices <- unique(as.character(alldata$Petal.Width))
petallchoices <- unique(as.character(alldata$Petal.Length))
sepallchoices <- unique(as.character(alldata$Sepal.Length))
sepalwchoices <- unique(as.character(alldata$Sepal.Width))
}
# UI
ui<-fluidPage(
titlePanel("Explorer"),
fluidRow(
column(4,
wellPanel(
h4("Apply Filters"),
selectInput(inputId = "species", label="Select a Species:", choices = c("All Species", sort(specieschoices)), selected="setosa", multiple = TRUE, selectize = TRUE),
selectInput(inputId = "petalw", label="Select Petal Width:", choices = c("All", sort(petalwchoices)), selected="All", multiple = TRUE, selectize = FALSE),
selectInput(inputId = "petall", label="Select Petal Length", choices = c("All", petallchoices), selected="All", multiple = TRUE, selectize = FALSE),
selectInput(inputId = "sepall", label="Select Sepal Length", choices = c("All",sort(sepallchoices)), selected="All", multiple = TRUE, selectize = FALSE),
selectInput(inputId = "sepalw", label="Select Sepal Width", choices = c("All",sort(sepalwchoices)), selected="All", multiple = TRUE, selectize = FALSE)
)),
column(8,
ggvisOutput("plot1")
),
column(4,
wellPanel(
h4("Data Variables"),
selectInput(inputId = "x", label="Select x-axis Variable:", choices=as.character(names(alldata[,1:4])),selected='Pedal.Length', multiple = FALSE),
selectInput(inputId = "y", label="Select y-axis Variable:", choices=as.character(names(alldata[,1:4])),selected='Pedal.Width', multiple = FALSE)
)),
column(4,
wellPanel(
h4("Data Visualization"),
selectInput(inputId = "fill", label="Select Filter for Data Point Fill", choices=as.character(c("All Points Black", "Species", "Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")), selected = 'Species', multiple = FALSE)
))
))
#SERVER
server<-function(input,output,session)
{
#Set up select all for all aplicable inputs
{
# Species
{
observe({
if("All Species" %in% input$species) {
#choose all the choices _except_ "All Tests"
selected_choices1 <- setdiff(specieschoices, "All Species")
updateSelectInput(session, "species", selected = selected_choices1)
}
})
output$selected <- renderText({
paste(input$myselect1, collapse=",")
})
}
# Pedal Width
{
observe({
if("All" %in% input$petalw) {
#choose all the choices _except_ "All"
selected_choices2 <- setdiff(petalwchoices, "All")
updateSelectInput(session, "petalw", selected = selected_choices2)
}
})
output$selected <- renderText({
paste(input$myselect2, collapse=",")
})
}
# Pedal Length
{
observe({
if("All" %in% input$petall) {
#choose all the choices _except_ "All"
selected_choices3 <- setdiff(petallchoices, "All")
updateSelectInput(session, "petall", selected = selected_choices3)
}
})
output$selected <- renderText({
paste(input$myselect3, collapse=",")
})
}
# Sepal Length
{
observe({
if("All" %in% input$sepall) {
#choose all the choices _except_ "All"
selected_choices4 <- setdiff(sepallchoices, "All")
updateSelectInput(session, "sepall", selected = selected_choices4)
}
})
output$selected <- renderText({
paste(input$myselect4, collapse=",")
})
}
# Sepal Width
{
observe({
if("All" %in% input$sepalw) {
#choose all the choices _except_ "All"
selected_choices5 <- setdiff(sepalwchoices, "All")
updateSelectInput(session, "sepalw", selected = selected_choices5)
}
})
output$selected <- renderText({
paste(input$myselect5, collapse=",")
})
}
}
#Set up reactive variables
filteredData <- reactive({
# Apply filters
m <- alldata %>% filter(
`Species` %in% input$species,
`Petal.Width` %in% input$petalw,
`Petal.Length` %in% input$petall,
`Sepal.Width` %in% input$sepalw,
`Sepal.Length` %in% input$sepall
)
m <- as.data.frame(m)
m
})
# Function for generating tooltip text
my_tooltip <- function(tt) {
if (is.null(tt)) return(NULL)
if (is.null(tt$ID)) return(NULL)
# Pick out the shot with this ID
alldata <- isolate(filteredData())
Datapoint <- alldata[alldata$ID == tt$ID, ]
paste0("<b>", "Species: ", Datapoint$`Species`,
"</b><br>", "ID: ", Datapoint$`ID`
)
}
vis <- reactive({
# Allows for points to be consistent if the user desires
if (input$fill == "All Points Black") {
fillvar = "black"}
else {
fillvar <- as.symbol(input$fill)
}
#Plot Data with Visualization Customization
xvar <- prop("x", as.symbol(input$x))
yvar <- prop("y", as.symbol(input$y))
filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
prop("fill", fillvar),
key := ~ID
) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 450, duration = 0)
})
#Actually plots the data
vis %>% bind_shiny("plot1")
}
#Run the Shiny App to Display Webpage
{
shinyApp(ui=ui, server=server)
}
as aosmith pointed out, my solution was to use the droplevels function when making the filtered dataset.
m <- droplevels(as.data.frame(m))