1
process_facet_layout <- function(gm) {
2 2
	panel.mode <- outer.margins <- attr.outside.position <- legend.outside.position <- NULL
3
	
4 2
	fpi <- gm$shape.fpi
5
	
6 2
	dh2 <- gm$shape.dh - fpi$legH - fpi$attrH - fpi$mainH
7 2
	dw2 <- gm$shape.dw - fpi$legW
8
	
9
	## calculate facets and total device aspect ratio
10
	#dasp <- dw/dh
11 2
	dasp2 <- dw2/dh2
12 2
	hasp <- gm$shape.sasp * gm$ncol / gm$nrow
13
	
14 2
	if (hasp>dasp2) {
15 2
		fW <- dw2
16 2
		fH <- dw2 / hasp
17 2
	} else {
18 2
		fH <- dh2
19 2
		fW <- dh2 * hasp
20 2
	}
21
	
22 2
	if (gm$panel.mode=="none") {
23 2
		gH <- fH + (gm$nrow - 1) * fpi$between.margin.in + fpi$xlabHin
24 2
		gW <- fW + (gm$ncol - 1) * fpi$between.margin.in + fpi$ylabWin
25 2
	} else if (gm$panel.mode=="one") {
26 2
		gH <- fH + gm$nrow * fpi$pSH + (gm$nrow - 1) * fpi$between.margin.in + fpi$xlabHin
27 2
		gW <- fW + (gm$ncol - 1) * fpi$between.margin.in + fpi$ylabWin
28 2
	} else {
29 0
		gH <- fH + fpi$pSH + fpi$between.margin.in * gm$nrow + fpi$xlabHin
30 0
		gW <- fW + fpi$pSW + fpi$between.margin.in * gm$ncol + fpi$ylabWin
31 2
	}
32 2
	gasp <- gW/gH
33

34 2
	if (gasp>dasp2) {
35 2
		xs <- 0
36 2
		ys <- convertHeight(unit(dh2-(dw2 / gasp), "inch"), "npc", valueOnly=TRUE)
37 2
	} else {
38 2
		xs <- convertWidth(unit(dw2-(gasp * dh2), "inch"), "npc", valueOnly=TRUE)
39 2
		ys <- 0
40 2
	}
41 2
	outerx <- sum(gm$outer.margins[c(2,4)])
42 2
	outery <- sum(gm$outer.margins[c(1,3)])
43
	
44 2
	spc <- 1e-5 # trick also used before (v1.2), to prevent clipping of frame border
45
	
46 2
	gm <- within(gm, {
47 2
		between.margin.y <- convertHeight(unit(fpi$between.margin.in, "inch"), "npc", valueOnly=TRUE)
48 2
		between.margin.x <- convertWidth(unit(fpi$between.margin.in, "inch"), "npc", valueOnly=TRUE)
49 2
		panelh <- convertHeight(unit(fpi$pSH, "inch"), "npc", valueOnly=TRUE)
50 2
		panelw <- convertWidth(unit(fpi$pSW, "inch"), "npc", valueOnly=TRUE)
51

52 2
		ylabWnpc <- convertWidth(unit(fpi$ylabWin, "inch"), "npc", valueOnly=TRUE)
53 2
		xlabHnpc <- convertHeight(unit(fpi$xlabHin, "inch"), "npc", valueOnly=TRUE)
54
		
55 2
		attr.between.legend.and.map <- attr.outside.position %in% c("top", "bottom")
56
		
57
		
58 2
		if (panel.mode=="none") {
59 2
			colrange <- (1:ncol)*2 + 3
60 2
			rowrange <- (1:nrow)*2 + 4
61 2
			facetw <- ((1-spc-outerx)-xs-fpi$legmarx-ylabWnpc-between.margin.x*(ncol-1))/ncol
62 2
			faceth <- ((1-spc-outery)-ys-fpi$legmary-fpi$attrmary-fpi$mainmary-xlabHnpc-between.margin.y*(nrow-1))/nrow
63 2
			colws <- c(outer.margins[2], xs/2, fpi$legmar[2], ylabWnpc, rep(c(facetw, between.margin.x), ncol-1), facetw, fpi$legmar[4], xs/2, outer.margins[4])
64
			
65 2
			if (attr.between.legend.and.map) {
66 2
				rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$legmar[3], fpi$attrmar[3], rep(c(faceth, between.margin.y), nrow-1), faceth, xlabHnpc, fpi$attrmar[1], fpi$legmar[1], ys/2, outer.margins[1])
67 2
			} else {
68 0
				rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$attrmar[3], fpi$legmar[3], rep(c(faceth, between.margin.y), nrow-1), faceth, xlabHnpc, fpi$legmar[1], fpi$attrmar[1], ys/2, outer.margins[1])
69 2
			}
70
			
71

72 2
		} else if (panel.mode=="one") {
73 2
			colrange <- (1:ncol)*2 + 3
74 2
			rowrange <- (1:nrow)*3 + 4
75
			
76 2
			facetw <- ((1-spc-outerx)-xs-fpi$legmarx-ylabWnpc-between.margin.x*(ncol-1))/ncol
77 2
			faceth <- ((1-spc-outery)-ys-fpi$legmary-fpi$attrmary-fpi$mainmary-xlabHnpc-between.margin.y*(nrow-1))/nrow - panelh
78
			
79 2
			colws <- c(outer.margins[2], xs/2, fpi$legmar[2], ylabWnpc, rep(c(facetw, between.margin.x), ncol-1), facetw, fpi$legmar[4], xs/2, outer.margins[4])
80 2
			if (attr.between.legend.and.map) {
81 2
				rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$legmar[3], fpi$attrmar[3], rep(c(panelh, faceth, between.margin.y), nrow-1), panelh, faceth, xlabHnpc, fpi$attrmar[1], fpi$legmar[1], ys/2, outer.margins[1])
82 2
			} else {
83 0
				rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$attrmar[3], fpi$legmar[3], rep(c(panelh, faceth, between.margin.y), nrow-1), panelh, faceth, xlabHnpc, fpi$legmar[1], fpi$attrmar[1], ys/2, outer.margins[1])
84 2
			}
