Как заставить команду звезд иметь отрезки под разными углами? (в R)

Question

Я играю с функцией «звезды» ({графика}), чтобы создать сегмент цветов.

Я хочу построить цветок из сегментов, например, так, чтобы сгенерировала следующая команда:

stars1(mtcars[, 1:7],
  draw.segments = T,
        main = "Motor Trend Cars : stars(*, full = F)", full = T, col.radius = 1:8)

Но я хочу, чтобы сегменты имели не одинаковые углы, а меньшие углы (и между цветами могло бы быть пространство).

Цель, к которой я стремлюсь, заключается в том, чтобы у каждого цветка был «вес», чтобы некоторые аспекты были более важными (больший вес), а некоторые - меньше (и, следовательно, имели меньший угол).

Я понимаю, что это могут быть изменения в следующей части команды звезд:

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

Но я не уверен относительно того, как манипулировать им, чтобы выполнить мою задачу (взвешенных цветов, под разными углами)

Answer 1

Я узнал, как это сделать.

Для дальнейшего использования, вот код:

# 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)
}

Вот пример выполнения этого:

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

(вероятно, я опубликую это с объяснением на моем блоге в ближайшее время ...)

Answer 2

Есть ли у вас какое-либо перцептивное обоснование для этого изменения? Если вес будет варьироваться в зависимости от звезды, будет очень трудно интерпретировать сюжет.

(Но реализовать это должно быть тривиально - вместо использования одинаково распределенных углов используйте веса: angles <- weights / sum(weights) * 2 * pi)