如何在ggplot中重现smoothScatter的异常值绘图？

Question

我试图得到像smoothScatter函数那样的东西，只在ggplot中。除了绘制N个最稀疏的点之外，我已经找到了所有的东西。任何人都可以帮我这个吗？

library(grDevices)
library(ggplot2)

# Make two new devices
dev.new()
dev1 <- dev.cur()
dev.new()
dev2 <- dev.cur()

# Make some data that needs to be plotted on log scales
mydata <- data.frame(x=exp(rnorm(10000)), y=exp(rnorm(10000)))

# Plot the smoothScatter version
dev.set(dev1)
with(mydata, smoothScatter(log10(y)~log10(x)))

# Plot the ggplot version
dev.set(dev2)
ggplot(mydata) + aes(x=x, y=y) + scale_x_log10() + scale_y_log10() + 
  stat_density2d(geom="tile", aes(fill=..density..^0.25), contour=FALSE) +
  scale_fill_gradientn(colours = colorRampPalette(c("white", blues9))(256))

请注意，在基本图形版本中，如何在平滑密度图上绘制100个最“稀疏”的点。稀疏性由点坐标处的核密度估计值定义，重要的是，核心密度估计是在对数变换（或其他任何坐标变换）之后计算的。我可以通过添加+ geom_point(size=0.5)来绘制所有点，但我只想要稀疏点。

有没有办法用ggplot来实现这个目标？这有两个部分。第一个是弄清坐标变换后的异常值，第二个是仅绘制那些点。

Answer 1

这是一种解决方法！是不是在最不密集的n点上工作，而是绘制密度小于0.25的所有点。

它实际绘制了stat_density2d()图层，然后是geom_point(，然后是stat_density2d()，使用alpha在最后一层中间创建一个透明的“洞”，其中密度为^ 0.25高于（在这种情况下）0.4。

显然，你有三个地块的表现。

# Plot the ggplot version
ggplot(mydata) + aes(x=x, y=y) + scale_x_log10() + scale_y_log10() + 
  stat_density2d(geom="tile", aes(fill=..density..^0.25, alpha=1), contour=FALSE) + 
  geom_point(size=0.5) +
  stat_density2d(geom="tile", aes(fill=..density..^0.25,     alpha=ifelse(..density..^0.25<0.4,0,1)), contour=FALSE) + 
  scale_fill_gradientn(colours = colorRampPalette(c("white", blues9))(256))

Answer 2

这里是一种解决方案，可以首先计算数据中每个（双变量）观测值的稀疏度（或分别在应用选择的变换后 之后）。

首先让我们根据从KernSmooth::bkde2D计算出的密度为每个观测值计算最可能的密度值，为了方便起见，我们通过grDevices:::.smoothScatterCalcDensity对其进行了调用，以对binwidth进行适当的猜测（如果没有）提供。此功能对other problems as well有用。

densVals <- function(x, y = NULL, nbin = 128, bandwidth, range.x) {
  dat <- cbind(x, y)
  # limit dat to strictly finite values
  sel <- is.finite(x) & is.finite(y)
  dat.sel <- dat[sel, ]
  # density map with arbitrary graining along x and y
  map   <- grDevices:::.smoothScatterCalcDensity(dat.sel, nbin, bandwidth)
  map.x <- findInterval(dat.sel[, 1], map$x1)
  map.y <- findInterval(dat.sel[, 2], map$x2)
  # weighted mean of the fitted density map according to how close x and y are
  # to the arbitrary grain of the map
  den <- mapply(function(x, y) weighted.mean(x = c(
    map$fhat[x, y], map$fhat[x + 1, y + 1],
    map$fhat[x + 1, y], map$fhat[x, y + 1]), w = 1 / c(
    map$x1[x] + map$x2[y], map$x1[x + 1] + map$x2[y + 1],
    map$x1[x + 1] + map$x2[y], map$x1[x] + map$x2[y + 1])),
    map.x, map.y)
  # replace missing density estimates with NaN
  res <- rep(NaN, length(sel))
  res[sel] <- den
  res
}

我将加权平均值用作“真实”密度值的（线性）近似值。可能只需进行简单的查找即可。

这是实际计算。

mydata <- data.frame(x = exp(rnorm(10000)), y = exp(rnorm(10000)))
# the transformation applied will affect the local density estimate
mydata$point_density <- densVals(log10(mydata$x), log10(mydata$y))

现在，让我们绘图。 （以特洛伊的答案为基础。）

library(ggplot2)

ggplot(mydata, aes(x = x, y = y)) +
  stat_density2d(geom = "raster", aes(fill = ..density.. ^ 0.25), contour = FALSE) +
  scale_x_log10() + scale_y_log10() +
  scale_fill_gradientn(colours = colorRampPalette(c("white", blues9))(256)) +
  # select only the 100 sparesest points
  geom_point(data = dplyr::top_n(mydata, 100, -point_density), size = .5)

(final plot)-对不起，尚未嵌入图像。

不需要过度绘图。 ：）