1
2.get_breaks <- function(x, n, method, r=NULL) {
3	if (is.function(method)) {
4		if (!is.null(r)) {
5			x[x<r[1] | x>r[2]] <- NA
6		}
7		breaks <- method(x)
8	} else if (method=="cases") {
9		if (!is.null(r)) {
10			x[x<r[1] | x>r[2]] <- NA
11		}
12		n <- n+1
13		i <- seq(0, 1, length.out=n)
14		breaks <- quantile(x, i, na.rm=TRUE)
15		if ((breaks[1] %% 1) != 0) {
16			breaks[1] <- breaks[1] - 0.000001
17		}
18		if ((breaks[n] %% 1) != 0) {
19			breaks[n] <- breaks[n] + 0.000001
20		}
21	} else { # if (method=="eqint") {
22		if (is.null(r)) {
23			r <- c(min(x, na.rm=TRUE), max(x, na.rm=TRUE))
24		}
25		if ((r[1] %% 1) != 0) { r[1] <- r[1] - 0.00001 }
26		if ((r[2] %% 1) != 0) { r[2] <- r[2] + 0.00001 }
27		breaks <- seq(r[1] , r[2], length.out=n+1)
28	}
29	breaks
30}
31
32.get_nrnc <- function(nr, nc, nl) {
33	if (missing(nc)) {
34		nc <- ceiling(sqrt(nl))
35	} else {
36		nc <- max(1, min(nl, round(nc)))
37	}
38	if (missing(nr)) {
39		nr <- ceiling(nl / nc)
40	} else {
41		nr <- max(1, min(nl, round(nr)))
42		nc <- ceiling(nl / nr)
43	}
44	c(nr, nc)
45}
46
47
48.plot.axes <- function(x) {
49	if (is.null(x$axs$cex)) {
50		x$axs$cex.axis = 0.75
51	}
52	if (is.null(x$axs$mgp)) {
53		x$axs$mgp = c(2, .5, 0)
54	}
55	if (!is.null(x$axs$sides)) {
56		if (x$axs$sides[1] > 0) {
57			usr <- graphics::par("usr")
58			sides <- x$axs$sides
59			x$axs$sides <- NULL
60			sides <- round(unique(sides))
61			sides[sides > 1 & sides < 5]
62			for (s in sides) {
63				if (s %in% c(1,3)) {
64					ur <- usr[2] - usr[1]
65					at <- c(usr[1]-10*ur, usr[2]+10*ur)
66				} else {
67					ur <- usr[4] - usr[3]
68					at <- c(usr[3]-10*ur, usr[4]+10*ur)
69				}
70				graphics::axis(s, at=at, labels=c("",""), lwd.ticks=0,
71					cex.axis=x$axs$cex.axis, mgp=x$axis$mgp)
72				x$axs$side <- s
73				do.call(graphics::axis, x$axs)
74			}
75			x$axs$sides <- x$sides
76		}
77	} else {
78		x$axs$side <- 1
79		do.call(graphics::axis, x$axs)
80		x$axs$side <- 2
81		do.call(graphics::axis, x$axs)
82		graphics::box()
83	}
84	x$axs$side <- NULL
85	x
86}
87
88
89.get.leg.coords <- function(x) {
90
91	if (is.null(x$leg$ext)) {
92		ext <- unlist(x$ext)
93		xmin <- x$ext[1]
94		xmax <- x$ext[2]
95		ymin <- x$ext[3]
96		ymax <- x$ext[4]
97	} else {
98		p <- as.vector(x$leg$ext)
99		xmin <- p[1]
100		xmax <- p[2]
101		ymin <- p[3]
102		ymax <- p[4]
103		#ymin <- max(ymin, ext["ymin"])
104		#ymax <- min(ymax, ext["ymax"])
105	}
106
107	if (is.null(x$leg$shrink)) {
108		leg.shrink <- c(0,0)
109	} else {
110		leg.shrink <- rep_len(x$leg$shrink,2)
111	}
112	if (!is.null(x$leg$main)) {
113		n <- length(x$leg$main)
114		leg.shrink[2] <- max(x$leg$shrink[2], (.05*n))
115	}
116
117	yd <- ymax - ymin
118	ymin <- ymin + yd * leg.shrink[1]
119	ymax <- ymax - yd * leg.shrink[2]
120    dx <- xmax - xmin
121	dy <- ymax - ymin
122
123	x$leg$ext <- data.frame(xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax, dx=dx, dy=dy)
124	x
125}
126
127
128.line.usr <- function(line, side) {
129## https://stackoverflow.com/questions/30765866/get-margin-line-locations-in-log-space/30835971#30835971
130
131	lh <- graphics::par("cin")[2] * graphics::par("cex") * graphics::par("lheight")
132	x_off <- diff(graphics::grconvertX(c(0, lh), "inches", "npc"))
133	y_off <- diff(graphics::grconvertY(c(0, lh), "inches", "npc"))
134	if (side == 1) {
135		graphics::grconvertY(-line * y_off, "npc", "user")
136	} else if (side ==2) {
137		graphics::grconvertX(-line * x_off, "npc", "user")
138	} else if (side ==3) {
139		graphics::grconvertY(1 + line * y_off, "npc", "user")
140	} else {
141		graphics::grconvertX(1 + line * x_off, "npc", "user")
142	}
143}
144
145.get.leg.extent <- function(x) {
146	usr <- graphics::par("usr")
147	dxy <- graphics::par("cxy") * graphics::par("cex")
148	loc <- x$leg$loc
149	p <- NULL
150	if (is.character(loc)) {
151		if (loc == "right") {
152			p <- c(usr[2]+dxy[1], usr[2]+2*dxy[1], usr[3], usr[4])
153		} else if (loc == "left") {
154			s <- .line.usr(trunc(graphics::par("mar")[2]), 2)
155			p <- c(s+4*dxy[1], s+5*dxy[1], usr[3], usr[4])
156		} else if (loc == "bottom") {
157			s <- .line.usr(trunc(graphics::par("mar")[1]), 1)
158			p <- c(usr[1], usr[2], s+2*dxy[2], s+3*dxy[2])
159		} else if (loc == "top") {
160			p <- c(usr[1], usr[2], usr[4]+dxy[2], usr[4]+2*dxy[2])
161		} else {
162			warn("plot", "invalid legend location:", loc)
163			p <- c(usr[1], usr[2], usr[4]+dxy[2], usr[4]+2*dxy[2])
164		}
165	}
166	x$leg$ext <- p
167	x$leg$user <- FALSE
168	.get.leg.coords(x)
169}
170
171
172
173
174
175.leg.main <- function(x) {
176	leg <- x$leg
177    if (!is.null(leg$title)) {
178		e <- leg$ext
179		n <- length(leg$title)
180		ymax <- e$ymax + 0.05 * e$dy
181
182		for (i in 1:n) {
183			if (x$leg$loc == "right") {
184				text(x=e$xmax, y=ymax+(n-i)*0.05* e$dy,
185					labels = leg$title[i], cex = leg$title.cex, xpd=TRUE)
186			} else if (x$leg$loc == "left") {
187				text(x=e$xmin, y=ymax+(n-i)*0.05* e$dy,
188					labels = leg$title[i], cex = leg$title.cex, xpd=TRUE)
189			} else {
190				ymax <- e$ymax + 2*e$dy
191				text(x=(e$xmin+e$xmax)/2, y=ymax+(n-i)*0.05* e$dy,
192					labels = leg$title[i], cex = leg$title.cex, xpd=TRUE)
193			}
194		}
195	}
196	x
197}
198
199
200.plot.cont.legend <- function(x, ...) {
201
202	if (is.null(x$leg$ext)) {
203		x <- .get.leg.extent(x)
204	} else {
205		x <- .get.leg.coords(x)
206	}
207
208	cex <- x$leg$cex
209	if (is.null(cex)) cex <- 0.8
210
211	cols <- rev(x$cols)
212	nc <- length(cols)
213
214	zlim <- x$range
215	zz <- x$leg$at
216	if (is.null(zz)) {
217		if (is.null(x$levels)){
218			x$levels <- 5
219		}
220		zz <- pretty(zlim, n =(x$levels+1))
221		zz <- zz[zz >= zlim[1] & zz <= zlim[2]]
222	}
223	zztxt <- x$leg$labels
224	if (is.null(zztxt)) {
225		zztxt <- formatC(zz, digits=x$leg$digits, format = "f")
226	}
227	e <- x$leg$ext
228	if (x$leg$loc %in% c("left", "right")) {
229		Y <- seq(e$ymin, e$ymax, length.out=nc+1)
230		graphics::rect(e$xmin, Y[-(nc + 1)], e$xmax, Y[-1], col=rev(cols), border=NA, xpd=NA)
231		ypos <- e$ymin + (zz - zlim[1])/(zlim[2] - zlim[1]) * e$dy
232		if (x$leg$loc == "right") {
233			graphics::segments(e$xmin, ypos, e$xmax+e$dx*0.25, ypos, xpd=NA)
234			text(e$xmax, ypos, zztxt, pos=4, xpd=NA, cex=cex, ...)
235		} else {
236			graphics::segments(e$xmin-e$dx*0.25, ypos, e$xmax, ypos, xpd=NA)
237			text(e$xmin, ypos, zztxt, pos=2, xpd=NA, cex=cex, ...)
238		}
239	} else {
240		X <- seq(e$xmin, e$xmax, length.out=nc+1)
241		graphics::rect(X[-(nc + 1)], e$ymin, X[-1], e$ymax, col=rev(cols), border=NA, xpd=NA)
242		xpos <- e$xmin + (zz - zlim[1])/(zlim[2] - zlim[1]) * e$dx
243		if (x$leg$loc == "bottom") {
244			graphics::segments(xpos, e$ymin-e$dy*0.25, xpos, e$ymax, xpd=NA)
245			text(xpos, e$ymin, zztxt, pos=1, xpd=NA, cex=cex)
246		} else {
247			graphics::segments(xpos, e$ymin, xpos, e$ymax+e$dy*0.25, xpd=NA)
248			text(xpos, e$ymax+e$dy*0.25, zztxt, pos=3, xpd=NA, cex=cex)
249		}
250	}
251	graphics::rect(e$xmin, e$ymin, e$xmax, e$ymax, border ="black", xpd=NA)
252
253	x$leg.main <- .leg.main(x)
254	x
255}
256
257
258.plot.class.legend <- function(x, y, legend, fill, xpd=TRUE, cex=0.8, geomtype="",
259	lty=1, lwd=1, pch=1, angle=45, density=NULL,
260	pt.cex = 1, pt.bg="black", pt.lwd=1, bty="n", border="black", seg.len=1,
261# catching
262	merge, trace,...) {
263
264	if (x == "top") {
265		usr <- graphics::par("usr")
266		x <- usr[c(2)]
267		y <- usr[c(4)]
268	}
269	if (grepl("points", geomtype)) {
270		leg <- legend(x, y, legend, col=fill, xpd=xpd, bty=bty, cex=cex, pch=pch,
271		pt.cex=pt.cex, pt.bg=pt.bg, pt.lwd=pt.lwd, ...)
272	} else if (geomtype == "lines") {
273		leg <- legend(x, y, legend, col=fill, xpd=xpd, bty=bty, cex=cex, lty=lty, lwd=lwd, seg.len=seg.len, ...)
274	} else {
275		leg <- legend(x, y, legend, fill=fill, xpd=xpd, bty=bty, cex=cex, density=density*2, angle=angle, border=border, ...)
276	}
277}
278
279