SCM

SCM Repository

[latticeextra] Diff of /pkg/R/horizonplot.R
ViewVC logotype

Diff of /pkg/R/horizonplot.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 191, Wed Dec 30 11:01:04 2015 UTC revision 192, Wed Dec 30 12:37:55 2015 UTC
# Line 12  Line 12 
12               colorkey = FALSE, legend = NULL,               colorkey = FALSE, legend = NULL,
13               panel = panel.horizonplot,               panel = panel.horizonplot,
14               prepanel = prepanel.horizonplot,               prepanel = prepanel.horizonplot,
15               col.regions = c("#B41414","#E03231","#F7A99C","#9FC8DC","#468CC8","#0165B3"),               nbands = 3L,
16                 col.regions = brewer.pal(n = 2 * nbands, name = "RdYlBu"),
17               strip = FALSE, strip.left = TRUE,               strip = FALSE, strip.left = TRUE,
18               par.strip.text = list(cex = 0.6),               par.strip.text = list(cex = 0.6),
19               colorkey.digits = 3,               colorkey.digits = 3, # nbands ?,
20               #layout = c(1, NA), ## TODO pending new lattice release               #layout = c(1, NA), ## TODO pending new lattice release
21               groups = NULL,               groups = NULL,
22               default.scales =               default.scales =
# Line 31  Line 32 
32                    strip = strip, strip.left = strip.left,                    strip = strip, strip.left = strip.left,
33                    par.strip.text = par.strip.text,                    par.strip.text = par.strip.text,
34                    #layout = layout,                    #layout = layout,
35                    default.scales = default.scales)                    default.scales = default.scales,
36                      nbands = nbands)
37      ans$call <- match.call()      ans$call <- match.call()
38      ## add colorkey      ## add colorkey
39      if (isTRUE(colorkey)) {      if (isTRUE(colorkey)) colorkey <- list()
40          colorkey <- list()      if (is.list(colorkey))
41      }      {
42      if (is.list(colorkey)) {          bands.at <- seq(-nbands, nbands)
43          if (ans$y.scales$relation == "same") {          if (ans$y.scales$relation == "same") {
44              origin <- ans$y.limits[1]              origin <- ans$y.limits[1]
45              horizonscale <- diff(ans$y.limits)              horizonscale <- diff(ans$y.limits)
46          }          }
47          if (is.na(horizonscale)) {          if (is.na(horizonscale)) {
48              labels <- expression(              ## labels <- expression(
49                  - 3 * Delta[i], - 2 * Delta[i], - 1 * Delta[i], 0,              ##    - 3 * Delta[i], - 2 * Delta[i], - 1 * Delta[i], 0,
50                  + 1 * Delta[i], + 2 * Delta[i], + 3 * Delta[i], 0)              ##    + 1 * Delta[i], + 2 * Delta[i], + 3 * Delta[i], 0)
51              if (is.numeric(origin)) {              labels <- parse(text = sprintf("%+d * Delta[i]", bands.at))
52                  labels[4] <- origin              labels[nbands + 1] <- if (is.numeric(origin)) origin else "origin"
             } else {  
                 labels[4] <- "origin"  
53              }              }
54          } else {          else {
55              if (is.numeric(origin)) {              if (is.numeric(origin)) {
56                  labels <- round(origin + (-3:3) * horizonscale, colorkey.digits)                  labels <- round(origin + bands.at * horizonscale, colorkey.digits)
57              } else {              } else {
58                  labels <- paste(ifelse(-3:3>=0,"+","-"),                  labels <- sprintf("%+g", round(bands.at * horizonscale, colorkey.digits))
59                                  round(abs(-3:3) * horizonscale, colorkey.digits))                  labels[nbands + 1] <- "origin"
                 labels[4] <- "origin"  
60              }              }
61          }          }
62          ii <- round((0:5 / 5) * (length(col.regions)-1)) + 1          ii <- round(seq(1, length(col.regions), length.out = 2 * nbands))
63          colorkey <-          colorkey <-
64              modifyList(list(col = col.regions[ii], at = -3:3,              modifyList(list(col = col.regions[ii], at = bands.at,
65                              labels = list(labels = labels, at = -3:3)),                              labels = list(labels = labels, at = bands.at)),
66                         colorkey)                         colorkey)
67          space <- colorkey$space          space <- colorkey$space
68          if (is.null(space)) space <- "right"          if (is.null(space)) space <- "right"
# Line 78  Line 77 
77    
78  panel.horizonplot <-  panel.horizonplot <-
79      function(x, y, ..., border = NA,      function(x, y, ..., border = NA,
80               col.regions = c("#B41414","#E03231","#F7A99C","#9FC8DC","#468CC8","#0165B3"),               nbands = 3L,
81                 col.regions = brewer.pal(n = 2 * nbands, name = "RdYlBu"),
82               origin) ## catch origin, don't pass to panel.xyarea!               origin) ## catch origin, don't pass to panel.xyarea!
83  {  {
84      regions <- trellis.par.get("regions")      regions <- trellis.par.get("regions")
85      origin <- current.panel.limits()$y[1]      origin <- current.panel.limits()$ylim[1]
86      scale <- diff(current.panel.limits()$y)      scale <- diff(current.panel.limits()$ylim)
87      ## ordered for drawing, from least extreme to most extreme      ## ordered for drawing, from least extreme to most extreme
88      sections <- c(0, -1, 1, -2, 2, -3) ## these are the lower bounds      #sections <- c(0, -1, 1, -2, 2, -3) ## these are the lower bounds
89      ii <- round(((sections + 3) / 5) * (length(col.regions)-1)) + 1      sections <- as.vector(rbind(seq_len(nbands)-1, -seq_len(nbands)))
90        #ii <- round(((sections + 3) / 5) * (length(col.regions)-1)) + 1
91        ii <- round(((sections + nbands) / (2*nbands-1)) * (length(col.regions)-1)) + 1
92        #ii <- sections + nbands + 1
93      col <- col.regions[ii]      col <- col.regions[ii]
94      for (i in seq_along(sections)) {      for (i in seq_along(sections)) {
95          section <- sections[i]          section <- sections[i]
# Line 106  Line 109 
109    
110  prepanel.horizonplot <-  prepanel.horizonplot <-
111      function(x, y, ..., horizonscale = NA,      function(x, y, ..., horizonscale = NA,
112               origin = function(y) na.omit(y)[1])               origin = function(y) na.omit(y)[1],
113                 nbands=3L)
114  {  {
115      if (is.function(origin))      if (is.function(origin))
116          origin <- origin(y)          origin <- origin(y)
117      ans <- prepanel.default.xyplot(x, y, ...)      ans <- prepanel.default.xyplot(x, y, ...)
118      if (is.na(horizonscale))      if (is.na(horizonscale))
119          horizonscale <- max(abs(ans$ylim - origin)) / 3          horizonscale <- max(abs(ans$ylim - origin)) / nbands
120      ans$ylim <- origin + c(0, horizonscale)      ans$ylim <- origin + c(0, horizonscale)
121      ans      ans
122  }  }

Legend:
Removed from v.191  
changed lines
  Added in v.192

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