R function to plot inequalities with shading - r

Suppose I have a set of inequalities:
-2x + y <= -3
1.25x + y <= 2.5
y >= -3
And I can summarize the information as follows:
mat <- matrix(c(-2, 1, 1.25, 1, 0, 1), nrow = 3, byrow = TRUE)
dir <- c("<=", "<=", ">=")
rhs <- c(-3, 2.5, -3)
I wrote the following function to plot the inequalities:
plot(0, 0, xlim = c(-1, 5), ylim = c(-4, 1))
plot_ineq <- function(mat, dir, rhs, xlow, xhigh){
line <- list()
for(i in 1:nrow(mat)){
if(mat[i, 2] > 0){
line[[i]] <- sapply(seq(xlow, xhigh, 0.1), function(x) (rhs[i] - mat[i, 1] * x)/mat[i, 2])
}else if(mat[i, 2] < 0){
line[[i]] <- sapply(seq(xlow, xhigh, 0.1), function(x) (rhs[i] - mat[i, 1] * x)/mat[i, 2])
if(dir[i] == ">="){
dir[i] = "<="
}else dir[i] = ">="
}
lines(seq(xlow, xhigh, 0.1), line[[i]])
}
}
plot_ineq(mat = mat, dir = dir, rhs = rhs, xlow = -1, xhigh = 5)
I have two questions: (1) how can I have a blank plot without having the (0, 0) point there? and (2) how can I shade the corresponding region according to dir? Should I try ggplot2?
I'm simply looking to shade the area that is described by the set of inequalities above. Not where (0, 0) lies.

1) Change the last inequality to be the same direction as the others and then use plotPolytope in gMOIP.
library(gMOIP)
mat <- matrix(c(-2, 1, 1.25, 1, 0, -1), nrow = 3, byrow = TRUE)
rhs <- c(-3, 2.5, 3)
argsFaces <- list(argsGeom_polygon = list(fill = "blue"))
plotPolytope(mat, rhs, argsFaces = argsFaces)
giving (continued after image)
2) The above uses ggplot2 graphics but if you prefer classic graphics then using mat and rhs from above:
library(gMOIP)
cp <- cornerPoints(mat, rhs)
cp <- cp[chull(cp), ] # chull gives indices of convex hull in order
plot(cp, type = "n")
polygon(cp, col = "blue")
# not shown but to add lines run this too
for(i in 1:nrow(cp)) {
ix <- if (i < nrow(cp)) i + 0:1 else c(i, 1)
b <- diff(cp[ix, 2]) / (d <- diff(cp[ix, 1]))
if (abs(d) < 1e-5) abline(v = a <- cp[i, 1])
else abline(a = a <- cp[i, 2] - b * cp[i, 1], b = b)
}
giving (continued after image)
3) Note that there is an archived package named intpoint on CRAN and it could be used to draw the boundary of the feasible region and lines. It does have the limitation that it is hard coded to show X and Y axes between -1 and 5 although it might not be hard to generalize it. It is used like this (output not shown) where mat, rhs and cp are from above.
library(intpoint)
intpoint:::show2d(mat, rhs, c = numeric(2))
polygon(cp, col = "blue")

Related

Solutions to a system of inequalities in R

