SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/panel.xblocks.R
ViewVC logotype

Annotation of /pkg/R/panel.xblocks.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 194 - (view) (download)

1 : felix 148 ##
2 :     ## Copyright (c) 2008 Felix Andrews <felix@nfrac.org>
3 :     ##
4 :    
5 :    
6 :     panel.xblocks <- function(x, ...)
7 :     UseMethod("panel.xblocks")
8 :    
9 :     panel.xblocks.default <-
10 :     function (x, y, ..., col = NULL, border = NA,
11 :     height = unit(1, "npc"),
12 :     block.y = unit(0, "npc"), vjust = 0,
13 :     name = "xblocks", gaps = FALSE,
14 :     last.step = median(diff(tail(x))))
15 :     {
16 :     if (is.function(y))
17 :     y <- y(x)
18 :     x <- as.numeric(x)
19 :     if (length(x) == 0) return()
20 :     if (is.unsorted(x, na.rm = TRUE))
21 :     stop("'x' should be ordered (increasing)")
22 :     if (is.na(last.step))
23 :     last.step <- 0
24 :     if (gaps) {
25 :     .Deprecated(msg = "The 'gaps' argument is deprecated; use panel.xblocks(time(z), is.na(z))")
26 :     y <- is.na(y)
27 :     }
28 :     ## Three cases:
29 :     ## (1) If y is character, assume it gives the block colours
30 :     ## -- unless 'col' is given, which over-rides it.
31 :     ## (2) If y is logical, show blocks of TRUE values.
32 :     ## (3) If y is numeric, show blocks of non-NA values.
33 :     if (is.logical(y)) {
34 :     y <- y
35 :     } else if (is.numeric(y)) {
36 :     y <- !is.na(y)
37 :     } else {
38 :     ## this will convert factor, Date, etc to character:
39 :     y <- as.character(y)
40 :     }
41 :     ## Note: rle treats each NA as unique (does not combine runs of NAs)
42 :     ## so we need to replace NAs with a temporary value.
43 :     NAval <-
44 :     if (is.character(y)) "" else FALSE
45 :     y[is.na(y)] <- NAval
46 :     ## find blocks (runs of constant values)
47 :     yrle <- rle(y)
48 :     ## substitute NA values back in
49 :     blockCol <- yrle$values
50 :     blockCol[blockCol == NAval] <- NA
51 :     ## for logical series, col default comes from current theme
52 :     if (is.logical(y) && is.null(col))
53 :     col <- trellis.par.get("plot.line")$col
54 :     ## set block colours if 'col' given
55 :     if (length(col) > 0) {
56 :     if (is.character(col))
57 :     col[col == ""] <- NA
58 :     ok <- !is.na(blockCol)
59 :     blockCol[ok] <- rep(col, length = sum(ok)) ## rep to avoid warnings
60 :     }
61 :     ## work out block geometry
62 :     idxBounds <- cumsum(c(1, yrle$lengths))
63 :     idxStart <- head(idxBounds, -1)
64 :     idxEnd <- tail(idxBounds, -1)
65 :     idxEnd[length(idxEnd)] <- length(y)
66 :     blockStart <- x[idxStart]
67 :     blockEnd <- x[idxEnd]
68 :     blockEnd[length(blockEnd)] <- tail(blockEnd, 1) + last.step
69 :     blockWidth <- blockEnd - blockStart
70 :     ## draw it
71 :     grid::grid.rect(x = blockStart, width = blockWidth,
72 :     y = block.y, height = height,
73 :     hjust = 0, vjust = vjust,
74 :     default.units = "native", name = name,
75 :     gp = gpar(fill = blockCol, col = border, ...))
76 :     }
77 :    
78 :     panel.xblocks.ts <-
79 :     function(x, y = x, ...)
80 :     {
81 : deepayan 194 if (!is.function(y)) y <- as.vector(y)
82 : felix 148 panel.xblocks(as.vector(time(x)), y, ...)
83 :     }
84 :    
85 :     panel.xblocks.zoo <-
86 :     function(x, y = x, ...)
87 :     {
88 : deepayan 194 if (!is.function(y)) y <- zoo::coredata(y)
89 :     panel.xblocks(zoo::index(x), y, ...)
90 : felix 148 }
91 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge