Question

我正在尝试撤消R中leaflet图例的值显示。此post涵盖了分类数据，但我正在使用连续数据。这是一个玩具示例：

map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')
x <- 1:100
pal <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x)
map %>% addLegend('topright', pal=pal, values=x)

我希望图例在顶部读取100，在底部读取1，颜色反转。我当然可以在colorNumeric()中反转颜色，但是反转标签的顺序会更难。我已经尝试颠倒x中值的顺序，我甚至摆弄labelFormat()的{{1}}参数来引用反转值的查找表......似乎没有任何效果。有一个简单的方法吗？

Answer 1

我刚发现内置的labelFormat函数有一个transform参数，它接受一个函数。所以我在那里传递了sort函数。要使用相同的示例，

map %>% addLegend('topright',
              pal = pal, 
              values = x, 
              labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)))

Answer 2

更新

使用杰克的the answer。这个应该不再是被接受的＆＃39;之一。

我有一种感觉，这是一种更简单的方法。但是，使用my solution from this other question，您可以创建自己的标签格式并使用

但是，您可能希望在剪切超过100

时使用剪切

library(leaflet)

map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')

x <- 1:100
## I've reversed the order of the colours too
pal <- colorNumeric(rev(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6")), x)

## custom label format function
myLabelFormat = function(..., reverse_order = FALSE){ 
    if(reverse_order){ 
        function(type = "numeric", cuts){ 
            cuts <- sort(cuts, decreasing = T)
        } 
    }else{
        labelFormat(...)
    }
}

map %>% addLegend('topright',
                  pal = pal, 
                  values = x, 
                  labFormat = myLabelFormat(reverse_order = T))

Answer 3

不幸的是，对此的公认答案将使数字与它们代表的颜色不一致（实际上完全相反）。

这是最初提出的解决方案，我说这是不正确的：

map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')
x <- 1:100
pal <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x)
map %>% addLegend('topright', pal=pal, values=x)

# This solution shows 100 as red
map %>% addLegend('topright',
                  pal = pal, 
                  values = x, 
                  labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)))

但是，如果您一直使用pal()函数在地图上绘制任何内容，那么现在您就完全错了。

# But 100 is blue, not red
plot(1, 1, pch = 19, cex = 3, col = pal(100))

我认为解决方案是将函数定义为将颜色分配给数字，一种用于图例相反，一种用于实际绘制事物：

pal_rev <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x, reverse = TRUE)

map %>% addLegend('topright',
                  pal = pal_rev, 
                  values = x, 
                  labFormat = labelFormat(transform = function(x) sort(x, decreasing = TRUE)))

这为我们提供了一个与我们将要绘制的内容相匹配的图例，即100现在可以正确显示为蓝色：

Answer 4

