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