SCM

SCM Repository

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

Diff of /pkg/R/theeconomist.R

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

revision 161, Sat Jul 24 03:50:13 2010 UTC revision 162, Sat Jul 24 04:11:18 2010 UTC
# Line 1  Line 1 
1  ## Implementation Copyright (c) 2009 Felix Andrews  ## Implementation Copyright (c) 2009 Felix Andrews
2  ## based on plot style used in The Economist magazine.  ## based on plot style used in The Economist magazine.
3    
4    theEconomist.theme <-
5       function(win.fontfamily = NULL, #"Gill Sans MT"
6                with.bg = FALSE, box = "black", ...)
7    {
8        theme <- list(
9             background = list(col = if (with.bg) "#D5E2E9" else "transparent"),
10             plot.line = list(col = "#00526D", lwd = 2.5),
11             superpose.line = list(col = c("#00526D", "#00A3DB", "#7A2713", "#939598", "#6CCFF6"), lwd = 2.5),
12             plot.symbol = list(col = "#00526D", pch = 16),
13             superpose.symbol = list(col = c("#00526D", "#00A3DB", "#7A2713", "#939598", "#6CCFF6"), pch = 16),
14             plot.polygon = list(col = "#00526D"),
15             superpose.polygon = list(col = c("#5F92A8", "#00526D", "#6CCFF6", "#00A3DB", "#A7A9AC")),
16             regions = list(col = colorRampPalette(brewer.pal(9, "Blues"))(100)),
17             reference.line = list(col = if (with.bg) "white" else "#aaaaaa", lwd = 1.75),
18             dot.line = list(col = if (with.bg) "white" else "#aaaaaa", lwd = 1.75),
19             add.line = list(col = "#ED1C24", lwd = 1.5),
20             axis.line = list(col = box),
21             box.3d = list(col = box),
22             strip.border = list(col = box),
23             strip.background = list(col = if (with.bg) "white" else "#CBDDE6"),
24             strip.shingle = list(col = if (with.bg) "#CBDDE6" else "white", alpha = 0.5),
25             par.main.text = list(font = 1),
26             par.sub.text = list(font = 1),
27             axis.text = list(cex = 1)
28             )
29        if (.Platform$OS.type == "windows" && !is.null(win.fontfamily)) {
30            windowsFonts(TheEconomistLike = win.fontfamily)
31            theme$grid.pars$fontfamily <- "TheEconomistLike"
32        } else {
33            ## TODO: how do fonts work on linux etc?
34        }
35        modifyList(theme, simpleTheme(...))
36    }
37    
38    theEconomist.opts <- function()
39    {
40        list(default.args =
41             list(axis = theEconomist.axis,
42                  xscale.components = xscale.components.subticks,
43                  yscale.components = theEconomist.yscalecomps,
44                  between = list(x = 1, y = 1)),
45             axis.padding = list(numeric = 0, factor = 0.6),
46             skip.boundary.labels = 0,
47             layout.widths =
48             list(axis.left = list(x = 0, units = "char"),
49                  axis.right = list(x = 3, units = "char"))
50             )
51    }
52    
53    theEconomist.yscalecomps <- function(lim, ...) {
54        ans <- yscale.components.default(lim = lim, ...)
55        if (!is.list(ans$right)) {
56            ans$right <- ans$left
57            ans$left$ticks$at <- numeric()
58            ans$left$labels$at <- numeric()
59            ans$left$labels$labels <- character()
60        }
61        ans
62    }
63    
64    theEconomist.axis <-
65        function(side = c("top", "bottom", "left", "right"),
66                 scales, components, ...,
67                 labels = c("default", "yes", "no"),
68                 ticks = c("default", "yes", "no"),
69                 line.col)
70    {
71        if (scales$draw == FALSE)
72            return()
73        side <- match.arg(side)
74        labels <- match.arg(labels)
75        ticks <- match.arg(ticks)
76        ticks <- "no"
77        if (!is.list(components$top)) {
78            if (side == "top") {
79                labels <- "no"
80            }
81        }
82        if (side == "right") {
83            labels <- "yes"
84        }
85        ## use axis.text for ticks because axis.line$col might be transparent
86        axis.text <- trellis.par.get("axis.text")
87        axis.default(side, scales = scales,
88                     components = components, ...,
89                     labels = labels, ticks = ticks,
90                     line.col = axis.text$col)
91        ## now draw grid lines corresponding to horizontal axis ticks.
92        ## can only do this with the bottom and right sides;
93        ## otherwise the strip viewports are current, not panel.
94        if (side %in% c("top", "left"))
95            return()
96        ref.line <- trellis.par.get("reference.line")
97        if (side == "right") {
98            comp.list <- components[["right"]]
99            if (!is.list(comp.list))
100                comp.list <- components[["left"]]
101            tck <- abs(comp.list$ticks$tck)
102            panel.refline(h = comp.list$ticks$at,
103                          lwd = ref.line$lwd * tck,
104                          alpha = ref.line$alpha * tck / max(tck, na.rm = TRUE))
105            ## draw axis line along bottom (assuming transparent axis.line)
106            lims <- current.panel.limits()
107            panel.abline(h = lims$y[1], col = axis.text$col)
108        }
109    }
110    
111  asTheEconomist <-  asTheEconomist <-
112      function(x,      function(x, ...,
113               type = "l",               type = "l",
114               vertical = FALSE, zeroline = "red",               ylab = expression(NULL),
115                 xlab = expression(NULL),
116               par.settings =               par.settings =
117                 theEconomist.theme(with.bg = with.bg, box = "transparent"),                 theEconomist.theme(with.bg = with.bg, box = "transparent"),
118               with.bg = FALSE,               with.bg = FALSE,
119               titleSpec = list(x = grid::unit(5, "mm"), just = "left"),               titleSpec = list(x = grid::unit(5, "mm"), just = "left"),
120               ylab = expression(NULL),               par.strip.text = list(font = 2))
              xlab = expression(NULL),  
              scales = list(axs = "i",  
                  x = list(tck = 0, alternating = 1),  
                  y = list(tck = 0, alternating = 2)),  
              par.strip.text = list(font = 2),  
              between = list(x = 1, y = 1))  
