Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

geom_segment_plus

By: a guest on Feb 4th, 2013  |  syntax: R  |  size: 4.24 KB  |  views: 58  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. library(proto)
  2. #' Single line segments.
  3. #'
  4. #' @section Aesthetics:
  5. #' \Sexpr[results=rd,stage=build]{ggplot2:::rd_aesthetics("geom", "segment")}
  6. #'
  7. #' @inheritParams geom_point
  8. #' @param arrow specification for arrow heads, as created by arrow()
  9. #' @param lineend Line end style (round, butt, square)
  10. #' @seealso \code{\link{geom_path}} and \code{\link{geom_line}} for multi-
  11. #'   segment lines and paths.
  12. #' @export
  13. #' @examples
  14. #' library(grid) # needed for arrow function
  15. #' p <- ggplot(seals, aes(x = long, y = lat))
  16. #' (p <- p + geom_segment(aes(xend = long + delta_long, yend = lat + delta_lat), arrow = arrow(length = unit(0.1,"cm"))))
  17. #'
  18. #' if (require("maps")) {
  19. #'
  20. #' xlim <- range(seals$long)
  21. #' ylim <- range(seals$lat)
  22. #' usamap <- data.frame(map("world", xlim = xlim, ylim = ylim, plot =
  23. #' FALSE)[c("x","y")])
  24. #' usamap <- rbind(usamap, NA, data.frame(map('state', xlim = xlim, ylim
  25. #' = ylim, plot = FALSE)[c("x","y")]))
  26. #' names(usamap) <- c("long", "lat")
  27. #'
  28. #' p + geom_path(data = usamap) + scale_x_continuous(limits = xlim)
  29. #' }
  30. #'
  31. #' # You can also use geom_segment to recreate plot(type = "h") :
  32. #' counts <- as.data.frame(table(x = rpois(100,5)))
  33. #' counts$x <- as.numeric(as.character(counts$x))
  34. #' with(counts, plot(x, Freq, type = "h", lwd = 10))
  35. #'
  36. #' qplot(x, Freq, data = counts, geom = "segment",
  37. #'   yend = 0, xend = x, size = I(10))
  38. #'
  39. #' # Adding line segments
  40. #' library(grid) # needed for arrow function
  41. #' b <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
  42. #' b + geom_segment(aes(x = 2, y = 15, xend = 2, yend = 25))
  43. #' b + geom_segment(aes(x = 2, y = 15, xend = 3, yend = 15))
  44. #' b + geom_segment(aes(x = 5, y = 30, xend = 3.5, yend = 25), arrow = arrow(length = unit(0.5, "cm")))
  45.  
  46. geom_segment_plus <- function (mapping = NULL, data = NULL, stat = "identity",
  47.   position = "identity", arrow = NULL, lineend = "butt", na.rm = FALSE, ...) {
  48.  
  49.   GeomSegmentPlus$new(mapping = mapping, data = data, stat = stat,
  50.     position = position, arrow = arrow, lineend = lineend, na.rm = na.rm, ...)
  51. }
  52.  
  53. GeomSegmentPlus <- proto(ggplot2:::Geom, {
  54.   objname <- "segmentplus"
  55.  
  56.   draw <- function(., data, scales, coordinates, arrow = NULL,
  57.     lineend = "butt", na.rm = FALSE, ...) {
  58.  
  59.     data <- remove_missing(data, na.rm = na.rm,
  60.       c("x", "y", "xend", "yend", "linetype", "size", "shape","shorten.start","shorten.end","offset"),
  61.       name = "geom_segment_plus")
  62.     if (empty(data)) return(zeroGrob())
  63.  
  64.     if (is.linear(coordinates)) {
  65.         data = coord_transform(coordinates, data, scales)
  66.           for(i in 1:dim(data)[1] )
  67.           {
  68.                 match = data$xend == data$x[i] & data$x == data$xend[i] & data$yend == data$y[i] & data$y == data$yend[i]
  69.                 #print("Match:")
  70.                 #print(sum(match))
  71.                 if( sum( match ) == 0 ) data$offset[i] <- 0
  72.           }
  73.  
  74.           data$dx = data$xend - data$x
  75.           data$dy = data$yend - data$y
  76.           data$dist = sqrt( data$dx^2 + data$dy^2 )
  77.           data$px = data$dx/data$dist
  78.           data$py = data$dy/data$dist
  79.  
  80.           data$x = data$x + data$px * data$shorten.start
  81.           data$y = data$y + data$py * data$shorten.start
  82.           data$xend = data$xend - data$px * data$shorten.end
  83.           data$yend = data$yend - data$py * data$shorten.end
  84.           data$x = data$x - data$py * data$offset
  85.           data$xend = data$xend - data$py * data$offset
  86.           data$y = data$y + data$px * data$offset
  87.           data$yend = data$yend + data$px * data$offset
  88.          
  89.       return(with(data,
  90.         segmentsGrob(x, y, xend, yend, default.units="native",
  91.         gp = gpar(col=alpha(colour, alpha), fill = alpha(colour, alpha),
  92.           lwd=size * .pt, lty=linetype, lineend = lineend),
  93.         arrow = arrow)
  94.       ))
  95.     }
  96.                 print("carrying on")
  97.  
  98.     data$group <- 1:nrow(data)
  99.     starts <- subset(data, select = c(-xend, -yend))
  100.     ends <- rename(subset(data, select = c(-x, -y)), c("xend" = "x", "yend" = "y"),
  101.       warn_missing = FALSE)
  102.    
  103.     pieces <- rbind(starts, ends)
  104.     pieces <- pieces[order(pieces$group),]
  105.    
  106.     GeomPath$draw_groups(pieces, scales, coordinates, arrow = arrow, ...)
  107.   }
  108.  
  109.  
  110.   default_stat <- function(.) StatIdentity
  111.   required_aes <- c("x", "y", "xend", "yend")
  112.   default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA,shorten.start=0,shorten.end=0,offset=0)
  113.   guide_geom <- function(.) "path"
  114. })
clone this paste RAW Paste Data