1
legend_prepare <- function(gp, gal, gt, scaleFactor) {
2

3 2
	varnames <- c("fill", "symbol.size", "symbol.col", "symbol.shape", "line.col", "line.lwd", "raster", "text.size", "text.col")
4 2
	varnames_hist <- c("fill", "symbol.col", "line.col", "raster")
5
	
6
	# todo hist: "fill_hist"
7
	# is.portrait
8
	
9 2
	if (gt$legend.show) {
10 2
		xadd <- lapply(gal, function(g) {
11 2
			type <- if(g$type=="symbol") {
12 2
				if (is.null(g$size) || length(g$size)==1) {
13 0
					"symbol.col"
14 2
				} else "symbol.size"
15 2
			} else if (g$type=="line") {
16 0
				"line.col"
17 2
			} else if (g$type=="text") {
18 0
				if (is.null(g$size) || length(g$size)==1) {
19 0
					"text.col"
20 0
				} else {
21 0
					"text.size"
22 0
				}
23 2
			} else "fill"
24
			
25 2
			nitems <- max(length(g$col), length(g$size), length(g$shape), length(g$labels), length(g$text), length(g$lwd), length(g$lty))
26
			
27 2
			revfun <- if (g$reverse) rev else function(x)x
28
			
29 2
			legend.format <- process_legend_format(g$legend.format, gt$legend.format, 1)
30
			
31 2
			legend.labels <- revfun(if (is.null(g$labels)) rep("", nitems) else rep(g$labels, length.out=nitems))
32 2
			attr(legend.labels, "align") <- legend.format$text.align
33
			
34 2
			size_ext <- ifelse(type == "text.size", 1, scaleFactor)
35
			
36 2
			list(legend.type=type,
37 2
				 legend.title=g$title,
38 2
				 legend.is.portrait=g$is.portrait,
39 2
				 legend.z=g$z,
40 2
				 legend.labels=legend.labels,
41 2
				 legend.text=revfun(if (is.null(g$text)) NULL else rep(g$text, length.out=nitems)),
42 2
				 legend.palette=revfun(if (is.null(g$col)) rep("grey50", nitems) else rep(g$col, length.out=nitems)),
43 2
				 legend.sizes=revfun(if (is.null(g$size)) 1 else rep(g$size, length.out=nitems) * size_ext),
44 2
				 legend.shapes=revfun(if (is.null(g$shape)) rep(21, nitems) else rep(g$shape, length.out=nitems)),
45 2
				 border.col=g$border.col,
46 2
				 lwd=g$border.lwd,
47 2
				 line.legend.lwd=revfun(if (is.null(g$lwd)) NULL else rep(g$lwd, length.out=nitems)),
48 2
				 line.legend.lty=revfun(if (is.null(g$lty)) NULL else rep(g$lty, length.out=nitems)),
49 2
				 symbol.border.lwd=g$border.lwd,
50 2
				 symbol.border.col=g$border.col,
51 2
				 symbol.normal.size=1,
52 2
				 symbol.max.size=if (is.null(g$size)) NULL else max(g$size)) # * scaleFactor
53 2
		})
54
		
55 2
		x <- lapply(gp, function(gpl) {
56 2
			y <- lapply(varnames, function(v) {
57 2
				if (!is.na(gpl$varnames[[v]][1])) {
58 2
					if (gpl[[paste(v, "legend.show", sep=".")]]) {
59 2
						legend.labels <- paste(v, "legend.labels", sep=".")
60 2
						legend.text <- paste(v, "legend.text", sep=".")
61 2
						legend.palette <- paste(v, "legend.palette", sep=".")
62 2
						legend.sizes <- paste(v, "legend.sizes", sep=".")
63 2
						legend.shapes <-paste(v, "legend.shapes", sep=".")
64 2
						legend.title <- paste(v, "legend.title", sep=".")
65 2
						legend.is.portrait <- paste(v, "legend.is.portrait", sep=".")
66 2
						legend.z <- paste(v, "legend.z", sep=".")
67 2
						legend.misc <- paste(v, "legend.misc", sep=".")
68 2
						list_misc <- gpl[[legend.misc]]
69 2
						if (v %in% c("symbol.col", "symbol.shape")) list_misc$symbol.max.size <- list_misc$symbol.max.size * scaleFactor
70

71 2
						size_ext <- ifelse(v == "text.size", 1, scaleFactor)
72
						
73 2
						c(list(legend.type=v,
74 2
							   legend.title=gpl[[legend.title]],
75 2
							   legend.is.portrait=gpl[[legend.is.portrait]],
76 2
							   legend.z=gpl[[legend.z]],
77 2
							   legend.labels=gpl[[legend.labels]],
78 2
							   legend.text=gpl[[legend.text]],
79 2
							   legend.palette=gpl[[legend.palette]],
80 2
							   legend.sizes=gpl[[legend.sizes]] * size_ext,
81 2
							   legend.shapes=gpl[[legend.shapes]]),
82 2
						  list_misc)
83 2
					}
84 2
				}
85 2
			})
86
			
87 2
			yhist <- lapply(varnames_hist, function(v) {
88 2
				vh <- paste(v, "hist", sep="_")
89 2
				legend.hist <- paste(v, "legend.hist", sep=".")
90
				
91 2
				if (!is.na(gpl$varnames[[v]][1])) {
92 2
					if (gpl[[legend.hist]]) {
93 0
						legend.labels <- paste(v, "legend.labels", sep=".")
94 0
						legend.palette <- paste(v, "legend.palette", sep=".")
95 0
						legend.sizes <- paste(v, "legend.sizes", sep=".")
96 0
						legend.shapes <-paste(v, "legend.shapes", sep=".")
97 0
						legend.title <- paste(v, "legend.hist.title", sep=".")
98 0
						legend.hist.z <- paste(v, "legend.hist.z", sep=".")
99 0
						legend.hist.misc <- paste(v, "legend.hist.misc", sep=".")
100 0
						list_hist_misc <- gpl[[legend.hist.misc]]
101 0
						c(list(legend.type="hist",
102 0
							   legend.title=gpl[[legend.title]],
103 0
							   legend.is.portrait=TRUE,
104 0
							 legend.z=gpl[[legend.hist.z]],
105 0
							 legend.labels=gpl[[legend.labels]],
106 0
							 legend.palette=gpl[[legend.palette]],
107 0
							 legend.sizes=gpl[[legend.sizes]] * scaleFactor,
108 0
							 legend.shapes=gpl[[legend.shapes]]),
109 0
						  list_hist_misc)
110 2
					} else NULL
111 2
				} else NULL
112 2
			})
113 2
			c(y[!vapply(y, is.null, logical(1))], yhist[!vapply(yhist, is.null, logical(1))])
114 2
		})
115
		#x <- c(x, xadd)
116
	
117 2
		legelem <- c(do.call("c", x), xadd)
118 2
	} else legelem <- list(NULL)
119
	
120 2
	if (all(vapply(legelem, is.null, logical(1)))) {
121 2
		return(NULL)
122 2
	} else {
123 2
		legelem
124 2
	}
125
}

Read our documentation on viewing source code .

Loading