-
Notifications
You must be signed in to change notification settings - Fork 45
/
align.R
executable file
·185 lines (156 loc) · 6.29 KB
/
align.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
##### START zeroGrob FROM ggplot2 ##############################################
# Copied from ggplot2. This is a non-exported function. To avoid R CMD CHECK
# note for use ::: the functions were copied here.
#' The zero grob draws nothing and has zero size.
#'
#' @keywords internal
#' @author hadley
#' @references https://github.com/hadley/ggplot2/blob/master/R/grob-null.r
zeroGrob <- function() .zeroGrob
.zeroGrob <- grob(cl = "zeroGrob", name = "NULL")
widthDetails.zeroGrob <-
heightDetails.zeroGrob <-
grobWidth.zeroGrob <-
grobHeight.zeroGrob <- function(x) unit(0, "cm")
drawDetails.zeroGrob <- function(x, recording) {}
is.zero <- function(x) is.null(x) || inherits(x, "zeroGrob")
##### END zeroGrob FROM ggplot2 ################################################
#' Adapted from ggExtra package which is no longer available. This is related to
#' an experimental mlpsa plot that will combine the circular plot along with
#' the two individual distributions.
#'
#' @param gl grid.layout
#' @param ... graphic elements to combine.
align.plots <- function(gl, ...) {
#With ggplot2 version .9.2 these functions were removed. This is a bit of
#a hack copying them from an older version, but seems to still work!
ggplotGrob <- function (x) {
gtable_gTree(ggplot_gtable(ggplot_build(x)))
}
gtable_gTree <- function (x, ...) {
children <- gtable_gList(x)
vp <- gtable_viewport(x)
gTree(children = children, childrenvp = vp, ...)
}
gtable_gList <- function (x) {
names <- with(x$layout, paste(name, t, l, sep = "-"))
grobs <- llply(seq_along(names), function(i) {
editGrob(x$grobs[[i]], vp = vpPath(x$name, names[i]),
name = names[i])
})
do.call("gList", grobs)
}
gtable_viewport <- function (x) {
layout_vp <- viewport(layout = gtable_layout(x), name = x$name)
vp <- function(i) {
vp <- x$layout[i, ]
viewport(name = paste(vp$name, vp$t, vp$l, sep = "-"),
layout.pos.row = vp$t:vp$b, layout.pos.col = vp$l:vp$r,
clip = vp$clip)
}
children_vp <- do.call("vpList", llply(seq_along(x$grobs),
vp))
vpTree(layout_vp, children_vp)
}
gtable_layout <- function (x) {
grid.layout(nrow = nrow(x), heights = x$heights, ncol = ncol(x),
widths = x$widths, respect = x$respect)
}
# Obtained from http://groups.google.com/group/ggplot2/browse_thread/thread/1b859d6b4b441c90
# Adopted from http://ggextra.googlecode.com/svn/trunk/R/align.r
# BUGBUG: Does not align horizontally when one has a title.
# There seems to be a spacer used when a title is present. Include the
# size of the spacer. Not sure how to do this yet.
stats.row <- vector( "list", gl$nrow )
stats.col <- vector( "list", gl$ncol )
lstAll <- list(...)
dots <- lapply(lstAll, function(.g) {
ggplotGrob(.g[[1]]) })
plottitles <- lapply(dots, function(.g) {
if(!is.null(getGrob(.g, 'plot.title.text', grep=TRUE)))
editGrob(getGrob(.g, "plot.title.text", grep=TRUE), vp=NULL)
else .zeroGrob
})
xtitles <- lapply(dots, function(.g) {
#.g <- ggplotGrob(.g)
if(!is.null(getGrob(.g, "axis.title.x.text", grep=TRUE)))
editGrob(getGrob(.g,"axis.title.x.text",grep=TRUE), vp=NULL)
else .zeroGrob
})
xlabels <- lapply(dots, function(.g) {
#.g <- ggplotGrob(.g)
if(!is.null(getGrob(.g, "axis.text.x.text",grep=TRUE)))
editGrob(getGrob(.g,"axis.text.x.text",grep=TRUE), vp=NULL)
else .zeroGrob
})
ytitles <- lapply(dots, function(.g) {
#.g <- ggplotGrob(.g)
if(!is.null(getGrob(.g,"axis.title.y.text",grep=TRUE)))
editGrob(getGrob(.g,"axis.title.y.text",grep=TRUE), vp=NULL)
else .zeroGrob
})
ylabels <- lapply(dots, function(.g) {
#.g <- ggplotGrob(.g)
if(!is.null(getGrob(.g,"axis.text.y.text",grep=TRUE)))
editGrob(getGrob(.g,"axis.text.y.text",grep=TRUE), vp=NULL)
else .zeroGrob
})
legends <- lapply(dots, function(.g) {
if(!is.null(.g$children$legends))
editGrob(.g$children$legends, vp=NULL)
else .zeroGrob
})
widths.left <- mapply(`+`, e1=lapply(ytitles, grobWidth),
e2= lapply(ylabels, grobWidth), SIMPLIFY=FALSE)
widths.right <- lapply(legends, grobWidth)
# heights.top <- lapply(plottitles, grobHeight)
heights.top <- lapply( plottitles, function(x) unit(0,"cm") )
heights.bottom <- mapply(`+`, e1=lapply(xtitles, grobHeight),
e2=lapply(xlabels, grobHeight), SIMPLIFY=FALSE)
for ( i in seq_along( lstAll ) ) {
lstCur <- lstAll[[i]]
# Left
valNew <- widths.left[[ i ]]
valOld <- stats.col[[ min(lstCur[[3]]) ]]$widths.left.max
if ( is.null( valOld ) ) valOld <- unit( 0, "cm" )
stats.col[[ min(lstCur[[3]]) ]]$widths.left.max <-
max( do.call( unit.c, list(valOld, valNew) ) )
# Right
valNew <- widths.right[[ i ]]
valOld <- stats.col[[ max(lstCur[[3]]) ]]$widths.right.max
if ( is.null( valOld ) ) valOld <- unit( 0, "cm" )
stats.col[[ max(lstCur[[3]]) ]]$widths.right.max <-
max( do.call( unit.c, list(valOld, valNew) ) )
# Top
valNew <- heights.top[[ i ]]
valOld <- stats.row[[ min(lstCur[[2]]) ]]$heights.top.max
if ( is.null( valOld ) ) valOld <- unit( 0, "cm" )
stats.row[[ min(lstCur[[2]]) ]]$heights.top.max <-
max( do.call( unit.c, list(valOld, valNew) ) )
# Bottom
valNew <- heights.bottom[[ i ]]
valOld <- stats.row[[ max(lstCur[[2]]) ]]$heights.bottom.max
if ( is.null( valOld ) ) valOld <- unit( 0, "cm" )
stats.row[[ max(lstCur[[2]]) ]]$heights.bottom.max <-
max( do.call( unit.c, list(valOld, valNew) ) )
}
for(i in seq_along(dots)){
lstCur <- lstAll[[i]]
nWidthLeftMax <- stats.col[[ min( lstCur[[ 3 ]] ) ]]$widths.left.max
nWidthRightMax <- stats.col[[ max( lstCur[[ 3 ]] ) ]]$widths.right.max
nHeightTopMax <- stats.row[[ min( lstCur[[ 2 ]] ) ]]$heights.top.max
nHeightBottomMax <- stats.row[[ max( lstCur[[ 2 ]] ) ]]$heights.bottom.max
pushViewport( viewport( layout.pos.row=lstCur[[2]],
layout.pos.col=lstCur[[3]], just=c("left","top") ) )
pushViewport(viewport(
x=unit(0, "npc") + nWidthLeftMax - widths.left[[i]],
y=unit(0, "npc") + nHeightBottomMax - heights.bottom[[i]],
width=unit(1, "npc") - nWidthLeftMax + widths.left[[i]] -
nWidthRightMax + widths.right[[i]],
height=unit(1, "npc") - nHeightBottomMax + heights.bottom[[i]] -
nHeightTopMax + heights.top[[i]],
just=c("left","bottom")))
grid.draw(dots[[i]])
upViewport(2)
}
}