85
			
86 2
		} else {
87 0
			colrange <- (1:ncol)*2 + 5
88 0
			rowrange <- (1:nrow)*2 + 6
89
			
90 0
			colpanelrow <- 6
91 0
			rowpanelcol <- 5
92
			
93 0
			facetw <- ((1-spc-outerx)-xs-fpi$legmarx-ylabWnpc-between.margin.x*ncol-panelw)/ncol
94 0
			faceth <- ((1-spc-outery)-ys-fpi$legmary-fpi$attrmary-fpi$mainmary-xlabHnpc-between.margin.y*nrow-panelh)/nrow
95
			
96 0
			colws <- c(outer.margins[2], xs/2, fpi$legmar[2], ylabWnpc, panelw, rep(c(between.margin.x, facetw), ncol), fpi$legmar[4], xs/2, outer.margins[4])
97
			
98 0
			if (attr.between.legend.and.map) {
99 0
				rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$legmar[3], fpi$attrmar[3], panelh, rep(c(between.margin.y, faceth), nrow), xlabHnpc, fpi$attrmar[1],fpi$legmar[1], ys/2, outer.margins[1])
100 0
			} else {
101 0
				rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$attrmar[3], fpi$legmar[3], panelh, rep(c(between.margin.y, faceth), nrow), xlabHnpc, fpi$legmar[1], fpi$attrmar[1], ys/2, outer.margins[1])
102 0
			}
103
			
104 2
		}
105 2
		if (legend.outside.position[1] == "left") {
106 0
			legx <- 3
107 0
			legy <- 5:(length(rowhs)-5)
108 2
		} else if (legend.outside.position[1] == "right") {
109 2
			legx <- length(colws)-2
110 2
			legy <- 5:(length(rowhs)-5)
111 2
		} else if (legend.outside.position[1] == "top") {
112 0
			legy <- 4- attr.between.legend.and.map
113 0
			legx <- 5:(length(colws)-3)
114 2
		} else if (legend.outside.position[1] == "bottom") {
115 2
			legy <- length(rowhs)-3 + attr.between.legend.and.map
116 2
			legx <- 5:(length(colws)-3)
117 2
		}
118
		
119 2
		if (tolower(attr.outside.position[1]) == "top") {
120 0
			attry <- 3 + attr.between.legend.and.map
121 0
			attrx <- 5:(length(colws)-3)
122 2
		} else {
123 2
			attry <- length(rowhs)-2 - attr.between.legend.and.map
124 2
			attrx <- 5:(length(colws)-3)
125 2
		}
126
		
127 2
		xlaby <- length(rowhs)-4
128 2
		xlabx <- 5:(length(colws)-3)
129
		
130 2
		ylaby <- 5:(length(rowhs)-5)
131 2
		ylabx <- 4
132
		
133 2
	})
134 2
	gm$gasp <- unname(gasp)
135 2
	gm
136
}

Read our documentation on viewing source code .

Loading