Suppose I have the following system of inequalities:
-2x + y <= -3
1.25x + y <= 2.5
y >= -3
I want to find multiple tuples of (x, y) that satisfy the above inequalities.
library(Rglpk)
obj <- numeric(2)
mat <- matrix(c(-2, 1, 1.25, 1, 0, 1), nrow = 3)
dir <- c("<=", "<=", ">=")
rhs <- c(-3, 2.5, -3)
Rglpk_solve_LP(obj = obj, mat = mat, dir = dir, rhs = rhs)
Using the above code only seems to return 1 possible solution tuple (1.5, 0). Is possible to return other solution tuples?
Edit: Based on the comments, I would be interested to learn if there are any functions that could help me find the corner points.
Actually to understand the possible answers for the given question we can try to solve the system of inequalities graphically.
There was a nice answer concerning plotting of inequations in R at stackowerflow. Using the given aproach we can plot the following graph:
library(ggplot2)
fun1 <- function(x) 2*x - 3 # this is the same as -2x + y <= -3
fun2 <- function(x) -1.25*x + 2.5 # 1.25x + y <= 2.5
fun3 <- function(x) -3 # y >= -3
x1 = seq(-1,5, by = 1/16)
mydf = data.frame(x1, y1=fun1(x1), y2=fun2(x1),y3= fun3(x1))
mydf <- transform(mydf, z = pmax(y3,pmin(y1,y2)))
ggplot(mydf, aes(x = x1)) +
geom_line(aes(y = y1), colour = 'blue') +
geom_line(aes(y = y2), colour = 'green') +
geom_line(aes(y = y3), colour = 'red') +
geom_ribbon(aes(ymin=y3,ymax = z), fill = 'gray60')
All the possible (infinite by number) tuples lie inside the gray triangle.
The vertexes can be found using the following code.
obj <- numeric(2)
mat <- matrix(c(-2, 1.25, 1, 1), nrow = 2)
rhs <- matrix(c(-3, 2.5), nrow = 2)
aPoint <- solve(mat, rhs)
mat <- matrix(c(-2, 0, 1, 1), nrow = 2)
rhs <- matrix(c(-3, -3), nrow = 2)
bPoint <- solve(mat, rhs)
mat <- matrix(c(1.25, 0, 1, 1), nrow = 2)
rhs <- matrix(c(2.5, -3), nrow = 2)
cPoint <- solve(mat, rhs)
Note the order of arguments of matrices.
And you get the coordinates:
> aPoint
[,1]
[1,] 1.6923077
[2,] 0.3846154
> bPoint
[,1]
[1,] 0
[2,] -3
> cPoint
[,1]
[1,] 4.4
[2,] -3.0
All the codes below are with base R only (no need library(Rglpk))
1. Corner Points
If you want to get all the corner points, here is one option
A <- matrix(c(-2, 1.25, 0, 1, 1, -1), nrow = 3)
b <- c(-3, 2.5, 3)
# we use `det` to check if the coefficient matrix is singular. If so, we return `Inf`.
xh <-
combn(nrow(A), 2, function(k) {
if (det(A[k, ]) == 0) {
rep(NA, length(k))
} else {
solve(A[k, ], b[k])
}
})
# We filter out the points that satisfy the constraint
corner_points <- t(xh[, colSums(A %*% xh <= b, na.rm = TRUE) == length(b)])
such that
> corner_points
[,1] [,2]
[1,] 1.692308 0.3846154
[2,] 0.000000 -3.0000000
[3,] 4.400000 -3.0000000
2. Possible Tuples
If you want to have multiple tuples, e.g., n=10, we can use Monte Carlo simulation (based on the obtained corner_points in the previous step) to select the tuples under the constraints:
xrange <- range(corner_points[, 1])
yrange <- range(corner_points[, 2])
n <- 10
res <- list()
while (length(res) < n) {
px <- runif(1, xrange[1], xrange[2])
py <- runif(1, yrange[1], yrange[2])
if (all(A %*% c(px, py) <= b)) {
res[length(res) + 1] <- list(c(px, py))
}
}
and you will see n possible tuples in a list like below
> res
[[1]]
[1] 3.643167 -2.425809
[[2]]
[1] 2.039007 -2.174171
[[3]]
[1] 0.4990635 -2.3363637
[[4]]
[1] 0.6168402 -2.6736421
[[5]]
[1] 3.687389 -2.661733
[[6]]
[1] 3.852258 -2.704395
[[7]]
[1] 1.7571062 0.1067597
[[8]]
[1] 3.668024 -2.771307
[[9]]
[1] 2.108187 -1.365349
[[10]]
[1] 2.106528 -2.134310
First of all, the matrix representing the three equations needs a small correction, because R fills matrices column by column :
-2x + y <= -3
1.25x + y <= 2.5
y >= -3
mat <- matrix(c(-2, 1.25, 0, 1, 1, 1), nrow = 3
# and not : mat <- matrix(c(-2, 1, 1.25, 1, 0, 1), nrow = 3)
To get different tuples, you could modify the objective function :
obj <- numeric(2) results in an objective function 0 * x + 0 * y which is always equal to 0 and can't be maximized : the first valid x,y will be selected.
Optimization on x is achieved by using obj <- c(1,0), resulting in maximization / minimization of 1 * x + 0 * y.
Optimization on y is achieved by using obj <- c(0,1).
#setting the bounds is necessary, otherwise optimization occurs only for x>=0 and y>=0
bounds <- list(lower = list(ind = c(1L, 2L), val = c(-Inf, -Inf)),
upper = list(ind = c(1L, 2L), val = c(Inf, Inf)))
# finding maximum x: obj = c(1,0), max = T
Rglpk_solve_LP(obj = c(10,0), mat = mat, dir = dir, rhs = rhs,bound=bounds, max = T)$solution
# [1] 4.4 -3.0
# finding minimum x: obj = c(1,0), max = F
Rglpk_solve_LP(obj = c(10,0), mat = mat, dir = dir, rhs = rhs,bound=bounds, max = F)$solution
#[1] 0 -3
# finding maximum y: obj = c(0,1), max = T
Rglpk_solve_LP(obj = c(0,1), mat = mat, dir = dir, rhs = rhs,bound=bounds, max = T)$solution
#[1] 1.6923077 0.3846154

Margin for alluvial plot

I use this example
library(alluvial)
tit <- as.data.frame(Titanic)
# only two variables: class and survival status
tit2d <- aggregate( Freq ~ Class + Survived, data=tit, sum)
alluvial( tit2d[,1:2], freq=tit2d$Freq, xw=0.0, alpha=0.8,
gap.width=0.1, col= "steelblue", border="white",
layer = tit2d$Survived != "Yes" , cex.axis =8)
Pay attention I use cex.axis =8 and i get
Axis labels go beyond
I try to use par(mar=c(10, 10, 10, 10)) but no result
thanks for any idea
There is a bug in the source code of the alluvial function
The function sets par(mar=c(2,1,1,1)) hard coded so using the par() outside doesn't have any effect.
You could change locally the source code of the function to one of 2 options:
add an argument mar_ and pass the margin, and set at the right place par(mar=mar_).
just overwrite locally the line to the desired margins
I found the first option more appealing because you can then set the values from outside the function and optimise more easily.
The source code:
function (..., freq, col = "gray", border = 0, layer, hide = FALSE,
alpha = 0.5, gap.width = 0.05, xw = 0.1, cw = 0.1, blocks = TRUE,
ordering = NULL, axis_labels = NULL, cex = par("cex"), cex.axis = par("cex.axis"))
{
p <- data.frame(..., freq = freq, col, alpha, border, hide,
stringsAsFactors = FALSE)
np <- ncol(p) - 5
if (!is.null(ordering)) {
stopifnot(is.list(ordering))
if (length(ordering) != np)
stop("'ordering' argument should have ", np, " components, has ",
length(ordering))
}
n <- nrow(p)
if (missing(layer)) {
layer <- 1:n
}
p$layer <- layer
d <- p[, 1:np, drop = FALSE]
p <- p[, -c(1:np), drop = FALSE]
p$freq <- with(p, freq/sum(freq))
col <- col2rgb(p$col, alpha = TRUE)
if (!identical(alpha, FALSE)) {
col["alpha", ] <- p$alpha * 256
}
p$col <- apply(col, 2, function(x) do.call(rgb, c(as.list(x),
maxColorValue = 256)))
isch <- sapply(d, is.character)
d[isch] <- lapply(d[isch], as.factor)
if (length(blocks) == 1) {
blocks <- if (!is.na(as.logical(blocks))) {
rep(blocks, np)
}
else if (blocks == "bookends") {
c(TRUE, rep(FALSE, np - 2), TRUE)
}
}
if (is.null(axis_labels)) {
axis_labels <- names(d)
}
else {
if (length(axis_labels) != ncol(d))
stop("`axis_labels` should have length ", names(d),
", has ", length(axis_labels))
}
getp <- function(i, d, f, w = gap.width) {
a <- c(i, (1:ncol(d))[-i])
if (is.null(ordering[[i]])) {
o <- do.call(order, d[a])
}
else {
d2 <- d
d2[1] <- ordering[[i]]
o <- do.call(order, d2[a])
}
x <- c(0, cumsum(f[o])) * (1 - w)
x <- cbind(x[-length(x)], x[-1])
gap <- cumsum(c(0L, diff(as.numeric(d[o, i])) != 0))
mx <- max(gap)
if (mx == 0)
mx <- 1
gap <- gap/mx * w
(x + gap)[order(o), ]
}
dd <- lapply(seq_along(d), getp, d = d, f = p$freq)
rval <- list(endpoints = dd)
===============================================
===============Need to edit====================
op <- par(mar = c(2, 1, 1, 1))
===============================================
plot(NULL, type = "n", xlim = c(1 - cw, np + cw), ylim = c(0,
1), xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", xlab = "",
ylab = "", frame = FALSE)
ind <- which(!p$hide)[rev(order(p[!p$hide, ]$layer))]
for (i in ind) {
for (j in 1:(np - 1)) {
xspline(c(j, j, j + xw, j + 1 - xw, j + 1, j + 1,
j + 1 - xw, j + xw, j) + rep(c(cw, -cw, cw),
c(3, 4, 2)), c(dd[[j]][i, c(1, 2, 2)], rev(dd[[j +
1]][i, c(1, 1, 2, 2)]), dd[[j]][i, c(1, 1)]),
shape = c(0, 0, 1, 1, 0, 0, 1, 1, 0, 0), open = FALSE,
col = p$col[i], border = p$border[i])
}
}
for (j in seq_along(dd)) {
ax <- lapply(split(dd[[j]], d[, j]), range)
if (blocks[j]) {
for (k in seq_along(ax)) {
rect(j - cw, ax[[k]][1], j + cw, ax[[k]][2])
}
}
else {
for (i in ind) {
x <- j + c(-1, 1) * cw
y <- t(dd[[j]][c(i, i), ])
w <- xw * (x[2] - x[1])
xspline(x = c(x[1], x[1], x[1] + w, x[2] - w,
x[2], x[2], x[2] - w, x[1] + w, x[1]), y = c(y[c(1,
2, 2), 1], y[c(2, 2, 1, 1), 2], y[c(1, 1),
1]), shape = c(0, 0, 1, 1, 0, 0, 1, 1, 0, 0),
open = FALSE, col = p$col[i], border = p$border[i])
}
}
for (k in seq_along(ax)) {
text(j, mean(ax[[k]]), labels = names(ax)[k], cex = cex)
}
}
axis(1, at = rep(c(-cw, cw), ncol(d)) + rep(seq_along(d),
each = 2), line = 0.5, col = "white", col.ticks = "black",
labels = FALSE)
axis(1, at = seq_along(d), tick = FALSE, labels = axis_labels,
cex.axis = cex.axis)
par(op)
invisible(rval)
}
I marked where the problem occur as:
================================================
==============Need to edit======================
op <- par(mar = c(2, 1, 1, 1))
================================================
After changing the line to par(mar=c(5, 5, 3, 10)) I got:

My variogram code result different from variog() result

I am writing code for producing a variogram. For validating my result, I checked with geoR::variog() but both variograms are different.
I tried to understand the code of variog() to see what happens under the hood but there are so many things happening that I can't seem to understand it. I, in my code, am using the parameters X-coordinate, Y-coordiante, data value, number of lags, minimum lag value, lag interval, azimuth (angle in degrees; 90 corresponds to vertical direction), angle tolerance (in degrees) and maximum bandwidth.
variogram = function(xcor, ycor, data, nlag, minlag, laginv, azm, atol, maxbandw){
dl <- length(data)
lowangle <- azm - atol
upangle <- azm + atol
gamlag <- integer(nlag)
n <- integer(nlag)
dist <- pairdist(xcor, ycor)
maxd <- max(dist)
llag <- seq(minlag, minlag + (nlag-1) * laginv, by = laginv)
hlag <- llag + laginv
for(i in 1:dl){
for(j in i:dl){
if(i != j){
if(xcor[j]- xcor[i] == 0)
theta <- 90
else
theta <- 180/pi * atan((ycor[j] - ycor[i])/(xcor[j] - xcor[i]))
for(k in 1:nlag){
d <- dist[j, i]
b <- abs(d * sin(theta - azm))
if((llag[k] <= d & d < hlag[k]) & (lowangle <= theta & theta < upangle) & (b <= maxbandw)){
gamlag[k] <- gamlag[k] + (data[i] - data[j])^2;
n[k] <- n[k] + 1
}
}
}
}
}
gamlag <- ifelse(n == 0, NA, gamlag/(2*n))
tmp <- data.frame("lag" = llag, "gamma" = gamlag)
return(tmp)
}
function call for the above code
ideal_variogram_2 <- variogram(data3[,1], data3[,2], data3[,3], 18, 0, 0.025, 90, 45, 1000000)
ideal_variogram_2 <- na.omit(ideal_variogram_2)
plot(ideal_variogram_2$lag, ideal_variogram_2$gamma, main = "Using my code")
function call for variog()
geodata1 <- as.geodata(data3, coords.col = 1:2, data.col = 3)
ideal_variogram_1 <- variog(geodata1, coords = geodata1$coords, data = geodata1$data, option = "bin", uvec = seq(0, 0.45, by = 0.025), direction = pi/2, tolerance = pi/4)
df <- data.frame(u = ideal_variogram_1$u, v = ideal_variogram_1$v)
plot(df$u, df$v, main = "Using variog()")
The 2 variograms that I got are at the following link:
Variogram

How to plot non-linear decision boundaries with a grid in R?

I find this particular graph in ISLR (Figure 2.13) or ESL very well done. I can't guess how the authors would have made this in R. I know how to get the orange and blue points very easily. The main confusion is the background dots and the purple line.
Any ideas?
Here is some sample code to get the yellow and orange points with a grey grid. How do I get an arbitrary non-linear curve in purple and then color the grid according to the curve?
set.seed(pi)
points = replicate(100, runif(2))
pointsColored = ifelse(apply(points, 2, sum) <= 1, "orange", "blue")
# Confound some
pointsColored[sample.int(length(pointsColored), 10)] = "orange"
plot(x=points[1, ], y=points[2, ])
grid(nx=100, ny=100)
# Plot points over the grid.
points(x=points[1, ], y=points[2, ], col=pointsColored)
As I indicated in my comment, a solution was provided by #chl here on stats.stackexchange.com. Here it is, applied to your data set.
library(class)
set.seed(pi)
X <- t(replicate(1000, runif(2)))
g <- ifelse(apply(X, 1, sum) <= 1, 0, 1)
xnew <- cbind(rep(seq(0, 1, length.out=50), 50),
rep(seq(0, 1, length.out=50), each=50))
m <- knn(X, xnew, g, k=15, prob=TRUE)
prob <- attr(m, "prob")
prob <- ifelse(m=="1", prob, 1-prob)
prob15 <- matrix(prob, 50)
par(mar=rep(3, 4))
contour(unique(xnew[, 1]), unique(xnew[, 2]), prob15, levels=0.5,
labels="", xlab='', ylab='', axes=FALSE, lwd=2.5, asp=1)
title(xlab=expression(italic('X')[1]), ylab=expression(italic('X')[2]),
line=1, family='serif', cex.lab=1.5)
points(X, bg=ifelse(g==1, "#CA002070", "#0571B070"), pch=21)
gd <- expand.grid(x=unique(xnew[, 1]), y=unique(xnew[, 2]))
points(gd, pch=20, cex=0.4, col=ifelse(prob15 > 0.5, "#CA0020", "#0571B0"))
box()
(UPDATE: I changed the colour palette because the blue/yellow/purple thing was pretty hideous.)
This was my silly attempt at approximation. Clearly the issues raised by #StephenKolassa are valid and not handled by this approximation.
myCurve1 = function (x)
abs(x[[1]] * sin(x[[1]]) + x[[2]] * sin(x[[2]]))
myCurve2 = function (x)
abs(x[[1]] * cos(x[[1]]) + x[[2]] * cos(x[[2]]))
myCurve3 = function (x)
abs(x[[1]] * tan(x[[1]]) + x[[2]] * tan(x[[2]]))
tmp = function (myCurve, seed=99) {
set.seed(seed)
points = replicate(100, runif(2))
colors = ifelse(apply(points, 2, myCurve) > 0.5, "orange", "blue")
# Confound some
swapInts = sample.int(length(colors), 6)
for (i in swapInts) {
if (colors[[i]] == "orange") {
colors[[i]] = "blue"
} else {
colors[[i]] = "orange"
}
}
gridPoints = seq(0, 1, 0.005)
gridPoints = as.matrix(expand.grid(gridPoints, gridPoints))
gridColors = vector("character", nrow(gridPoints))
gridPch = vector("character", nrow(gridPoints))
for (i in 1:nrow(gridPoints)) {
val = myCurve(gridPoints[i, ])
if (val > 0.505) {
gridColors[[i]] = "orange"
gridPch[[i]] = "."
} else if (val < 0.495) {
gridColors[[i]] = "blue"
gridPch[[i]] = "."
} else {
gridColors[[i]] = "purple"
gridPch[[i]] = "*"
}
}
plot(x=gridPoints[ , 1], y=gridPoints[ , 2], col=gridColors, pch=gridPch)
points(x=points[1, ], y=points[2, ], col=colors, lwd=2)
}
par(mfrow=c(1, 3))
tmp(myCurve1)
tmp(myCurve2)
tmp(myCurve3)

How to get the stars command to have segments of different angles ? (in R)

I am playing with the "stars" ({graphics}) function to create a segment of flowers.
I wish to plot a flower of segments, for example in way the following command will produce:
stars1(mtcars[, 1:7],
draw.segments = T,
main = "Motor Trend Cars : stars(*, full = F)", full = T, col.radius = 1:8)
But, I want the segments to not have equal angles, but smaller angles (and between the flowers there could be space).
The goal I am striving for is to be able to give each flower "weight" so that some aspects are more important (larger weight) and some are less (and thus, will have a smaller angle).
I understand this can be changes in the following part of the stars command:
if (draw.segments) {
aangl <- c(angles, if (full) 2 * pi else pi)
for (i in 1L:n.loc) {
px <- py <- numeric()
for (j in 1L:n.seg) {
k <- seq.int(from = aangl[j], to = aangl[j +
1], by = 1 * deg)
px <- c(px, xloc[i], s.x[i, j], x[i, j] * cos(k) +
xloc[i], NA)
py <- c(py, yloc[i], s.y[i, j], x[i, j] * sin(k) +
yloc[i], NA)
}
polygon(px, py, col = col.segments, lwd = lwd, lty = lty)
}
But I am unsure as to how to manipulate it in order to achieve my task (of weighted flowers, by different angles)
Do you have any perceptual justification for this change? If the weights are going to vary by star it's going to be very hard to interpret the plot.
(But it should be trivial to implement - instead of using equally distributed angles, use weights: angles <- weights / sum(weights) * 2 * pi)
I found out how to do it.
For future reference, here is the code:
# functions we'll need...
add.num.before.and.after <- function(vec, num = NULL)
{
# this will add a number before and after every number in a vector.
# the deafult adds the number which is one more then the length of the vector
# assuming that later we will add a zero column to a data.frame and will use that column to add the zero columns...
if(is.null(num)) num <- rep(length(vec) +1, length(vec))
if(length(num)==1) num <- rep(num, length(vec))
#x <- as.list(vec)
list.num.x.num <- sapply(seq_along(vec) , function(i) c(num[i], vec[i], num[i]), simplify = F)
num.x.num <- unlist(list.num.x.num)
return(num.x.num)
}
add.0.columns.to.DF <- function(DF, zero.column.name = " ")
{
# this function gets a data frame
# and returns a data.frame with extra two columns (of zeros) before and after every column
zero.column <- rep(0, dim(DF)[1]) # the column of zeros
column.seq <- seq_len(dim(DF)[2]) # the column ID for the original data.frame
DF.new.order <- add.num.before.and.after(column.seq) # add the last column id before and after every element in the column id vector
DF.and.zero <- cbind(DF, zero.column) # making a new data.frame with a zero column at the end
new.DF <- DF.and.zero[,DF.new.order] # moving the zero column (and replicating it) before and after every column in the data.frame
# renaming the zero columns to be " "
columns.to.erase.names <- ! (colnames(new.DF) %in% colnames(DF))
colnames(new.DF)[columns.to.erase.names] <- zero.column.name
return(new.DF)
}
angles.by.weight <- function(angles, weights = NULL)
{
angles <- angles[-1] # remove the 0 from "angles"
angles <- c(angles, 2*pi) # add last slice angle
number.of.slices = length(angles)
if(is.null(weights)) weights <- rep(.6, number.of.slices) # Just for the example
slice.angle <- diff(angles)[1]
#new.angles <- rep(0, 3*length(angles))
new.angles <- numeric()
for(i in seq_along(angles))
{
weighted.slice.angle <- slice.angle*weights[i]
half.leftover.weighted.slice.angle <- slice.angle* ((1-weights[i])/2)
angle1 <- angles[i] - (weighted.slice.angle + half.leftover.weighted.slice.angle)
angle2 <- angles[i] - half.leftover.weighted.slice.angle
angle3 <- angles[i]
new.angles <- c(new.angles,
angle1,angle2,angle3)
}
new.angles.length <- length(new.angles)
new.angles <- c(0, new.angles[-new.angles.length])
return(new.angles)
}
# The updated stars function
stars2 <-
function (x, full = TRUE, scale = TRUE, radius = TRUE, labels =
dimnames(x)[[1L]],
locations = NULL, nrow = NULL, ncol = NULL, len = 1, key.loc = NULL,
key.labels = dimnames(x)[[2L]], key.xpd = TRUE, xlim = NULL,
ylim = NULL, flip.labels = NULL, draw.segments = FALSE, col.segments = 1L:n.seg,
col.stars = NA, axes = FALSE, frame.plot = axes, main = NULL,
sub = NULL, xlab = "", ylab = "", cex = 0.8, lwd = 0.25,
lty = par("lty"), xpd = FALSE, mar = pmin(par("mar"), 1.1 +
c(2 * axes + (xlab != ""), 2 * axes + (ylab != ""), 1,
# 0)), add = FALSE, plot = TRUE, ...)
0)), add = FALSE, plot = TRUE, col.radius = NA, polygon = TRUE,
key.len = len,
segment.weights = NULL,
...)
{
if (is.data.frame(x))
x <- data.matrix(x)
else if (!is.matrix(x))
stop("'x' must be a matrix or a data frame")
if (!is.numeric(x))
stop("data in 'x' must be numeric")
# this code was moved here so that the angles will be proparly created...
n.seg <- ncol(x) # this will be changed to the ncol of the new x - in a few rows...
# creates the angles
angles <- if (full)
seq.int(0, 2 * pi, length.out = n.seg + 1)[-(n.seg + 1)]
else if (draw.segments)
seq.int(0, pi, length.out = n.seg + 1)[-(n.seg + 1)]
else seq.int(0, pi, length.out = n.seg)
if (length(angles) != n.seg)
stop("length of 'angles' must equal 'ncol(x)'")
# changing to allow weighted segments
angles <- angles.by.weight(angles, segment.weights)
#angles <- angles.by.weight.2(angles) # try2
# try3
# weights <- sample(c(.3,.9), length(angles)-1, replace = T)
# angles <- weights / sum(weights) * 2 * pi
# angles <- c(0,angles )
# changing to allow weighted segments
col.segments <- add.num.before.and.after(col.segments, "white") # for colors
x <- add.0.columns.to.DF(x)
n.loc <- nrow(x)
n.seg <- ncol(x)
if (is.null(locations)) {
if (is.null(nrow))
nrow <- ceiling(if (!is.numeric(ncol)) sqrt(n.loc) else n.loc/ncol)
if (is.null(ncol))
ncol <- ceiling(n.loc/nrow)
if (nrow * ncol < n.loc)
stop("nrow * ncol < number of observations")
ff <- if (!is.null(labels))
2.3
else 2.1
locations <- expand.grid(ff * 1L:ncol, ff * nrow:1)[1L:n.loc,
]
if (!is.null(labels) && (missing(flip.labels) ||
!is.logical(flip.labels)))
flip.labels <- ncol * mean(nchar(labels, type = "c")) >
30
}
else {
if (is.numeric(locations) && length(locations) == 2) {
locations <- cbind(rep.int(locations[1L], n.loc),
rep.int(locations[2L], n.loc))
if (!missing(labels) && n.loc > 1)
warning("labels do not make sense for a single location")
else labels <- NULL
}
else {
if (is.data.frame(locations))
locations <- data.matrix(locations)
if (!is.matrix(locations) || ncol(locations) != 2)
stop("'locations' must be a 2-column matrix.")
if (n.loc != nrow(locations))
stop("number of rows of 'locations' and 'x' must be equal.")
}
if (missing(flip.labels) || !is.logical(flip.labels))
flip.labels <- FALSE
}
xloc <- locations[, 1]
yloc <- locations[, 2]
# Here we created the angles, but I moved it to the beginning of the code
if (scale) {
x <- apply(x, 2L, function(x) (x - min(x, na.rm = TRUE))/diff(range(x,
na.rm = TRUE)))
}
x[is.na(x)] <- 0
mx <- max(x <- x * len)
if (is.null(xlim))
xlim <- range(xloc) + c(-mx, mx)
if (is.null(ylim))
ylim <- range(yloc) + c(-mx, mx)
deg <- pi/180
op <- par(mar = mar, xpd = xpd)
on.exit(par(op))
if (plot && !add)
plot(0, type = "n", ..., xlim = xlim, ylim = ylim, main = main,
sub = sub, xlab = xlab, ylab = ylab, asp = 1, axes = axes)
if (!plot)
return(locations)
s.x <- xloc + x * rep.int(cos(angles), rep.int(n.loc, n.seg))
s.y <- yloc + x * rep.int(sin(angles), rep.int(n.loc, n.seg))
if (draw.segments) {
aangl <- c(angles, if (full) 2 * pi else pi)
for (i in 1L:n.loc) {
px <- py <- numeric()
for (j in 1L:n.seg) {
k <- seq.int(from = aangl[j], to = aangl[j +
1], by = 1 * deg)
px <- c(px, xloc[i], s.x[i, j], x[i, j] * cos(k) +
xloc[i], NA)
py <- c(py, yloc[i], s.y[i, j], x[i, j] * sin(k) +
yloc[i], NA)
}
polygon3(px, py, col = col.segments, lwd = lwd, lty = lty)
}
}
else {
for (i in 1L:n.loc) {
# polygon3(s.x[i, ], s.y[i, ], lwd = lwd, lty = lty,
# col = col.stars[i])
if (polygon)
polygon3(s.x[i, ], s.y[i, ], lwd = lwd, lty = lty,
col = col.stars[i])
if (radius)
segments(rep.int(xloc[i], n.seg), rep.int(yloc[i],
# n.seg), s.x[i, ], s.y[i, ], lwd = lwd, lty = lty)
n.seg), s.x[i, ], s.y[i, ], lwd = lwd, lty = lty, col =
col.radius)
}
}
if (!is.null(labels)) {
y.off <- mx * (if (full)
1
else 0.1)
if (flip.labels)
y.off <- y.off + cex * par("cxy")[2L] * ((1L:n.loc)%%2 -
if (full)
0.4
else 0)
text(xloc, yloc - y.off, labels, cex = cex, adj = c(0.5,
1))
}
if (!is.null(key.loc)) {
par(xpd = key.xpd)
key.x <- key.len * cos(angles) + key.loc[1L]
key.y <- key.len * sin(angles) + key.loc[2L]
if (draw.segments) {
px <- py <- numeric()
for (j in 1L:n.seg) {
k <- seq.int(from = aangl[j], to = aangl[j +
1], by = 1 * deg)
px <- c(px, key.loc[1L], key.x[j], key.len * cos(k) +
key.loc[1L], NA)
py <- c(py, key.loc[2L], key.y[j], key.len * sin(k) +
key.loc[2L], NA)
}
polygon3(px, py, col = col.segments, lwd = lwd, lty = lty)
}
else {
# polygon3(key.x, key.y, lwd = lwd, lty = lty)
if (polygon)
polygon3(key.x, key.y, lwd = lwd, lty = lty)
if (radius)
segments(rep.int(key.loc[1L], n.seg), rep.int(key.loc[2L],
# n.seg), key.x, key.y, lwd = lwd, lty = lty)
n.seg), key.x, key.y, lwd = lwd, lty = lty, col = col.radius)
}
lab.angl <- angles + if (draw.segments)
(angles[2L] - angles[1L])/2
else 0
label.x <- 1.1 * key.len * cos(lab.angl) + key.loc[1L]
label.y <- 1.1 * key.len * sin(lab.angl) + key.loc[2L]
for (k in 1L:n.seg) {
text.adj <- c(if (lab.angl[k] < 90 * deg || lab.angl[k] >
270 * deg) 0 else if (lab.angl[k] > 90 * deg &&
lab.angl[k] < 270 * deg) 1 else 0.5, if (lab.angl[k] <=
90 * deg) (1 - lab.angl[k]/(90 * deg))/2 else if (lab.angl[k] <=
270 * deg) (lab.angl[k] - 90 * deg)/(180 * deg) else 1 -
(lab.angl[k] - 270 * deg)/(180 * deg))
text(label.x[k], label.y[k], labels = key.labels[k],
cex = cex, adj = text.adj)
}
}
if (frame.plot)
box(...)
invisible(locations)
}
Here is an example of running this:
#require(debug)
# mtrace(stars2)
stars(mtcars[1:3, 1:8],
draw.segments = T,
main = "Motor Trend Cars : stars(*, full = F)", full = T, col.segments = 1:2)
stars2(mtcars[1:3, 1:8],
draw.segments = T,
main = "Motor Trend Cars : stars(*, full = F)", full = T, col.segments = 0:3,
segment.weights = c(.2,.2,1,1,.4,.4,.6,.9))
(I'll probably publish this with explanation on my blog sometime soon...)

Resources