121  {  {
122      ans <- x      ans <- x
123      ## make nice left-aligned title      ## make nice left-aligned title
# Line 42  Line 143 
143      ans <- update(ans,      ans <- update(ans,
144                    type = type, ylab = ylab, xlab = xlab,                    type = type, ylab = ylab, xlab = xlab,
145                    par.settings = par.settings,                    par.settings = par.settings,
                   scales = scales,  
146                    par.strip.text = par.strip.text,                    par.strip.text = par.strip.text,
147                    between = between)                    between = list(x = 1, y = 1),
148      ans <- ans +                    scales = list(y = list(axs = "i", alternating = 2)),
149          layer_(panel.xticksgrid(vertical = V, zeroline = ZL, ...),                    skip.boundary.labels = 0,
150                 data = list(V = vertical, ZL = zeroline))                    lattice.options = list(
151                      layout.widths =
152                      list(axis.left = list(x = 0, units = "char"),
153                           axis.right = list(x = 3, units = "char"))
154                      )
155                      )
156        ## these do not get through update()
157        ans$axis <- theEconomist.axis
158        ans$xscale.components <- xscale.components.subticks
159        ans$yscale.components <- theEconomist.yscalecomps
160      ans$call <- match.call()      ans$call <- match.call()
161      ans      ans
162  }  }
# Line 74  Line 183 
183      pdf.options(fonts = ps.options()$fonts)      pdf.options(fonts = ps.options()$fonts)
184      ## TODO: problem: after this, plots generated by bitmap() use wrong font      ## TODO: problem: after this, plots generated by bitmap() use wrong font
185  }  }
   
 theEconomist.theme <-  
    function(win.fontfamily = NULL, #"Gill Sans MT"  
             with.bg = FALSE, box = "black", ...)  
 {  
     theme <- list(  
          background = list(col = if (with.bg) "#D5E2E9" else "transparent"),  
          plot.line = list(col = "#00526D", lwd = 2.5),  
          superpose.line = list(col = c("#00526D", "#00A3DB", "#7A2713", "#939598", "#6CCFF6"), lwd = 2.5),  
          plot.symbol = list(col = "#00526D", pch = 16),  
          superpose.symbol = list(col = c("#00526D", "#00A3DB", "#7A2713", "#939598", "#6CCFF6"), pch = 16),  
          plot.polygon = list(col = "#00526D"),  
          superpose.polygon = list(col = c("#5F92A8", "#00526D", "#6CCFF6", "#00A3DB", "#A7A9AC")),  
          regions = list(col = colorRampPalette(brewer.pal(9, "Blues"))(100)),  
          reference.line = list(col = if (with.bg) "white" else "#aaaaaa", lwd = 1.75),  
          dot.line = list(col = if (with.bg) "white" else "#aaaaaa", lwd = 1.75),  
          add.line = list(col = "#ED1C24", lwd = 1.5),  
          axis.line = list(col = box),  
          box.3d = list(col = box),  
          strip.border = list(col = box),  
          strip.background = list(col = if (with.bg) "white" else "#CBDDE6"),  
          strip.shingle = list(col = if (with.bg) "#CBDDE6" else "white", alpha = 0.5),  
          par.main.text = list(font = 1),  
          par.sub.text = list(font = 1),  
          axis.text = list(cex = 1)  
          )  
     if (.Platform$OS.type == "windows" && !is.null(win.fontfamily)) {  
         windowsFonts(TheEconomistLike = win.fontfamily)  
         theme$grid.pars$fontfamily <- "TheEconomistLike"  
     } else {  
         ## TODO: how do fonts work on linux etc?  
     }  
     modifyList(theme, simpleTheme(...))  
 }  
   
 panel.xticksgrid <-  
     function(..., vertical = FALSE, zeroline = "red", x = NULL, y = NULL)  
 {  
     lims <- current.panel.limits()  
     xminor <- pretty(lims$x, n = 25)  
     if (vertical) {  
         panel.grid(h = 0, v = -1, x = x, y = y)  
         if (abs(lims$x[1]) > abs(diff(lims$x)) / 20)  
             panel.refline(v = 0, col = zeroline, alpha = 0.8)  
     } else {  
         panel.grid(h = -1, v = 0, x = x, y = y)  
         if (abs(lims$y[1]) > abs(diff(lims$y)) / 20)  
             panel.refline(h = 0, col = zeroline, alpha = 0.8)  
     }  
     panel.abline(h = lims$y[1], col = "black")  
     panel.axis(side = "bottom", outside = TRUE,  
                tck = -1, line.col = 1)  
     panel.axis(side = "bottom", outside = TRUE,  
                at = xminor, tck = -0.33, line.col = 1)  
 }  
   

Legend:
Removed from v.161  
changed lines
  Added in v.162

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