R小叶连续图例中的逆序

Question

我试图leaflet在R中反转我的图例的值显示.这篇文章涵盖了分类数据,但我正在处理连续数据.这是一个玩具示例:

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()参数,addLegend()以引用反转值的查找表......似乎没有任何效果.是否有捷径可寻？

Answer 1

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

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

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 2

尽管接受的答案确实翻转了图例的颜色和标签，但地图的颜色并不适合图例。这是一个（从这里窃取的）解决方案。基本上，mpriem89创建了一个名为 的新函数，其工作方式与使用额外参数addLegend_decreasing完全相同：反转图例的颜色和标签，正确定位地图的颜色。这是函数代码：addLegenddecreasing = 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_decreasing 的地图：

希望这有帮助，它确实对我有帮助。

Answer 3

我刚刚发现内置labelFormat函数有一个transform带函数的参数.所以我sort在那里传递了这个功能.要使用相同的示例,

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