虽然接受的答案确实翻转了图例的颜色和标签，但地图的颜色并不适合图例。这是一个（从 here 窃取的）解决方案。基本上，mpriem89 创建了一个名为 addLegend_decreasing 的新函数，它的工作方式与 addLegend 完全一样，但有一个额外的参数：decreasing = FALSE 反转图例的颜色和标签，正确地处理地图的颜色。下面是函数代码：

    addLegend_decreasing <- function (map, position = c("topright", "bottomright", "bottomleft","topleft"),
                                  pal, values, na.label = "NA", bins = 7, colors, 
                                  opacity = 0.5, labels = NULL, labFormat = labelFormat(), 
                                  title = NULL, className = "info legend", layerId = NULL, 
                                  group = NULL, data = getMapData(map), decreasing = FALSE) {
  
        position <- match.arg(position)
        type <- "unknown"
        na.color <- NULL
        extra <- NULL
        if (!missing(pal)) {
            if (!missing(colors)) 
                stop("You must provide either 'pal' or 'colors' (not both)")
            if (missing(title) && inherits(values, "formula")) 
                title <- deparse(values[[2]])
            values <- evalFormula(values, data)
            type <- attr(pal, "colorType", exact = TRUE)
            args <- attr(pal, "colorArgs", exact = TRUE)
            na.color <- args$na.color
            if (!is.null(na.color) && col2rgb(na.color, alpha = TRUE)[[4]] == 
                    0) {
                na.color <- NULL
            }
            if (type != "numeric" && !missing(bins)) 
                warning("'bins' is ignored because the palette type is not numeric")
            if (type == "numeric") {
                cuts <- if (length(bins) == 1) 
                    pretty(values, bins)
                else bins   
                if (length(bins) > 2) 
                    if (!all(abs(diff(bins, differences = 2)) <= 
                                     sqrt(.Machine$double.eps))) 
                        stop("The vector of breaks 'bins' must be equally spaced")
                n <- length(cuts)
                r <- range(values, na.rm = TRUE)
                cuts <- cuts[cuts >= r[1] & cuts <= r[2]]
                n <- length(cuts)
                p <- (cuts - r[1])/(r[2] - r[1])
                extra <- list(p_1 = p[1], p_n = p[n])
                p <- c("", paste0(100 * p, "%"), "")
                if (decreasing == TRUE){
                    colors <- pal(rev(c(r[1], cuts, r[2])))
                    labels <- rev(labFormat(type = "numeric", cuts))
                }else{
                    colors <- pal(c(r[1], cuts, r[2]))
                    labels <- rev(labFormat(type = "numeric", cuts))
                }
                colors <- paste(colors, p, sep = " ", collapse = ", ")
            }
            else if (type == "bin") {
                cuts <- args$bins
                n <- length(cuts)
                mids <- (cuts[-1] + cuts[-n])/2
                if (decreasing == TRUE){
                    colors <- pal(rev(mids))
                    labels <- rev(labFormat(type = "bin", cuts))
                }else{
                    colors <- pal(mids)
                    labels <- labFormat(type = "bin", cuts)
                }
            }
            else if (type == "quantile") {
                p <- args$probs
                n <- length(p)
                cuts <- quantile(values, probs = p, na.rm = TRUE)
                mids <- quantile(values, probs = (p[-1] + p[-n])/2, na.rm = TRUE)
                if (decreasing == TRUE){
                    colors <- pal(rev(mids))
                    labels <- rev(labFormat(type = "quantile", cuts, p))
                }else{
                    colors <- pal(mids)
                    labels <- labFormat(type = "quantile", cuts, p)
                }
            }
            else if (type == "factor") {
                v <- sort(unique(na.omit(values)))
                colors <- pal(v)
                labels <- labFormat(type = "factor", v)
                if (decreasing == TRUE){
                    colors <- pal(rev(v))
                    labels <- rev(labFormat(type = "factor", v))
                }else{
                    colors <- pal(v)
                    labels <- labFormat(type = "factor", v)
                }
            }
            else stop("Palette function not supported")
            if (!any(is.na(values))) 
                na.color <- NULL
        }
        else {
            if (length(colors) != length(labels)) 
                stop("'colors' and 'labels' must be of the same length")
        }
        legend <- list(colors = I(unname(colors)), labels = I(unname(labels)), 
                                     na_color = na.color, na_label = na.label, opacity = opacity, 
                                     position = position, type = type, title = title, extra = extra, 
                                     layerId = layerId, className = className, group = group)
        invokeMethod(map, data, "addLegend", legend)
        }

运行后，您应该将 addLegend 替换为 addLegend_decreasing 并设置 decreasing = TRUE。然后，您的代码更改为：

    #Default map:
    map <- leaflet() %>% addProviderTiles('Esri.WorldTopoMap')
    x <- 1:100
    pal <- colorNumeric(c("#d7191c","#fdae61","#ffffbf","#abd9e9", "#2c7bb6"), x)
    map %>% addLegend_decreasing('topright', pal = pal, values = x, decreasing = TRUE)

以下是真实的 leaflet 地图示例：

    df <- local({
    n <- 300; x <- rnorm(n); y <- rnorm(n)
    z <- sqrt(x ^ 2 + y ^ 2); z[sample(n, 10)] <- NA
    data.frame(x, y, z)
    })
    pal <- colorNumeric("OrRd", df$z)
    leaflet(df) %>%
      addTiles() %>%
        addCircleMarkers(~x, ~y, color = ~pal(z), group = "circles") %>%
          addLegend(pal = pal, values = ~z, group = "circles", position = "bottomleft") %>%
            addLayersControl(overlayGroups = c("circles"))

使用默认 addLegend 映射：

与 addLegend_decreasing 和 decreasing = TRUE 相同的地图

    leaflet(df) %>%
      addTiles() %>%
        addCircleMarkers(~x, ~y, color = ~pal(z), group = "circles") %>%
          addLegend_decreasing(pal = pal, values = ~z, group = "circles", position = "bottomleft", decreasing = TRUE) %>%
            addLayersControl(overlayGroups = c("circles"))

使用自定义 addLegend_decresing 映射：

希望这会有所帮助，它确实帮助了我。

R传单连续传奇中的逆序

4 个答案:

更新