传单中用户输入的突出显示标记 - R Shiny答案

【问题标题】：Highlight marker from user input in leaflet - R Shiny传单中用户输入的突出显示标记 - R Shiny
【发布时间】：2021-08-26 18:17:13
【问题描述】：

我正在尝试根据用户输入滑块突出显示地图中的点。如果该点在某个日期范围内，则更改颜色，如果不是，则默认为黑色。

#server
    shinyServer(function(input, output,session) {
   
        output$myMap <- renderLeaflet({
    
            leaflet() %>%
                addTiles()%>%
                addCircles(data=df,
                          # ~Longitude,
                          # ~Latitude,
                           group = "myMarkers",
                          label = ~htmlEscape(date))
        })
        
        observeEvent(input$selectVariable, {
        mydat$col_format<- ifelse(mydat$Date >= input$falltime[1] & mydat$Date <= input$falltime [2],'blue', 
    ifelse(mydat$Date >= input$springtime[1] & mydat$Date <= input$springtime [2], 'black',
    ifelse (mydat$Date, 'yellow')) )

            leafletProxy("myMap") %>%
                clearGroup("myMarkers") %>%
                addCircles(data = df[df$AnimlID == input$selectVariable, ],
                           #~ mydat$Longitd ,
                           #~ mydat$Latitud,
                           group = "myMarkers",
                           col = mydat$col_format,
                           label = ~htmlEscape(date)
                         )
        })
    })

#ui shinyUI(dashboardPage(#skin = "black",
    dashboardHeader(title = "Mapping Test", titleWidth = 350
),
    dashboardSidebar(width = 350,
        selectInput("selectVariable", label = h4("Select an D:"),
                                             choices =  unique(df$id)),
                   
                                 sliderInput("falltime","NSD Fall Slider:",
                                             min = min, max = max, value = c(min, max)),
                                verbatimTextOutput("dateText"),
                                 sliderInput("springtime","NSD Spring Slider:",
                                             min = min, max = max, value = c(min, max)),
                                 actionButton("submit", ("Submit"))),
    dashboardBody(fluidPage(
           box( plotOutput("plotlraj")),
           box( leafletOutput("myMap")),
           box(DT::dataTableOutput("Table"),
)
                
        ),
    )
))

使用上面的代码，我没有收到任何错误，但地图加载速度确实很慢，而且无论滑块输入设置的日期范围是什么，这些点总是蓝色的。

我也尝试添加此反应块，但同样，即使我更改滑块日期范围，所有点都是蓝色的

    colorpal<- reactive({
    
        if(mydat$Date >= input$falltime[1] & mydat$Date <= input$falltime [2]){
            mydat[,'seasonColor']<-'#626262'
        }
        if(mydat$Date >= input$springtime[1] & mydat$Date <= input$springtime [2]){
            mydat[,'seasonColor']<-'#BAF218
'
        }

【问题讨论】：

您需要ifelse 而不是if/else 或使用case_when 因为if/else 未矢量化
我建议制作一个响应式 data.frame。它将依赖于input$selectVariable、input$falltime 和input$springtime。在反应函数中，您通过AnimlID 进行过滤，并根据falltime 和springtime 值，创建一个包含fall、spring、NA 级别的因子列。然后在该列上colorFactor()。
@rbasa 感谢您的建议。你觉得你能举个例子吗？？

标签： r shinydashboard shiny-reactivity r-leaflet

【解决方案1】：

使用quakes 以便其他人可以复制。

在filtered_df 反应函数中，根据您的喜好操作您的 data.frame。我更喜欢使用 dplyr，但我显示的是基础 R。

req() 用于确保这些输入具有值。

在传单实例化中不需要addCircles()。 observe 响应式将负责在 filtered_df() 准备好后显示圆圈，之后每次更改。

为简洁起见，仅显示服务器代码。

    output$myMap <- renderLeaflet({
        leaflet() %>%
            addTiles()
    })
    
    filtered_df <- reactive({
        req(input$depth_slider,
            input$mag_slider)
        
        filtered_df <- quakes[quakes$depth <= input$depth_slider,]
        filtered_df[filtered_df$mag <= input$mag_slider, 'Strength'] <- 'Weak'
        filtered_df[filtered_df$mag > input$mag_slider, 'Strength'] <- 'Strong'
        return(filtered_df)
    })
    
    observe({
        filtered_df <- filtered_df()
        pal <- colorFactor(c('Green', 'Red'), domain = filtered_df$Strength)
        
        leafletProxy('myMap') %>%
            clearGroup('myMarkers') %>%
            clearControls() %>%
            addCircles(
                data = filtered_df,
                lng = ~long,
                lat = ~lat,
                group = 'myMarkers',
                color = ~pal(Strength)
            ) %>%
            addLegend(
                pal = pal,
                values = filtered_df$Strength
            )
    })

【讨论】：

谢谢你的例子！效果很好。