2

我希望生成一个带有分箱多边形（三角形或十六进制，最好在 ggplot 框架中）的三元图，其中多边形的颜色是所选值的分箱平均值或中位数。

该脚本非常接近，但三角形单元格的颜色代表了许多观测值，而不是三角形单元格中包含的观测值的平均值。

因此，与其单独提供 X、Y 和 Z；我将提供第四个填充/值变量，从中计算分箱均值​​或中位数并将其表示为渐变上的颜色。

类似于下图，但在带有附加轴的三元框架中。 stat_summary_hex() 绘图的图像，颜色为分箱平均值

我很感激帮助。谢谢你。

虚拟数据开头：

#load libraries       
devtools::install_git('https://bitbucket.org/nicholasehamilton/ggtern')
library(ggtern)
library(ggplot)



# example data 
sig <- matrix(c(3,0,0,2),2,2)
data <- data.frame(mvrnorm(n=10000, rep(2, 2), sig))
data$X1 <- data$X1/max(data$X1)
data$X2 <- data$X2/max(data$X2)
data$X1[which(data$X1<0)] <- runif(length(data$X1[which(data$X1<0)]))
data$X2[which(data$X2<0)] <- runif(length(data$X2[which(data$X2<0)]))
data$X3 <- with(data, 1-X1-X2)
data <- data[data$X3 >= 0,]
data$X4 <- rnorm(dim(data)[1])
data <- data.frame(X = data$X1, Y = data$X2, Z = data$X3, fill_variable = data$X4)
str(data)

# simple ternary plot where color of point is the fill variable value
ggtern(data,aes(X,Y,Z, color = fill_variable))+geom_point()

# 2D example, not a ternary though. Keep in mind in geom_hex Z is the fill, not the additional axis like ggtern
ggplot(data,aes(X,Y))+stat_summary_hex(aes(z = fill_variable))
4

1 回答 1

0

这段代码没有被清理，但它是一个很好的起点。原始的信用来自第一个问题中引用的 OP。

我对 count_bin 函数进行了一些小的调整，而不是进行 bin 计数，而是进行 bin 中位数。使用风险自负，请指出任何错误。对于我的实现，这报告 0 用于 NA 箱。

例子：

分箱中位数的功能（请原谅名称，只是节省时间）：

count_bin <- function(data, minT, maxT, minR, maxR, minL, maxL) {
  ret <- data
  ret <- with(ret, ret[minT <= X1 & X1 < maxT,])
  ret <- with(ret, ret[minL <= X2 & X2 < maxL,])
  ret <- with(ret, ret[minR <= X3 & X3 < maxR,])

  if(is.na(median(ret$VAR))) {
    ret <- 0
  } else {
    ret <- median(ret$VAR)
  }
  ret
}

修改热图功能：

heatmap3d <- function(data, inc, logscale=FALSE, text=FALSE, plot_corner=TRUE) {
  #   When plot_corner is FALSE, corner_cutoff determines where to stop plotting
  corner_cutoff = 1
  #   When plot_corner is FALSE, corner_number toggles display of obervations in the corners
  #   This only has an effect when text==FALSE
  corner_numbers = TRUE

  count <- 1
  points <- data.frame()
  for (z in seq(0,1,inc)) {
    x <- 1- z
    y <- 0
    while (x>0) {
      points <- rbind(points, c(count, x, y, z))
      x <- round(x - inc, digits=2)
      y <- round(y + inc, digits=2)
      count <- count + 1
    }
    points <- rbind(points, c(count, x, y, z))
    count <- count + 1
  }
  colnames(points) = c("IDPoint","T","L","R")
  #str(points)
  #str(count)
  #   base <- ggtern(data=points,aes(L,T,R)) +
  #               theme_bw() + theme_hidetitles() + theme_hidearrows() +
  #               geom_point(shape=21,size=10,color="blue",fill="white") +
  #               geom_text(aes(label=IDPoint),color="blue")
  #   print(base)

  polygons <- data.frame()
  c <- 1
  #   Normal triangles
  for (p in points$IDPoint) {
    if (is.element(p, points$IDPoint[points$T==0])) {
      next
    } else {
      pL <- points$L[points$IDPoint==p]
      pT <- points$T[points$IDPoint==p]
      pR <- points$R[points$IDPoint==p]
      polygons <- rbind(polygons, 
                        c(c,p),
                        c(c,points$IDPoint[abs(points$L-pL) < inc/2 & abs(points$R-pR-inc) < inc/2]),
                        c(c,points$IDPoint[abs(points$L-pL-inc) < inc/2 & abs(points$R-pR) < inc/2]))    
      c <- c + 1
    }
  }

  #str(c)

  # Upside down triangles
  for (p in points$IDPoint) {
    if (!is.element(p, points$IDPoint[points$T==0])) {
      if (!is.element(p, points$IDPoint[points$L==0])) {
        pL <- points$L[points$IDPoint==p]
        pT <- points$T[points$IDPoint==p]
        pR <- points$R[points$IDPoint==p]
        polygons <- rbind(polygons, 
                          c(c,p),
                          c(c,points$IDPoint[abs(points$T-pT) < inc/2 & abs(points$R-pR-inc) < inc/2]),
                          c(c,points$IDPoint[abs(points$L-pL) < inc/2 & abs(points$R-pR-inc) < inc/2])) 
        c <- c + 1
      }
    }
  }

  #str(c)

  #   IMPORTANT FOR CORRECT ORDERING.
  polygons$PointOrder <- 1:nrow(polygons)
  colnames(polygons) = c("IDLabel","IDPoint","PointOrder")

  df.tr <- merge(polygons,points)

  Labs = ddply(df.tr,"IDLabel",function(x){c(c(mean(x$T),mean(x$L),mean(x$R)))})
  colnames(Labs) = c("Label","T","L","R")

  #str(Labs)

     #triangles <- ggtern(data=df.tr,aes(L,T,R)) +
     #                geom_polygon(aes(group=IDLabel),color="black",alpha=0.25) +
     #                geom_text(data=Labs,aes(label=Label),size=4,color="black") +
     #                theme_bw()
     #    print(triangles)

  bins <- ddply(df.tr, .(IDLabel), summarize, 
                maxT=max(T),
                maxL=max(L),
                maxR=max(R),
                minT=min(T),
                minL=min(L),
                minR=min(R))

  #str(bins)


  count <- ddply(bins, .(IDLabel), summarize, 
                 N=count_bin(data, minT, maxT, minR, maxR, minL, maxL)
                 #N=mean(data)
                 )
  df <- join(df.tr, count, by="IDLabel")

  str(count)

  Labs = ddply(df,.(IDLabel,N),function(x){c(c(mean(x$T),mean(x$L),mean(x$R)))})
  colnames(Labs) = c("Label","N","T","L","R")

  if (plot_corner==FALSE){
    corner <- ddply(df, .(IDPoint, IDLabel), summarize, maxperc=max(T,L,R))
    corner <- corner$IDLabel[corner$maxperc>=corner_cutoff]

    df$N[is.element(df$IDLabel, corner)] <- 0
    if (text==FALSE & corner_numbers==TRUE) {
      Labs$N[!is.element(Labs$Label, corner)] <- ""
      text=TRUE
    }
  }    

  heat <- ggtern(data=df,aes(L,T,R)) +
    geom_polygon(aes(fill=N,group=IDLabel),color="black",alpha=1, size = 0.1,show.legend = F)
  if (logscale == TRUE) {
    heat <- heat + scale_fill_gradient(name="Observations", trans = "log",
                                       low=palette[2], high=palette[4])
  } else {
    heat <- heat + scale_fill_distiller(name="Median Value", 
                                       palette = "Spectral")
  }
  heat <<- heat +
    Tlab("x") +
    Rlab("y") +
    Llab("z") +
    theme_bw() + 
    theme(axis.tern.arrowsep=unit(0.02,"npc"), #0.01npc away from ticks ticklength
          axis.tern.arrowstart=0.25,axis.tern.arrowfinish=0.75,
          axis.tern.text=element_text(size=12),
          axis.tern.arrow.text.T=element_text(vjust=-1),validate = F,
          axis.tern.arrow.text.R=element_text(vjust=2),
          axis.tern.arrow.text.L=element_text(vjust=-1),
          #axis.tern.arrow.text=element_text(size=12),
          axis.tern.title=element_text(size=15),
          axis.tern.text=element_blank(),
          axis.tern.arrow.text=element_blank())
  if (text==FALSE) {
    print(heat)
  } else {
    print(heat + geom_text(data=Labs,aes(label=N),size=3,color="white"))
  }
}

虚拟示例：

# dummy example

sig <- matrix(c(3,3,3,3),3,3)
data <- data.frame(mvrnorm(n=10000, rep(2, 2), sig))
data$X1[which(data$X1<0)] <- runif(length(data$X1[which(data$X1<0)]))
data$X2[which(data$X2<0)] <- runif(length(data$X2[which(data$X2<0)]))
data$X3 <- with(data, 1-X1-X2)
data <- data[data$X3 >= 0,]
data$VAR <- rnorm(dim(data)[1])
data <- data.frame(X = data$X1, Y = data$X2, Z = data$X3, fill_variable = data$X4)
str(data)

ggtern(data,aes(X1,
                X2,
                X3, color = VAR))+geom_point(size = 5)+scale_color_distiller(palette = "Spectral")
heatmap3d(data,.05)

在此处输入图像描述

在此处输入图像描述

于 2017-12-19T00:50:37.687 回答