2017-12-13 39 views
2

빈 폴리곤 (, 삼각형 또는 16 진수, 바람직하게는 ggplot 프레임 워크)을 사용하여 삼항 플롯을 생성하려고합니다. 여기서 다각형의 색상은 선택된 값의 비닝 된 평균 또는 중앙값입니다. .binned mean/medians가있는 삼항 플롯

script은 매우 가깝지 만 삼각형 셀 색은 삼각형 셀에 포함 된 관측 값의 평균값이 아니라 많은 관측 값을 나타냅니다.

그래서 X, Y 및 Z를 제공하는 Soley가 아닙니다. 네 번째 채우기/값 변수를 제공합니다.이 값은 빈으로 묶인 평균값 또는 중간 값이 계산되고 그라디언트의 색상으로 표시됩니다.

추가 축이있는 3 진 프레임 워크에서 아래 이미지와 비슷합니다. Image of stat_summary_hex() plot with color as binned mean value

감사합니다. 고맙습니다. 이 코드는 정리되지

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

간단한 예. –

답변

0

하지만 좋은 점프 오프 포인트입니다 : 함께

더미 데이터를 시작합니다. 원본에 대한 크레딧은 첫 번째 질문에서 언급 된 OP가됩니다.

빈 수를 수행하는 대신 count_bin 함수를 약간 조정했는데 빈 중앙값을 사용합니다. 스스로 위험을 감수하고 버그를 지적하십시오. 구현을 위해 NA 빈에 대해 0을보고합니다.

예 : 비닝 중앙값

함수 (이름 사면은 단지 시간을 절약)

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) 

개발을위한 기초, 감사로 제공 9,

enter image description here