こんな感じです。
ggplot(data = iris)+
geom_grid(aes(y = Sepal.Length, x=Species),binwidth =0.1)
![f:id:abrahamcow:20190324062631p:plain]( "f:id:abrahamcow:20190324062631p:plain")
思い通りに動かないことも多いけど公開します。
皆様の暖かいアドバイスをお待ちしております。
- coord_flip に対応したい
- 四角が大きいとき隣の四角とかぶってしまうのをなんとかしたい
- bins でビンの数を変えられるようにしたい
- stack に対応したい
library(tidyverse)library(grid)
geom_grid <-function(mapping =NULL, data =NULL,
position ="identity",
...,
binwidth =NULL,
binaxis ="y",
method ="dotdensity",
binpositions ="bygroup",
stackdir ="up",
stackratio =1,
dotsize =1,
stackgroups =FALSE,
origin =NULL,
right =TRUE,
width =0.9,
drop =FALSE,
na.rm =FALSE,
show.legend =NA,
inherit.aes =TRUE){if(!is.null(position)&&(identical(position,"stack")||(inherits(position,"PositionStack"))))
message("position=\"stack\" doesn't work properly with geom_dotplot. Use stackgroups=TRUE instead.")if(stackgroups && method =="dotdensity"&& binpositions =="bygroup")
message('geom_dotplot called with stackgroups=TRUE and method="dotdensity". You probably want to set binpositions="all"')
layer(
data = data,
mapping = mapping,
stat = StatBindot,
geom = GeomGrid,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params =list(
binaxis = binaxis,
binwidth = binwidth,
binpositions = binpositions,
method = method,
origin = origin,
right = right,
width = width,
drop = drop,
stackdir = stackdir,
stackratio = stackratio,
dotsize = dotsize,
stackgroups = stackgroups,
na.rm = na.rm,
...
))}
GeomGrid <- ggproto("GeomGrid", Geom,
required_aes = c("x","y"),
non_missing_aes = c("size","shape"),
default_aes = aes(colour ="black", fill ="white", alpha =NA, stroke =1, linetype ="solid"),
setup_data =function(data, params){
data$width <- data$width %||%
params$width %||%(resolution(data$x,FALSE)*0.9)if(is.null(params$stackdir)|| params$stackdir =="up"){
stackdots <-function(a) a -.5
stackaxismin <-0
stackaxismax <-1}elseif(params$stackdir =="down"){
stackdots <-function(a)-a +.5
stackaxismin <--1
stackaxismax <-0}elseif(params$stackdir =="center"){
stackdots <-function(a) a -1- max(a -1)/2
stackaxismin <--.5
stackaxismax <-.5}elseif(params$stackdir =="centerwhole"){
stackdots <-function(a) a -1- floor(max(a -1)/2)
stackaxismin <--.5
stackaxismax <-.5}
data <- data[rep(1:nrow(data), data$count),]
data <- data %>%
dplyr::group_by_("x","y","PANEL","group")%>%
dplyr::mutate(countidx = row_number())%>%
dplyr::mutate(stackpos = stackdots(countidx))if(is.null(params$binaxis)|| params$binaxis =="x"){
data$xmin <- data$x - data$binwidth /2
data$xmax <- data$x + data$binwidth /2
data$ymin <- stackaxismin
data$ymax <- stackaxismax
data$y <-0}elseif(params$binaxis =="y"){
data <- dplyr::mutate(dplyr::group_by(data, group, PANEL),
ymin = min(y)- binwidth /2,
ymax = max(y)+ binwidth /2)
data$xmin <- data$x + data$width * stackaxismin
data$xmax <- data$x + data$width * stackaxismax
}
data
},
draw_group =function(data, panel_params, coord, na.rm =FALSE,
binaxis ="x", stackdir ="up", stackratio =1,
dotsize =1, stackgroups =FALSE){if(!coord$is_linear()){
warning("geom_grid does not work properly with non-linear coordinates.")}
tdata <- coord$transform(data, panel_params)if(inherits(coord,"CoordFlip"))
binaxis <- ifelse(binaxis =="x","y","x")if(binaxis =="x"){
stackaxis ="y"
dotdianpc <- dotsize * tdata$binwidth[1]/(max(panel_params$x.range)- min(panel_params$x.range))}elseif(binaxis =="y"){
stackaxis ="x"
dotdianpc <- dotsize * tdata$binwidth[1]/(max(panel_params$y.range)- min(panel_params$y.range))}
ggplot2:::ggname("geom_grid",
rectstackGrob(stackaxis = stackaxis, x = tdata$x, y = tdata$y, dotdia = dotdianpc,
stackposition = tdata$stackpos, stackratio = stackratio,
default.units ="npc",
gp = gpar(col = alpha(tdata$colour, tdata$alpha),
fill = alpha(tdata$fill, tdata$alpha),
lwd = tdata$stroke, lty = tdata$linetype)))},
draw_key = draw_key_dotplot
)
rectstackGrob <-function(
x = unit(0.5,"npc"),
y = unit(0.5,"npc"),
stackaxis ="y",
dotdia = unit(1,"npc"),
stackposition =0,
stackratio =1,
default.units ="npc", name =NULL, gp = gpar(), vp =NULL){if(!grid::is.unit(x))
x <- unit(x, default.units)if(!grid::is.unit(y))
y <- unit(y, default.units)if(!grid::is.unit(dotdia))
dotdia <- unit(dotdia, default.units)if(attr(dotdia,"unit")!="npc")
warning("Unit type of dotdia should be 'npc'")
grob(x = x, y = y, stackaxis = stackaxis, dotdia = dotdia,
stackposition = stackposition, stackratio = stackratio,
name = name, gp = gp, vp = vp, cl ="rectstackGrob")}
makeContext.rectstackGrob <-function(x, recording =TRUE){
xmm <- convertX(x$x,"mm", valueOnly =TRUE)
ymm <- convertY(x$y,"mm", valueOnly =TRUE)if(x$stackaxis =="x"){
dotdiamm <- convertY(x$dotdia,"mm", valueOnly =TRUE)
xpos <- xmm + dotdiamm *(x$stackposition * x$stackratio +(1- x$stackratio)/2)
ypos <- ymm
}elseif(x$stackaxis =="y"){
dotdiamm <- convertX(x$dotdia,"mm", valueOnly =TRUE)
xpos <- xmm
ypos <- ymm + dotdiamm *(x$stackposition * x$stackratio +(1- x$stackratio)/2)}
grid::rectGrob(
x = xpos, y = ypos, width = dotdiamm , height = dotdiamm ,
default.units ="mm",
name = x$name, gp = x$gp, vp = x$vp
)}
ggplot(data = iris)+
geom_grid(aes(y = Sepal.Length, x=Species),binwidth =0.1)
![[改訂第7版]LaTeX2ε美文書作成入門](http://images-fe.ssl-images-amazon.com/images/I/51E5K7B53aL._SL160_.jpg "[改訂第7版]LaTeX2ε美文書作成入門")
![RユーザのためのRStudio[実践]入門−tidyverseによるモダンな分析フローの世界−](http://images-fe.ssl-images-amazon.com/images/I/51yOW-20h-L._SL160_.jpg "RユーザのためのRStudio[実践]入門−tidyverseによるモダンな分析フローの世界−")
