背景

Question

背景

我有一个Shiny应用程序，它使用提供一组地图的传单。其中一些地图共享相似的元素。我想清理代码，将这些元素包装在一个函数中，我会在适当的时候调用这些元素。

可重复的示例

为了简化我在传单页面上使用示例提供的问题： Modifying Existing Maps with leafletProxy

我想利用这个包装函数在app中的地图上使这些图层可用：

# Create wrapper function adding tiles
add_map_layers <- function(map) {
    addProviderTiles(map = map, "Stamen.Toner",     group = "Toner") %>%
        addProviderTiles(map = map, "Stamen.TonerLite", group = "Toner Lite") %>%
        addProviderTiles(map = map, "CartoDB.Positron", group = "Carto") %>%
        addLayersControl(
            map = map,
            baseGroups = c("OSM (default)", "Toner", "Toner Lite", "Carto"),
            options = layersControlOptions(collapsed = FALSE)
        )
}

该功能将按以下方式添加：

observe({
    pal <- colorpal()

    leafletProxy("map", data = filteredData()) %>%
        clearShapes() %>%
        addCircles(
            radius = ~ 10 ^ mag / 10,
            weight = 1,
            color = "#777777",
            fillColor = ~ pal(mag),
            fillOpacity = 0.7,
            popup = ~ paste(mag)
        ) %>% 
        add_map_layers()
})

错误

代码会产生以下错误消息：

Warning: Error in unclass: cannot unclass an environment
Stack trace (innermost first):
    92: matchSignature
    91: getMethod
    90: existsMethod
    89: .local
    88: asJSON
    87: asJSON
    86: .local
    85: FUN
    84: FUN
    83: vapply
    82: .local
    81: asJSON
    80: asJSON
    79: .local
    78: FUN
    77: FUN
    76: vapply
    75: .local
    74: FUN
    73: FUN
    72: vapply
    71: .local
    70: FUN
    69: FUN
    68: vapply
    67: .local
    66: FUN
    65: FUN
    64: vapply
    63: .local
    62: FUN
    61: FUN
    60: vapply
    59: .local
    58: FUN
    57: FUN
    56: vapply
    55: .local
    54: asJSON
    53: asJSON
    52: .local
    51: asJSON
    50: asJSON
    49: jsonlite::toJSON
    48: toJSON
    47: private$websocket$send
    46: private$write
    45: private$sendMessage
    44: sess$sendCustomMessage
    43: flushedCallback
    42: callback
     1: shiny::runApp

问题

如何为常用元素开发包装函数，以便将其包含在传单管道中？目标只是最小化应用程序中重复的代码量。
该函数只能接受并返回map对象，因此我可以开发管道：
```
leaflet() %>%
wrapper_function() %>%
other_leaflet_function() 
```

完整示例

为方便复制粘贴，我已包含完整代码。如上所述，与官方示例的唯一区别是包装函数add_map_layers尝试将地图图层添加到传单对象。

library(shiny)
library(leaflet)
library(RColorBrewer)

ui <- bootstrapPage(
    tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
    leafletOutput("map", width = "100%", height = "100%"),
    absolutePanel(
        top = 10,
        right = 10,
        sliderInput(
            "range",
            "Magnitudes",
            min(quakes$mag),
            max(quakes$mag),
            value = range(quakes$mag),
            step = 0.1
        ),
        selectInput("colors", "Color Scheme",
                    rownames(subset(
                        brewer.pal.info, category %in% c("seq", "div")
                    ))),
        checkboxInput("legend", "Show legend", TRUE)
    )
)

server <- function(input, output, session) {
    # Create wrapper function adding tiles
    add_map_layers <- function(map) {
        addProviderTiles(map = map, "Stamen.Toner",     group = "Toner") %>%
            addProviderTiles(map = map, "Stamen.TonerLite", group = "Toner Lite") %>%
            addProviderTiles(map = map, "CartoDB.Positron", group = "Carto") %>%
            addLayersControl(
                map = map,
                baseGroups = c("OSM (default)", "Toner", "Toner Lite", "Carto"),
                options = layersControlOptions(collapsed = FALSE)
            )
    }

    # Reactive expression for the data subsetted to what the user selected
    filteredData <- reactive({
        quakes[quakes$mag >= input$range[1] & quakes$mag <= input$range[2], ]
    })

    # This reactive expression represents the palette function,
    # which changes as the user makes selections in UI.
    colorpal <- reactive({
        colorNumeric(input$colors, quakes$mag)
    })

    output$map <- renderLeaflet({
        # Use leaflet() here, and only include aspects of the map that
        # won't need to change dynamically (at least, not unless the
        # entire map is being torn down and recreated).
        leaflet(quakes) %>% addTiles() %>%
            fitBounds( ~ min(long), ~ min(lat), ~ max(long), ~ max(lat))
    })

    # Incremental changes to the map (in this case, replacing the
    # circles when a new color is chosen) should be performed in
    # an observer. Each independent set of things that can change
    # should be managed in its own observer.
    observe({
        pal <- colorpal()

        leafletProxy("map", data = filteredData()) %>%
            clearShapes() %>%
            addCircles(
                radius = ~ 10 ^ mag / 10,
                weight = 1,
                color = "#777777",
                fillColor = ~ pal(mag),
                fillOpacity = 0.7,
                popup = ~ paste(mag)
            ) %>% 
            add_map_layers()
    })

    # Use a separate observer to recreate the legend as needed.
    observe({
        proxy <- leafletProxy("map", data = quakes)

        # Remove any existing legend, and only if the legend is
        # enabled, create a new one.
        proxy %>% clearControls()
        if (input$legend) {
            pal <- colorpal()
            proxy %>% addLegend(position = "bottomright",
                                pal = pal,
                                values = ~ mag)
        }
    })
}

shinyApp(ui, server)

Answer 1

正确的语法：

add_map_layers <- function(map) {
    map %>% 
    addProviderTiles("Stamen.Toner",     group = "Toner") %>%
        addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>%
        addProviderTiles("CartoDB.Positron", group = "Carto") %>%
        addLayersControl(
            baseGroups = c("OSM (default)", "Toner", "Toner Lite", "Carto"),
            options = layersControlOptions(collapsed = FALSE)
        )
}

使用Shiny

背景

可重复的示例

错误

问题

完整示例

1 个答案: