Ternary heatmap in R

Question

R을 사용하여 삼항 히트 맵을 플로팅하는 방법을 고안하려고합니다. ggtern이 트릭을 수행 할 수 있어야한다고 생각하지만 stat_bin과 같은 binning 함수를 수행하는 방법을 모른다. 바닐라 ggplot2. 여기에 지금까지 가지고 무엇 : ggplot하는

require(ggplot2) 
require(ggtern) 
require(MASS) 
require(scales) 

palette <- c("#FF9933", "#002C54", "#3375B2", "#CCDDEC", "#BFBFBF", "#000000") 

sig <- matrix(c(1,2,3,4),2,2) 
data <- data.frame(mvrnorm(n=10000, rep(2, 2), Sigma)) 
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)])) 

## Print 2d heatmap 
ggplot(data, aes(x=X1, y=X2)) + 
    stat_bin2d(bins=50) + 
    scale_fill_gradient2(low=palette[4], mid=palette[3], high=palette[2]) + 
    xlab("Percentage x") + 
    ylab("Percentage y") + 
    scale_y_continuous(labels = percent) + 
    scale_x_continuous(labels = percent) + 
    theme_bw() + theme(text = element_text(size = 15)) 

data$X3 <- with(data, 1-X1-X2) 
data <- data[data$X3 >= 0,] 

## Print ternary heatmap 
ggtern(data, aes(x=X1, y=X2, z=X3)) + 
    geom_point(color="black",size=1,shape=16) + theme_bw() 

첫 번째 호출은 좋은 2D 히트 맵을 생성합니다

두 번째 플롯은 원의 점 좌표 시스템을 플롯. 각 삼각형의 점 수를 구하려면 stat_bin2d와 같은 것이 필요합니다. 이상 적으로 stat_bin2d의 bins 변수를 설정하여 2d에서와 같이 삼각형의 크기를 설정하고 싶습니다.

Answer 1

좋아, 이렇게 잠시 동안 놀고 난 후에 나는 이것을하는 길을 이해했다. 이것을 할 수있는 현명한 방법이 있다면 당신의 의견을 듣고 싶습니다.

코드는 여기에, 다음과 같습니다 나는 그것으로 생산 줄거리입니다 :

require(ggplot2) 
require(ggtern) 
require(MASS) 
require(scales) 
require(plyr) 

palette <- c("#FF9933", "#002C54", "#3375B2", "#CCDDEC", "#BFBFBF", "#000000") 

# 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)])) 

# Print 2d heatmap 
heatmap2d <- function(data) { 
p <- ggplot(data, aes(x=X1, y=X2)) + 
    stat_bin2d(bins=50) + 
    scale_fill_gradient2(low=palette[4], mid=palette[3], high=palette[2]) + 
    xlab("Percentage x") + 
    ylab("Percentage y") + 
    scale_y_continuous(labels = percent) + 
    scale_x_continuous(labels = percent) + 
    theme_bw() + theme(text = element_text(size = 15)) 
print(p) 
} 

# Example data 
# data$X3 <- with(data, 1-X1-X2) 
# data <- data[data$X3 >= 0,] 

# Auxiliary function for heatmap3d 
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(nrow(ret))) { 
     ret <- 0 
    } else { 
     ret <- nrow(ret) 
    } 
    ret 
} 

# Plot 3dimensional histogram in a triangle 
# See dataframe data for example of the input dataformat 
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") 

# 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 
     } 
    } 

# 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 
      } 
     } 
    } 

# 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") 

# 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)) 

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

    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) 
    if (logscale == TRUE) { 
      heat <- heat + scale_fill_gradient(name="Observations", trans = "log", 
          low=palette[2], high=palette[4]) 
    } else { 
      heat <- heat + scale_fill_gradient(name="Observations", 
          low=palette[2], high=palette[4]) 
    } 
    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), 
        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)) 
    if (text==FALSE) { 
     print(heat) 
    } else { 
     print(heat + geom_text(data=Labs,aes(label=N),size=3,color="white")) 
    } 
} 

# Usage examples 
# heatmap3d(data, 0.2, text=TRUE) 
# heatmap3d(data, 0.05) 
# heatmap3d(data, 0.1, text=FALSE, logscale=TRUE) 
# heatmap3d(data, 0.1, text=TRUE, logscale=FALSE, plot_corner=FALSE) 
# heatmap3d(data, 0.1, text=FALSE, logscale=FALSE, plot_corner=FALSE) 

Answer 2

(주로 내게로) 파이썬에서 원 히트 맵에 대한 라이브러리가있다는 python-ternary을했다. 그것은 ggtern으로 완성 된 기능은 아니지만 6 각형 영역과 여러 삼각형 스타일을 사용하는 것을 포함하여 히트 맵을 계산하는 추가 방법이있는 것처럼 보입니다.