Question

我正在尝试绘制具有两个组的轮廓三元图，等高线的不透明度（α）是点的密度（例如，更多的点紧密聚集=不透明的程度较小）。

我只停留在一点上。我的两个组（此处为A和B）的组大小不相等（A = 150磅，B = 50磅），这意味着一组中的点通常会更多地聚集在一起，在这种情况下，组B的不透明度应相对于 A组，因为B组中的点密度要小得多。但是看起来不透明度在组内而不是组间扩展。

我的问题：是否可以将不透明度缩放为点的密度，点的密度在两组之间都是相对的？

一个例子：

library(ggtern)

set.seed(1234)

# example data
df <- data.frame(X = c(runif(150, 0.7, 1),runif(50, 0, 0.3)),
                 Y = c(runif(150, 0, 0.3),runif(50, 0, 0.3)),
                 Z = c(runif(150, 0, 0.5),runif(50, 0.5, 1)),
                 D = c(rep("A", 150), rep("B", 50)))


# ternary plot 
ggtern(df, aes(x = X,y = Y, z = Z, color = D)) +
  stat_density_tern(aes(alpha = ..level.., fill = D), 
                    geom = 'polygon', 
                    bins = 10,
                    color = "grey") +
  geom_point(alpha = 0.5) +
  scale_colour_manual(values = c("tomato3", "turquoise4"))

# points are only displayed to show densities, I don't plan on showing 
# points in the final plot

鉴于组B的点密度要小得多，我希望轮廓比A组更不透明。

另一种选择是使用scale_colour_gradient()，但我不能看看如何在上获得两个单独的渐变（A和B中的每个渐变）单图。

Answer 1

我希望能为您提供一个简单的答案，但是，我没有。但是，我发现了一个非常棘手的解决方案，方法是进行新的统计并预先定义休息时间。免责声明：我自己不使用ggtern，所以我对具体细节不了解。通常的问题似乎是密度是按组计算的，而密度的积分通常设置为1。我们可以通过添加一个新的统计数据来解决此问题。

然后，该解决方案似乎非常简单：将计算出的密度乘以组中数据点的数量，即可得到按比例缩放以反映组大小的密度。唯一的缺点是我们必须更改bins = 10（按组计算），breaks = seq(start, end, by = somenumber)的轮廓要具有绝对值而不是相对值。

但是，ggtern相当复杂，其自身的特性使得编写新的stat函数很难工作。存在一个带有“已批准统计信息”的列表，ggtern会删除所有未经批准的图层。

ggtern:::.approvedstat

             identity            confidence          density_tern           smooth_tern 
       "StatIdentity"  "StatConfidenceTern"     "StatDensityTern"      "StatSmoothTern" 
                  sum                unique      interpolate_tern          mean_ellipse 
            "StatSum"          "StatUnique" "StatInterpolateTern"     "StatMeanEllipse" 
             hex_tern              tri_tern
        "StatHexTern"         "StatTriTern"

因此，首要任务是将我们自己的统计信息（我们称为StatDensityTern2）添加到批准的统计信息列表中，但由于此.approvedstat位于包名称空间中，我们必须对此有所戒备：

approveupdate <- c(ggtern:::.approvedstat, "density_tern2" = "StatDensityTern2")
assignInNamespace(".approvedstat", approveupdate, pos = "package:ggtern")

现在，我们可以编写自己的StatDensityTern2，该方法继承了StatDensityTern的功能，并且对组的计算方式进行了小的更新。在编写此新统计信息时，我们需要注意加载必要的程序包并正确引用内部函数。我们将主要从现有的StatDensityTern$compute_group复制粘贴，但是在将数据传递到轮廓函数之前进行一些小的调整以将z = as.vector(dens$z)更改为z = as.vector(dens$z) * nrow(data)。

library(compositions)
library(rlang)

