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

Question

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)

Thanks for any help,

Tal

Answer 1

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)

Answer 2

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...)