1# File src/library/graphics/R/polygon.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright 1995-2016 The R Core Team 5# In part (C) 2001 Kevin Buhr 6# 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 2 of the License, or 10# (at your option) any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# A copy of the GNU General Public License is available at 18# https://www.R-project.org/Licenses/ 19 20### polyhatch - a pure R implementation of polygon hatching 21### Copyright (C) 2001 Kevin Buhr 22### Provided to the R project for release under GPL. 23### Original nice clean structure destroyed by Ross Ihaka 24 25polygon <- 26 function(x, y = NULL, density = NULL, angle = 45, 27 border = NULL, col = NA, lty = par("lty"), ..., fillOddEven=FALSE) 28{ 29 ## FIXME: remove this eventually 30 ..debug.hatch <- FALSE 31 ##-- FIXME: what if `log' is active, for x or y? 32 xy <- xy.coords(x, y, setLab = FALSE) 33 34 if (is.numeric(density) && all(is.na(density) | density < 0)) 35 density <- NULL 36 if (!is.null(angle) && !is.null(density)) { 37 38 ## hatch helper functions 39 40 polygon.onehatch <- 41 function(x, y, x0, y0, xd, yd, ..debug.hatch = FALSE, ...) 42 { 43 ## draw the intersection of one line with polygon 44 ## 45 ## x,y - points of polygon (MUST have first and last points equal) 46 ## x0,y0 - origin of line 47 ## xd,yd - vector giving direction of line 48 ## ... - other parameters to pass to "segments" 49 50 if (..debug.hatch) { 51 points(x0, y0) 52 arrows(x0, y0, x0 + xd, y0 + yd) 53 } 54 55 ## halfplane[i] is 0 or 1 as (x[i], y[i]) lies in left or right 56 ## half-plane of the line 57 58 halfplane <- as.integer(xd * (y - y0) - yd * (x - x0) <= 0) 59 60 ## cross[i] is -1,0, or 1 as segment (x[i], y[i]) -- (x[i+1], y[i+1]) 61 ## crosses right-to-left, doesn't cross, or crosses left-to-right 62 63 cross <- halfplane[-1L] - halfplane[-length(halfplane)] 64 does.cross <- cross != 0 65 if (!any(does.cross)) return() # nothing to draw? 66 67 ## calculate where crossings occur 68 69 x1 <- x[-length(x)][does.cross]; y1 <- y[-length(y)][does.cross] 70 x2 <- x[-1L][does.cross]; y2 <- y[-1L][does.cross] 71 72 ## t[i] is "timepoint" on line at which segment (x1, y1)--(x2, y2) 73 ## crosses such that (x0,y0) + t*(xd,yd) is point of intersection 74 75 t <- (((x1 - x0) * (y2 - y1) - (y1 - y0) * (x2 - x1))/ 76 (xd * (y2 - y1) - yd * (x2 - x1))) 77 78 ## sort timepoints along line 79 80 o <- order(t) 81 tsort <- t[o] 82 83 ## we draw the part of line from t[i] to t[i+1] whenever it lies 84 ## "inside" the polygon --- the definition of this depends on 85 ## fillOddEven: if FALSE, we crossed 86 ## unequal numbers of left-to-right and right-to-left polygon 87 ## segments to get there. if TRUE, an odd number of crossings. 88 ## 89 90 crossings <- cumsum(cross[does.cross][o]) 91 if (fillOddEven) crossings <- crossings %% 2 92 drawline <- crossings != 0 93 94 ## draw those segments 95 96 lx <- x0 + xd * tsort 97 ly <- y0 + yd * tsort 98 lx1 <- lx[-length(lx)][drawline]; ly1 <- ly[-length(ly)][drawline] 99 lx2 <- lx[-1L][drawline]; ly2 <- ly[-1L][drawline] 100 segments(lx1, ly1, lx2, ly2, ...) 101 } 102 103 polygon.fullhatch <- 104 function(x, y, density, angle, ..debug.hatch = FALSE, ...) 105 { 106 ## draw the hatching for a given polygon 107 ## 108 ## x,y - points of polygon (need not have first and last points 109 ## equal, but no NAs are allowed) 110 ## density,angle - of hatching 111 ## ... - other parameters to pass to "segments" 112 113 x <- c(x, x[1L]) 114 y <- c(y, y[1L]) 115 angle <- angle %% 180 116 117 if (par("xlog") || par("ylog")) { 118 warning("cannot hatch with logarithmic scale active") 119 return() 120 } 121 usr <- par("usr"); pin <- par("pin") 122 123 ## usr coords per inch 124 125 upi <- c(usr[2L] - usr[1L], usr[4L] - usr[3L]) / pin 126 127 ## handle "flipped" usr coords 128 129 if (upi[1L] < 0) angle <- 180 - angle 130 if (upi[2L] < 0) angle <- 180 - angle 131 upi <- abs(upi) 132 133 ## usr-coords direction vector for hatching 134 135 xd <- cos(angle / 180 * pi) * upi[1L] 136 yd <- sin(angle / 180 * pi) * upi[2L] 137 138 ## to generate candidate hatching lines for polygon.onehatch, 139 ## we generate those lines necessary to cover the rectangle 140 ## (min(x),min(y)) to (max(x),max(y)) depending on the 141 ## hatching angle 142 143 ## (Note: We choose hatch line origins such that the hatching, 144 ## if extended outside polygon, would pass through usr-coordinate 145 ## origin. This ensures that all hatching with same density, 146 ## angle in figure will be aligned.) 147 148 if (angle < 45 || angle > 135) { 149 150 ## first.x and last.x are x-coords of first and last points 151 ## of rectangle to hit, as y-coord moves from bottom up 152 153 if (angle < 45) { 154 first.x <- max(x) 155 last.x <- min(x) 156 } 157 else { 158 first.x <- min(x) 159 last.x <- max(x) 160 } 161 162 ## y.shift is vertical shift between parallel hatching lines 163 164 y.shift <- upi[2L] / density / abs(cos(angle / 180 * pi)) 165 166 ## choose line origin (of first line) to align hatching 167 ## with usr origin 168 169 x0 <- 0 170 y0 <- floor((min(y) - first.x * yd / xd) / y.shift) * y.shift 171 172 ## line origins above y.end won't hit figure 173 174 y.end <- max(y) - last.x * yd / xd 175 176 ## hatch against all candidate lines 177 178 while (y0 < y.end) { 179 polygon.onehatch(x, y, x0, y0, xd, yd, 180 ..debug.hatch=..debug.hatch,...) 181 y0 <- y0 + y.shift 182 } 183 } 184 else { 185 ## first.y, last.y are y-coords of first and last points 186 ## of rectangle to hit, as x-coord moves from left to right 187 188 if (angle < 90) { 189 first.y <- max(y) 190 last.y <- min(y) 191 } 192 else { 193 first.y <- min(y) 194 last.y <- max(y) 195 } 196 197 ## x.shift is horizontal shift between parallel hatching lines 198 199 x.shift <- upi[1L] / density / abs(sin(angle / 180 * pi)) 200 201 ## choose line origin to align with usr origin 202 203 x0 <- floor((min(x) - first.y * xd / yd) / x.shift) * x.shift 204 y0 <- 0 205 206 ## line origins to right of x.end won't hit figure 207 208 x.end <- max(x) - last.y * xd / yd 209 210 ## hatch! 211 212 while (x0 < x.end) { 213 polygon.onehatch(x, y, x0, y0, xd, yd, 214 ..debug.hatch=..debug.hatch,...) 215 x0 <- x0 + x.shift 216 } 217 } 218 } 219 220 ## end of hatch helper functions 221 222 223 if (missing(col) || is.null(col)) { 224 col <- par("fg") 225 } else if (any(is.na(col))) { 226 col[is.na(col)] <- par("fg") 227 } 228 if (is.null(border)) border <- col 229 if (is.logical(border)) { 230 if (!is.na(border) && border) border <- col 231 else border <- NA 232 } 233 234 ## process multiple polygons separated by NAs 235 236 start <- 1 237 ends <- c(seq_along(xy$x)[is.na(xy$x) | is.na(xy$y)], length(xy$x) + 1) 238 239 num.polygons <- length(ends) 240 col <- rep_len(col, num.polygons) 241 if(length(border)) 242 border <- rep_len(border, num.polygons) 243 if(length(lty)) 244 lty <- rep_len(lty, num.polygons) 245 if(length(density)) 246 density <- rep_len(density, num.polygons) 247 angle <- rep_len(angle, num.polygons) 248 249 i <- 1L 250 for (end in ends) { 251 if (end > start) { 252 if(is.null(density) || is.na(density[i]) || density[i] < 0) 253 .External.graphics(C_polygon, xy$x[start:(end - 1)], 254 xy$y[start:(end - 1)], 255 col[i], NA, lty[i], ...) 256 else if (density[i] > 0) { 257 258 ## note: if col[i]==NA, "segments" will fill with par("fg") 259 260 polygon.fullhatch(xy$x[start:(end - 1)], 261 xy$y[start:(end - 1)], 262 col = col[i], lty = lty[i], 263 density = density[i], 264 angle = angle[i], 265 ..debug.hatch = ..debug.hatch, ...) 266 } 267 268 ## compatible with C_polygon: 269 ## only cycle through col, lty, etc. on non-empty polygons 270 i <- i + 1 271 } 272 start <- end + 1 273 } 274 .External.graphics(C_polygon, xy$x, xy$y, NA, border, lty, ...) 275 } 276 else { 277 if (is.logical(border)) { 278 if (!is.na(border) && border) border <- par("fg") 279 else border <- NA 280 } 281 .External.graphics(C_polygon, xy$x, xy$y, col, border, lty, ...) 282 } 283 invisible() 284} 285 286xspline <- 287 function(x, y = NULL, shape = 0, open = TRUE, repEnds = TRUE, 288 draw = TRUE, border = par("fg"), col = NA, ...) 289{ 290 xy <- xy.coords(x, y, setLab = FALSE) 291 s <- rep.int(shape, length(xy$x)) 292 if(open) s[1L] <- s[length(x)] <- 0 293 invisible(.External.graphics(C_xspline, xy$x, xy$y, s, open, repEnds, 294 draw, col, border, ...)) 295} 296 297polypath <- 298 function(x, y = NULL, 299 border = NULL, col = NA, lty = par("lty"), 300 rule = "winding", ...) 301{ 302 xy <- xy.coords(x, y, setLab = FALSE) 303 if (is.logical(border)) { 304 if (!is.na(border) && border) border <- par("fg") 305 else border <- NA 306 } 307 rule <- match(rule, c("winding", "evenodd")) 308 if (is.na(rule)) 309 stop("Invalid fill rule for graphics path") 310 # Determine path components 311 breaks <- which(is.na(xy$x) | is.na(xy$y)) 312 if (length(breaks) == 0) { # Only one path 313 .External.graphics(C_path, xy$x, xy$y, 314 as.integer(length(xy$x)), as.integer(rule), 315 col, border, lty, ...) 316 } else { 317 nb <- length(breaks) 318 lengths <- c(breaks[1] - 1, 319 diff(breaks) - 1, 320 length(xy$x) - breaks[nb]) 321 .External.graphics(C_path, xy$x[-breaks], xy$y[-breaks], 322 as.integer(lengths), as.integer(rule), 323 col, border, lty, ...) 324 } 325 invisible() 326} 327 328