StatDensityTern2 <-
  ggproto(
    "StatDensityTern2",
    StatDensityTern,
    compute_group = function(
      self, data, scales, na.rm = FALSE, n = 100, h = NULL,
      bdl = 0, bdl.val = NA, contour = TRUE, base = "ilr", expand = 0.5,
      weight = NULL, bins = NULL, binwidth = NULL, breaks = NULL
    ) {
      if (!c(base) %in% c("identity", "ilr")) 
        stop("base must be either identity or ilr", call. = FALSE)
      raes = self$required_aes
      data[raes] = suppressWarnings(compositions::acomp(data[raes]))
      data[raes][data[raes] <= bdl] = bdl.val[1]
      data = remove_missing(data, vars = self$required_aes, na.rm = na.rm, 
                            name = "StatDensityTern", finite = TRUE)
      if (ggplot2:::empty(data)) 
        return(data.frame())
      coord = coord_tern()
      f = get(base, mode = "function")
      fInv = get(sprintf("%sInv", base), mode = "function")
      if (base == "identity") 
        data = tlr2xy(data, coord, inverse = FALSE, scale = TRUE)
      h = h %||% ggtern:::estimateBandwidth(base, data[which(colnames(data) %in% 
                                                      raes)])
      if (length(h) != 2) 
        h = rep(h[1], 2)
      if (base != "identity" && diff(h) != 0) 
        warning("bandwidth 'h' has different x and y bandwiths for 'ilr', this may (probably will) introduce permutational artifacts depending on the ordering", 
                call. = FALSE)
      data[raes[1:2]] = suppressWarnings(f(as.matrix(data[which(colnames(data) %in% 
                                                                  raes)])))
      expand = if (length(expand) != 2) 
        rep(expand[1], 2)
      else expand
      rngxy = range(c(data$x, data$y))
      rngx = scales:::expand_range(switch(base, identity = coord$limits$x, 
                                 rngxy), expand[1])
      rngy = scales:::expand_range(switch(base, identity = coord$limits$y, 
                                 rngxy), expand[2])
      dens = ggtern:::kde2d.weighted(data$x, data$y, h = h, n = n, lims = c(rngx, 
                                                                   rngy), w = data$weight)

# Here be relevant changes ------------------------------------------------


      df = data.frame(expand.grid(x = dens$x, y = dens$y), 
                      z = as.vector(dens$z) * nrow(data), 
                      group = data$group[1])

# Here end relevant changes -----------------------------------------------


      if (contour) {
        df = StatContour$compute_panel(df, scales, bins = bins, 
                                       binwidth = binwidth, breaks = breaks)
      }
      else {
        names(df) <- c("x", "y", "density", "group")
        df$level <- 1
        df$piece <- 1
      }
      if (base == "identity") 
        df = tlr2xy(df, coord, inverse = TRUE, scale = TRUE)
      df[raes] = suppressWarnings(fInv(as.matrix(df[which(colnames(df) %in% 
                                                            raes)])))
      df
    }
  )

现在我们已经编写了一个新的统计信息并已经批准了该统计信息，我们可以通过以下方式使用它：

set.seed(1234)

# example data
df <- data.frame(X = c(runif(150, 0.7, 1),runif(50, 0, 0.3)),
                 Y = c(runif(150, 0, 0.3),runif(50, 0, 0.3)),
                 Z = c(runif(150, 0, 0.5),runif(50, 0.5, 1)),
                 D = c(rep("A", 150), rep("B", 50)))

ggtern(df, aes(x = X, y = Y, z = Z, color = D)) +
  geom_polygon(aes(alpha = ..level.., fill = D),
               stat = "DensityTern2",
               breaks = seq(10, 150, by = 10),
               color = "grey") +
  geom_point(alpha = 0.5) +
  scale_colour_manual(values = c("tomato3", "turquoise4"))

哪个给了我以下情节：

希望您发现这很有用！

三元图-跨组缩放不透明度

1 个答案: