|
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
|
|
}
|
mtennekes