Show data points only for selected date on a slider via Leaflet

Question

I have created a Timeseries visualization map application that updates data points on Leaflet with the progression of the time series animation.

Now I am trying to add another functionality where when the user selects a particular week from the time series, the map will just show the points for that date only. One way I am thinking to do this would be add the ability to define a range with two toggles, so when the user drags the start and end toggle to the same week, the maps will just show the data points for that week. Or maybe there is a better way of doing it.

How can a leaftet be created such that not only does it show the whole data points for the entire time series like an animation (the current code does this), but also have the ability to show only data points for selected date on the slider?

Code:

# This is a Shiny time series map web application
library(shiny)
library(tidyverse)
library(tidyr)
library(leaflet)
library(xts)


xts_to_tibble <- function(xts_obj) {
  data.frame(index(xts_obj), coredata(xts_obj)) %>%
    set_names(c("date", names(xts_obj))) %>%
    as_tibble()
}

# Create sample data
Date <- c(
  "2014-04-08", "2014-06-04", "2014-04-30",
  "2014-05-30", "2014-05-01"
)
lat <- as.numeric(c(
  "45.53814", "45.51076", "45.43560", "45.54332",
  "45.52234"
))
lon <- as.numeric(c(
  "-73.63672", "-73.61029", "-73.60100",
  "-73.56000 ", "-73.59022"
))
id <- as.numeric(c("1", "2", "3", "4", "5"))

# Create a df from the above columns
df <- data.frame(id, lat, lon, Date)
df$Year <- lubridate::year(df$Date)
df$Month <- lubridate::month(df$Date, label = TRUE, abbr = FALSE)
df$Week <- lubridate::week(df$Date)
df$Date <- as.Date(df$Date)
ui <- fluidPage(

  # Title
  titlePanel("Time Series Visiualization Map"),
  sidebarLayout(

    # Define the sidebar
    sidebarPanel(
      radioButtons(
        inputId = "Frequency",
        label = " Select Timer Series Frequency",
        choices = c(
          "weeks",
          "months",
          "years"
        ),
        selected = "weeks",
        inline = T
      ),
      uiOutput("Time_Series_UI")
    ),
    mainPanel(
      leafletOutput("Time_Series_Map")
    ),
  )
)



# Define server logic required to draw a histogram
server <- function(input, output) {

  # Render slider input depending on data frequency

  observe({
    # Create an xts object
    df_xts <- xts(df, order.by = as.Date(df$Date))

    # All_Dates = unique(df$Start_Date)

    Filtered_Dates <- df_xts[xts::endpoints(
      df_xts,
      on = input$Frequency
    )] %>% xts_to_tibble()

    output$Time_Series_UI <- renderUI({
      sliderInput("Date", "Date:",
        min = pull(slice_min(Filtered_Dates, date), date),
        max = pull(slice_max(Filtered_Dates, date), date),
        value = pull(slice_min(Filtered_Dates, date), date),
        step = 1,
        timeFormat = "%YYYY-%MM-%DD",
        animate = T
      )
    })
  })

  # Filter data for the date selected
  Filtered_Data <- reactive({
    req(input$Date)
    filter(df, Date == input$Date)
  })


  # Create the leaflet map
  output$Time_Series_Map <- renderLeaflet({
    leaflet(df) %>%
      addTiles() %>%
      setView(lat = 0, lng = 0, zoom = 2)
  })

  # Create data markers for selected date
  observe({
    # print(input$Date)

    leafletProxy("Time_Series_Map", data = Filtered_Data()) %>%
      addCircleMarkers(
        lng = ~lon, lat = ~lat,
        popup = ~id
      )
  })
}

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

Answer 1

I think the answer is not too difficult in this case currently your last observer looks like this:

  observe({
    # print(input$Date)
    
    leafletProxy("Time_Series_Map", data = Filtered_Data())     %>%
      addCircleMarkers(
        lng = ~lon, lat = ~lat,
        popup = ~id
      )
  })

This observer every time adds markers in Filtered_Data() however markers are never removed. By using a group and clearing that group you old markers are removed each time:

  observe({
    leafletProxy("Time_Series_Map", data = Filtered_Data())     %>%
      clearGroup("points") %>%
      addCircleMarkers(group='points',
        lng = ~lon, lat = ~lat,
        popup = ~id
      )
  })