Question

我有一个闪亮的应用程序，其中包含一个响应式ggvis图，它使用用户指定的变量和过滤器进行更新，就像这里看到的闪亮应用程序一样：

http://shiny.rstudio.com/gallery/movie-explorer.html

我有一个包含大约130个人名的列，当我要求显示填充的图例反映这些名称时，它会列出数据框中的每个名称，即使该名称已被过滤掉但未显示在情节中。即使只有5个人没有被过滤掉，这也会在图例中产生巨大的名称列表。图例会根据填充的性别自动更新，我不知道为什么会像我想要的那样自动更新而名称不会。您可以提供的任何帮助表示赞赏。我提供了一个简化的代码，用于复制虹膜数据框的问题，以及仅显示图上的setosa数据的屏幕截图，但所有三个物种仍然在图例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)
}

Answer 1

正如aosmith指出的那样，我的解决方案是在制作过滤数据集时使用droplevels函数。

m <- droplevels(as.data.frame(m))

图例仅显示绘图内容

1 个答案: