无法按日期过滤闪亮

Question

简单的问题，但没有一个答案对我有用。我用谷歌搜索了很多，但仍然很挣扎。

我正在尝试按日期过滤传单地图上的事件。

# Install packages
library(shiny)
library(shinydashboard)
library(tidyverse)
library(leaflet)
library(shinythemes)
library(knitr)
library(kableExtra)
library(RColorBrewer)
library(Hmisc)


# Read the initial file
incidents <- read.csv("Crime Incidents in 2017.csv", header = TRUE, 
stringsAsFactors = FALSE)

# Clean date format
incidents$Report.date <- as.Date(incidents$Report.date, format = "%Y-%m-%d")
class(incidents$Report.date)

# Define function for legend
addLegendCustom <- function(map, colors, labels, sizes, opacity = 0.5, ...){
colorAdditions <- paste0(colors, "; width:", sizes, "px; height:", sizes, 
"px")
labelAdditions <- paste0("<div style='display: inline-block;height: ", 
                       sizes, "px;margin-top: 4px;line-height: ", sizes, 
"px;'>", labels, "</div>")

return(addLegend(map, colors = colorAdditions, labels = labelAdditions, 
opacity = opacity, ...))
}

# User interface
ui <- fluidPage(theme = shinytheme("united"),
            titlePanel(HTML("<h1><center><font size=14> Crimes in 
Washington, DC (2017) </font></center></h1>")),
            # titlePanel("Crimes in Washington, DC (2017)", align = 
"center"), 
            fluidRow(column(4, align="center", 
                            selectInput("offenceInput", "Type of Offence",
                                        choices = sort(unique(incidents$Offense)),
                                        selected = sort(unique(incidents$Offense)),
                                        multiple = TRUE),
                            selectInput("methodInput", "Method of Offence",
                                        choices = sort(unique(incidents$Method)),
                                        selected = sort(unique(incidents$Method)),
                                        multiple = TRUE),
                            selectInput("shiftInput", "Police Shift",
                                        choices = sort(unique(incidents$Shift)),
                                        selected = sort(unique(incidents$Shift)),
                                        multiple = TRUE),
                            selectInput('background', 'Background',
                                        choices = providers,
                                        multiple = FALSE,
                                        selected = 'Stamen.TonerLite'),
                            dateRangeInput('daterangeInput',
                                             label = 'Date',
                                             start = as.Date('2017-01-01') , end = as.Date('2017-12-31')
                              )
            ),


            column(8,
                   leafletOutput(outputId = 'map', height = 600, width = 800),

                   column(12,
                          dataTableOutput('selected_date')
            )
            )

)) #)

# SERVER
server <- function(input, output, session) {  

# Filter the data based on inputs
filtered_data <- reactive({
selected_offence <- input$offenceInput
selected_method <- input$methodInput
selected_shift <- input$shiftInput
selected_date <- input$daterangeInput

out <- incidents

# Offense filtering

if(!is.null(selected_offence)){
  if(!all(selected_offence == '')){
    message('Keeping the following offences:')
    message(paste0('---', selected_offence, '\n', collapse = ''))
    out <- out %>%
      filter(Offense %in% selected_offence)
  }

}

# Method filtering filtering
if(!is.null(selected_method)){
  if(!all(selected_method == '')){
    message('Keeping the following methods:')
    message(paste0('---', selected_method, '\n', collapse = ''))
    out <- out %>%
      filter(Method %in% selected_method)
  }
}

# Shift filtering 
if(!is.null(selected_shift)){
  if(!all(selected_shift == '')){
    message('Keeping the following shifts:')
    message(paste0('---', selected_shift, '\n', collapse = ''))
    out <- out %>%
      filter(Shift %in% selected_shift)
  }
}

# Date filtering 
if(!is.null(selected_date)){
if(!all(selected_date == '')){
message('Keeping the following dates:')
message(paste0('---', selected_date, '\n', collapse = ''))
out <- out %>%
filter(Report.date %in% selected_date)
}
}

return(out)
})

output$map <- renderLeaflet({


# Get the filtered data first
df <- filtered_data()

# If there is any data, carry on
if(nrow(df) > 0){

  l <- 
    leaflet(data = df) %>% 
    addProviderTiles(input$background) %>% 
    setView(-77.0369, 38.9072, zoom = 12)

  message(nrow(df), ' crimes filtered.')

  # Define a color vector
  color_vector <- colorRampPalette(RColorBrewer::brewer.pal(n = 9, name = 'Paired'))(length(unique(df$Offense)))
  color_labels <- sort(unique(df$Offense))
  pal <- colorFactor(
    color_vector,
    domain = color_labels)

  l <- l %>%
    addCircles(lng = df$Lon, lat = df$Lat, weight = 1,
               popup = paste0(df$Offense, ' at ', df$Block),
               color = ~pal(df$Offense),
               radius = 20, opacity = 0.9) %>%
    addLegendCustom(colors = color_vector, 
                    labels = color_labels, sizes = rep(20, length(color_vector)),
                    position = 'bottomright',
                    opacity = 0.9,
                    title = 'Offense type')

} else {
  message('No crimes with current filter settings.')
  l <- l <- 
    leaflet() %>% 
    addProviderTiles(input$background) %>% 
    setView(-77.0369, 38.9072, zoom = 12)
}
return(l)
})


}

# Run the application 
shinyApp(ui = ui, server = server)

结果我收到了这个常见错误

Warning: Error in charToDate: character string is not in a standard unambiguous format

我的假设是我需要将我的约会对象作为角色，但到目前为止，多项努力都失败了。

非常感谢

数据在这里dropbox

奥莱克斯

Answer 1

您只需为第二个 selected_date 添加as.character()，如下所示。由于 selected_date 是日期格式，因此 selected_date=='' 会向您抛出错误消息。 （如果你运行as.Date('2017-01-01') == ""，你会得到同样的错误信息。）

# Date filtering 
 if(!is.null(selected_date)){
   if(!all(as.character(selected_date) == '')){
     message('Keeping the following dates:')
     message(paste0('---', selected_date, '\n', collapse = ''))
     out <- out %>%
       filter(Report.date %in% selected_date)
   }
 }

顺便说一句，很酷的应用程序！