[Rd] Bug in stars.R (PR#739)

tdye@lava.net tdye@lava.net
Mon, 20 Nov 2000 08:48:03 +0100 (MET)


Hi all,

Please let me know if this isn't the correct place to report bugs in
contributed code.  Otherwise, the following code contains one additional
line and a short comment above it.  The extra line of code catches the
unusual situation where a data column contains all 0 values.

The corrected code is below the signature.

Thanks for your help.
Tom

Thomas S. Dye, Ph.D.                                    http://www.tsdye.com
Home: 812A 19th Avenue, Honolulu, Hawaii 96816.  (808) 739-1367 or 387-9352.
Work: International Archaeological Research Institute, Inc., 2081 Young St.,
      Honolulu, Hawaii 96826. Voice (808) 946-2548; Fax 943-0716.

function (x, full = TRUE, scale = TRUE, radius = TRUE, labels = dimnames(x)[[1]], 
            locations = NULL, xlimit = NULL, ylimit = NULL, len = 1, 
            colors = NULL, key.loc = NULL, key.labels = NULL, draw.segments = FALSE, 
            draw.axes = FALSE, ...) 
{
  if (is.data.frame(x)) 
    x <- as.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")
  n.loc <- nrow(x)
  n.seg <- ncol(x)
  deg <- pi/180
  seg.colors <- if (!is.null(colors)) 
    colors
  else 1:n.seg
  if (is.null(locations)) {
    mat.dim <- ceiling(sqrt(n.loc))
    temp.loc.1 <- rep(x = 2.1 * 1:mat.dim, times = mat.dim, 
                      length = n.loc)
    temp.loc.2 <- rep(x = 2.1 * mat.dim:1, rep(x = mat.dim, 
                        times = mat.dim), length = n.loc)
    loc <- matrix(data = c(temp.loc.1, temp.loc.2), ncol = 2)
  }
  else {
    if (!is.matrix(locations) || ncol(locations) != 2) 
      stop("locations must be a 2-column matrix.")
    loc <- .Alias(locations)
  }
  if (n.loc != nrow(loc)) 
    stop("number of rows of locations and x must be equal.")
  angles <- if (full) 
    seq(0, 2 * pi, length = n.seg + 1)[-(n.seg + 1)]
  else if (draw.segments) 
    seq(0, pi, length = n.seg + 1)[-(n.seg + 1)]
  else seq(0, pi, length = n.seg)
  if (length(angles) != n.seg) 
    stop("length(angles) must be the same as ncol(x)")
  x[is.na(x)] <- 0
  if (scale) 
    x <- sweep(x, 2, apply(x, 2, max), FUN = "/")
# Columns of 0s will put NAs in x, next line gets rid of them
  x[is.na(x)] <- 0
  x <- x * len
  temp.xlim <- if (is.null(xlimit)) 
    range(loc[, 1] + max(x), loc[, 1] - max(x))
  else xlimit
  temp.ylim <- if (is.null(ylimit)) 
    range(loc[, 2] + max(x), loc[, 2] - max(x))
  else ylimit
  opar <- par(no.readonly = TRUE)
  on.exit(par(opar))
  plot(0, type = "n", ..., xlim = temp.xlim, ylim = temp.ylim, 
       xlab = "", ylab = "", asp = 1, axes = draw.axes)
  if (draw.segments) {
    for (i in 1:n.loc) {
      poly.x <- NA
      poly.y <- NA
      start.x.coord <- x[i, ] * cos(angles) + loc[i, 1]
      start.y.coord <- x[i, ] * sin(angles) + loc[i, 2]
      for (j in 1:n.seg) {
        poly.x <- c(poly.x, loc[i, 1], start.x.coord[j])
        poly.y <- c(poly.y, loc[i, 2], start.y.coord[j])
        next.angle <- if (j < n.seg) 
          angles[j + 1]
        else (if (full) 
              360
        else 180) * deg
        k <- seq(from = angles[j], to = next.angle, by = deg)
        poly.x <- c(poly.x, x[i, j] * cos(k) + loc[i, 
                                                   1], NA)
        poly.y <- c(poly.y, x[i, j] * sin(k) + loc[i, 
                                                   2], NA)
      }
      par(lwd = 0.25)
      polygon(poly.x, poly.y, col = seg.colors)
      par(lwd = 1)
      if (!is.null(labels)) 
        text(loc[i, 1], loc[i, 2] - if (full) 
             max(x)
        else 0.1 * max(x), labels[i], cex = 0.5, adj = c(0.5, 
                                                   1))
    }
  }
  else {
    for (i in 1:n.loc) {
      temp.x.coord <- x[i, ] * cos(angles) + loc[i, 1]
      temp.y.coord <- x[i, ] * sin(angles) + loc[i, 2]
      if (radius) {
        par(lwd = 0.25)
        segments(rep(loc[i, 1], n.seg), rep(loc[i, 2], 
                                            n.seg), temp.x.coord, temp.y.coord)
        par(lwd = 1)
      }
      lines(c(temp.x.coord, temp.x.coord[1]), c(temp.y.coord, 
                                                temp.y.coord[1]), lwd = 0.25)
      if (!is.null(labels)) 
        text(loc[i, 1], loc[i, 2] - if (full) 
             max(x)
        else 0.1 * max(x), labels[i], cex = 0.5, adj = c(0.5, 
                                                   1))
    }
  }
  if (!is.null(key.loc)) {
    if (draw.segments) {
      key.x <- NA
      key.y <- NA
      key.x.coord <- cos(angles) * len + key.loc[1]
      key.y.coord <- sin(angles) * len + key.loc[2]
      for (j in 1:n.seg) {
        key.x <- c(key.x, key.loc[1], key.x.coord[j])
        key.y <- c(key.y, key.loc[2], key.y.coord[j])
        k <- angles[j] + deg
        next.angle <- if (j < n.seg) 
          angles[j + 1]
        else (if (full) 
              360
        else 180) * deg
        while (k < next.angle) {
          key.x <- c(key.x, len * cos(k) + key.loc[1])
          key.y <- c(key.y, len * sin(k) + key.loc[2])
          k <- k + deg
        }
        key.x <- c(key.x, len * cos(next.angle) + key.loc[1], 
                   NA)
        key.y <- c(key.y, len * sin(next.angle) + key.loc[2], 
                   NA)
      }
      par(lwd = 0.25)
      polygon(key.x, key.y, col = seg.colors)
      par(lwd = 1)
    }
    else {
      temp.x.coord <- cos(angles) * len + key.loc[1]
      temp.y.coord <- sin(angles) * len + key.loc[2]
      par(lwd = 0.25)
      if (radius) 
        segments(rep(key.loc[1], n.seg), rep(key.loc[2], 
                                             n.seg), temp.x.coord, temp.y.coord)
      lines(c(temp.x.coord, temp.x.coord[1]), c(temp.y.coord, 
                                                temp.y.coord[1]))
      par(lwd = 1)
    }
    if (is.null(key.labels)) 
      key.labels <- dimnames(x)[[2]]
    lab.angl <- angles + if (draw.segments) 
      (angles[2] - angles[1])/2
    else 0
    label.x.coord <- cos(lab.angl) * len * 1.1 + key.loc[1]
    label.y.coord <- sin(lab.angl) * len * 1.1 + key.loc[2]
    for (k in 1:n.seg) {
      text.adj <- 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)) 
        text.adj <- c(text.adj, 0.5 * (1 - lab.angl[k]/(90 * 
                                                        deg)))
      else if (lab.angl[k] > (90 * deg) & lab.angl[k] <= 
               (270 * deg)) 
        text.adj <- c(text.adj, (lab.angl[k] - (90 * 
                                                deg))/(180 * deg))
      else if (lab.angl[k] > (270 * deg)) 
        text.adj <- c(text.adj, 1 - (0.5 * (lab.angl[k] - 
                                            (270 * deg))/(90 * deg)))
      text.default(x = label.x.coord[k], y = label.y.coord[k], 
                   labels = key.labels[k], cex = 0.5, adj = text.adj)
    }
  }
  invisible()
}


-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._