Hello dear members of R-help and R-core mailing list,
I am not sure if this request is a "ticket" that should be filled
somewhere
outside the mailing list. If so, I apologize for not doing and would like
to know where I should have filled it.
And to the subject matter:
I would like to use a command like this:
plot(c(1,8), 1:2, type="n")
polygon(1:7, c(2,1,2,NA,2,1,2),
col=c("red", "blue"),
# border=c("green", "yellow"),
border=c(1,10),
lwd=c(1:10))
To create two triangles, with different line widths.
But the polygon command doesn't seem to recycle the "lwd"
parameter as it
does for the col, lty, and the border parameters.
I would like the resulting plot to look like what the following code will
produce:
plot(c(1,8), 1:2, type="n")
polygon(1:3, c(2,1,2),
col=c("red"),
# border=c("green", "yellow"),
border=c(1,10),
lwd=c(1))
polygon(5:7, c(2,1,2),
col=c( "blue"),
# border=c("green", "yellow"),
border=c(1,10),
lwd=c(10))
I opened up the polygon code to add the lwd parameter so to be used as the
lty is used.
For some reason it didn't work (I am wondering if it is because of some way
.Internal(polygon(xy$x, xy$y, col, border, lty, lwd,...)) doesn't accept
lwd...)
Here is the updates code I wrote:
polygon2 <- function (x, y = NULL, density = NULL, angle = 45, border
NULL,
col = NA, lty = par("lty"), lwd
=par("lwd") ,..., fillOddEven = FALSE)
{
..debug.hatch <- FALSE
xy <- xy.coords(x, y)
if (is.numeric(density) && all(is.na(density) | density <
0))
density <- NULL
if (!is.null(angle) && !is.null(density)) {
polygon.onehatch <- function(x, y, x0, y0, xd, yd, ..debug.hatch
FALSE,
...) {
if (..debug.hatch) {
points(x0, y0)
arrows(x0, y0, x0 + xd, y0 + yd)
}
halfplane <- as.integer(xd * (y - y0) - yd * (x -
x0) <= 0)
cross <- halfplane[-1L] - halfplane[-length(halfplane)]
does.cross <- cross != 0
if (!any(does.cross))
return()
x1 <- x[-length(x)][does.cross]
y1 <- y[-length(y)][does.cross]
x2 <- x[-1L][does.cross]
y2 <- y[-1L][does.cross]
t <- (((x1 - x0) * (y2 - y1) - (y1 - y0) * (x2 -
x1))/(xd * (y2 - y1) - yd * (x2 - x1)))
o <- order(t)
tsort <- t[o]
crossings <- cumsum(cross[does.cross][o])
if (fillOddEven)
crossings <- crossings%%2
drawline <- crossings != 0
lx <- x0 + xd * tsort
ly <- y0 + yd * tsort
lx1 <- lx[-length(lx)][drawline]
ly1 <- ly[-length(ly)][drawline]
lx2 <- lx[-1L][drawline]
ly2 <- ly[-1L][drawline]
segments(lx1, ly1, lx2, ly2, ...)
}
polygon.fullhatch <- function(x, y, density, angle, ..debug.hatch
FALSE,
...) {
x <- c(x, x[1L])
y <- c(y, y[1L])
angle <- angle%%180
if (par("xlog") || par("ylog")) {
warning("cannot hatch with logarithmic scale active")
return()
}
usr <- par("usr")
pin <- par("pin")
upi <- c(usr[2L] - usr[1L], usr[4L] - usr[3L])/pin
if (upi[1L] < 0)
angle <- 180 - angle
if (upi[2L] < 0)
angle <- 180 - angle
upi <- abs(upi)
xd <- cos(angle/180 * pi) * upi[1L]
yd <- sin(angle/180 * pi) * upi[2L]
if (angle < 45 || angle > 135) {
if (angle < 45) {
first.x <- max(x)
last.x <- min(x)
}
else {
first.x <- min(x)
last.x <- max(x)
}
y.shift <- upi[2L]/density/abs(cos(angle/180 *
pi))
x0 <- 0
y0 <- floor((min(y) - first.x * yd/xd)/y.shift) *
y.shift
y.end <- max(y) - last.x * yd/xd
while (y0 < y.end) {
polygon.onehatch(x, y, x0, y0, xd, yd, ..debug.hatch
..debug.hatch,
...)
y0 <- y0 + y.shift
}
}
else {
if (angle < 90) {
first.y <- max(y)
last.y <- min(y)
}
else {
first.y <- min(y)
last.y <- max(y)
}
x.shift <- upi[1L]/density/abs(sin(angle/180 *
pi))
x0 <- floor((min(x) - first.y * xd/yd)/x.shift) *
x.shift
y0 <- 0
x.end <- max(x) - last.y * xd/yd
while (x0 < x.end) {
polygon.onehatch(x, y, x0, y0, xd, yd, ..debug.hatch
..debug.hatch,
...)
x0 <- x0 + x.shift
}
}
}
if (missing(col) || is.null(col) || is.na(col))
col <- par("fg")
if (is.null(border))
border <- col
if (is.logical(border)) {
if (!is.na(border) && border)
border <- col
else border <- NA
}
start <- 1
ends <- c(seq_along(xy$x)[is.na(xy$x) | is.na(xy$y)],
length(xy$x) + 1)
num.polygons <- length(ends)
col <- rep(col, length.out = num.polygons)
border <- rep(border, length.out = num.polygons)
lty <- rep(lty, length.out = num.polygons)
lwd <- rep(lwd, length.out = num.polygons)
density <- rep(density, length.out = num.polygons)
angle <- rep(angle, length.out = num.polygons)
i <- 1
for (end in ends) {
if (end > start) {
den <- density[i]
if (is.na(den) || den < 0)
.Internal(polygon(xy$x[start:(end - 1)], xy$y[start:(end
-
1)], col[i], NA, lty[i],lwd[i], ...))
else if (den > 0) {
polygon.fullhatch(xy$x[start:(end - 1)], xy$y[start:(end
-
1)], col = col[i], lty = lty[i],lwd = lwd[i], density
density[i],
angle = angle[i], ..debug.hatch = ..debug.hatch,
...)
}
i <- i + 1
}
start <- end + 1
}
.Internal(polygon(xy$x, xy$y, NA, border, lty,lwd, ...))
}
else {
if (is.logical(border)) {
if (!is.na(border) && border)
border <- par("fg")
else border <- NA
}
.Internal(polygon(xy$x, xy$y, col, border, lty, lwd,...))
}
}
Thanks for any help,
Tal
----------------Contact
Details:-------------------------------------------------------
Contact me: Tal.Galili@gmail.com | 972-52-7275845
Read me: www.talgalili.com (Hebrew) | www.biostatistics.co.il (Hebrew) |
www.r-statistics.com (English)
----------------------------------------------------------------------------------------------
[[alternative HTML version deleted]]
Tal Galili
2010-Apr-30 13:13 UTC
[Rd] Request - adding recycled "lwd" parameter to polygon
Hello dear members of R-devel mailing list and Kevin Buhr (the author of
the polygon function),
After some private e-mails, I was informed this is the place to post this
feature request. I hope I am correct.
I would like to use a command like this:
plot(c(1,8), 1:2, type="n")
polygon(1:7, c(2,1,2,NA,2,1,2),
col=c("red", "blue"),
# border=c("green", "yellow"),
border=c(1,10),
lwd=c(1:10))
To create two triangles, with different line widths.
But the polygon command doesn't seem to recycle the "lwd"
parameter as it
does for the col, lty, and the border parameters.
I would like the resulting plot to look like what the following code will
produce:
plot(c(1,8), 1:2, type="n")
polygon(1:3, c(2,1,2),
col=c("red"),
# border=c("green", "yellow"),
border=c(1,10),
lwd=c(1))
polygon(5:7, c(2,1,2),
col=c( "blue"),
# border=c("green", "yellow"),
border=c(1,10),
lwd=c(10))
I opened up the polygon code to add the lwd parameter so to be used as the
lty is used.
For some reason it didn't work (I am wondering if it is because of some way
.Internal(polygon(xy$x, xy$y, col, border, lty, lwd,...)) doesn't accept
lwd...)
Here is the updates code I wrote (which, for some reason, doesn't work):
polygon2 <- function (x, y = NULL, density = NULL, angle = 45, border
NULL,
col = NA, lty = par("lty"), lwd
=par("lwd") ,..., fillOddEven = FALSE)
{
..debug.hatch <- FALSE
xy <- xy.coords(x, y)
if (is.numeric(density) && all(is.na(density) | density <
0))
density <- NULL
if (!is.null(angle) && !is.null(density)) {
polygon.onehatch <- function(x, y, x0, y0, xd, yd, ..debug.hatch
FALSE,
...) {
if (..debug.hatch) {
points(x0, y0)
arrows(x0, y0, x0 + xd, y0 + yd)
}
halfplane <- as.integer(xd * (y - y0) - yd * (x -
x0) <= 0)
cross <- halfplane[-1L] - halfplane[-length(halfplane)]
does.cross <- cross != 0
if (!any(does.cross))
return()
x1 <- x[-length(x)][does.cross]
y1 <- y[-length(y)][does.cross]
x2 <- x[-1L][does.cross]
y2 <- y[-1L][does.cross]
t <- (((x1 - x0) * (y2 - y1) - (y1 - y0) * (x2 -
x1))/(xd * (y2 - y1) - yd * (x2 - x1)))
o <- order(t)
tsort <- t[o]
crossings <- cumsum(cross[does.cross][o])
if (fillOddEven)
crossings <- crossings%%2
drawline <- crossings != 0
lx <- x0 + xd * tsort
ly <- y0 + yd * tsort
lx1 <- lx[-length(lx)][drawline]
ly1 <- ly[-length(ly)][drawline]
lx2 <- lx[-1L][drawline]
ly2 <- ly[-1L][drawline]
segments(lx1, ly1, lx2, ly2, ...)
}
polygon.fullhatch <- function(x, y, density, angle, ..debug.hatch
FALSE,
...) {
x <- c(x, x[1L])
y <- c(y, y[1L])
angle <- angle%%180
if (par("xlog") || par("ylog")) {
warning("cannot hatch with logarithmic scale active")
return()
}
usr <- par("usr")
pin <- par("pin")
upi <- c(usr[2L] - usr[1L], usr[4L] - usr[3L])/pin
if (upi[1L] < 0)
angle <- 180 - angle
if (upi[2L] < 0)
angle <- 180 - angle
upi <- abs(upi)
xd <- cos(angle/180 * pi) * upi[1L]
yd <- sin(angle/180 * pi) * upi[2L]
if (angle < 45 || angle > 135) {
if (angle < 45) {
first.x <- max(x)
last.x <- min(x)
}
else {
first.x <- min(x)
last.x <- max(x)
}
y.shift <- upi[2L]/density/abs(cos(angle/180 *
pi))
x0 <- 0
y0 <- floor((min(y) - first.x * yd/xd)/y.shift) *
y.shift
y.end <- max(y) - last.x * yd/xd
while (y0 < y.end) {
polygon.onehatch(x, y, x0, y0, xd, yd, ..debug.hatch
..debug.hatch,
...)
y0 <- y0 + y.shift
}
}
else {
if (angle < 90) {
first.y <- max(y)
last.y <- min(y)
}
else {
first.y <- min(y)
last.y <- max(y)
}
x.shift <- upi[1L]/density/abs(sin(angle/180 *
pi))
x0 <- floor((min(x) - first.y * xd/yd)/x.shift) *
x.shift
y0 <- 0
x.end <- max(x) - last.y * xd/yd
while (x0 < x.end) {
polygon.onehatch(x, y, x0, y0, xd, yd, ..debug.hatch
..debug.hatch,
...)
x0 <- x0 + x.shift
}
}
}
if (missing(col) || is.null(col) || is.na(col))
col <- par("fg")
if (is.null(border))
border <- col
if (is.logical(border)) {
if (!is.na(border) && border)
border <- col
else border <- NA
}
start <- 1
ends <- c(seq_along(xy$x)[is.na(xy$x) | is.na(xy$y)],
length(xy$x) + 1)
num.polygons <- length(ends)
col <- rep(col, length.out = num.polygons)
border <- rep(border, length.out = num.polygons)
lty <- rep(lty, length.out = num.polygons)
lwd <- rep(lwd, length.out = num.polygons)
density <- rep(density, length.out = num.polygons)
angle <- rep(angle, length.out = num.polygons)
i <- 1
for (end in ends) {
if (end > start) {
den <- density[i]
if (is.na(den) || den < 0)
.Internal(polygon(xy$x[start:(end - 1)], xy$y[start:(end
-
1)], col[i], NA, lty[i],lwd[i], ...))
else if (den > 0) {
polygon.fullhatch(xy$x[start:(end - 1)], xy$y[start:(end
-
1)], col = col[i], lty = lty[i],lwd = lwd[i], density
density[i],
angle = angle[i], ..debug.hatch = ..debug.hatch,
...)
}
i <- i + 1
}
start <- end + 1
}
.Internal(polygon(xy$x, xy$y, NA, border, lty,lwd, ...))
}
else {
if (is.logical(border)) {
if (!is.na(border) && border)
border <- par("fg")
else border <- NA
}
.Internal(polygon(xy$x, xy$y, col, border, lty, lwd,...))
}
}
Thanks for any help,
Tal
----------------Contact
Details:-------------------------------------------------------
Contact me: Tal.Galili@gmail.com | 972-52-7275845
Read me: www.talgalili.com (Hebrew) | www.biostatistics.co.il (Hebrew) |
www.r-statistics.com (English)
----------------------------------------------------------------------------------------------
[[alternative HTML version deleted]]