SCM

SCM Repository

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

Annotation of /pkg/R/theeconomist.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 165 - (view) (download)

1 : felix 148 ## Implementation Copyright (c) 2009 Felix Andrews
2 :     ## based on plot style used in The Economist magazine.
3 :    
4 : felix 162 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 : felix 165 strip.shingle = list(col = if (with.bg) "#CBDDE6" else "#00A3DB", alpha = 0.5),
25 :     par.main.text = list(font = 1, just = "left", x = grid::unit(5, "mm")),
26 :     par.sub.text = list(font = 1, just = "left", x = grid::unit(5, "mm")),
27 :     axis.text = list(cex = 0.8),
28 :     box.dot = list(col = "#00526D", pch = "|", lwd = 1.75),
29 :     box.rectangle = list(fill = "#00526D", alpha = 0.5, col = "#00526D", lwd = 1.75),
30 :     box.umbrella = list(col = "#00526D", lty = 1, lwd = 1.75)
31 : felix 162 )
32 :     if (.Platform$OS.type == "windows" && !is.null(win.fontfamily)) {
33 :     windowsFonts(TheEconomistLike = win.fontfamily)
34 :     theme$grid.pars$fontfamily <- "TheEconomistLike"
35 :     } else {
36 :     ## TODO: how do fonts work on linux etc?
37 :     }
38 : felix 165 modifyList(modifyList(standard.theme("pdf"), theme), simpleTheme(...))
39 : felix 162 }
40 : felix 148
41 : felix 162 theEconomist.opts <- function()
42 :     {
43 :     list(default.args =
44 :     list(axis = theEconomist.axis,
45 :     xscale.components = xscale.components.subticks,
46 : felix 165 between = list(x = 0.8, y = 0.8)),
47 :     axis.padding = list(numeric = 0, factor = 0.6),
48 : felix 162 skip.boundary.labels = 0,
49 :     layout.widths =
50 :     list(axis.left = list(x = 0, units = "char"),
51 : felix 165 axis.right = list(x = 6, units = "char"))
52 : felix 162 )
53 :     }
54 :    
55 :     theEconomist.axis <-
56 :     function(side = c("top", "bottom", "left", "right"),
57 :     scales, components, ...,
58 :     labels = c("default", "yes", "no"),
59 :     ticks = c("default", "yes", "no"),
60 :     line.col)
61 :     {
62 :     if (scales$draw == FALSE)
63 :     return()
64 :     side <- match.arg(side)
65 :     labels <- match.arg(labels)
66 :     ticks <- match.arg(ticks)
67 : felix 165 if (side %in% c("bottom", "top")) {
68 :     if (side == "top")
69 :     ticks <- "no"
70 :     if (scales$relation == "same") {
71 :     scales$alternating <- 1 ## bottom side only
72 : felix 162 }
73 :     }
74 : felix 165 if (side %in% c("left", "right")) {
75 :     ticks <- "no"
76 :     components[["left"]]$ticks$tck <- 0
77 :     if (scales$relation == "same") {
78 :     scales$alternating <- 2 ## right side only
79 :     } else {
80 :     if (side == "right") {
81 :     labels <- if (scales$draw) "yes" else "no"
82 :     if (!is.list(components$right)) {
83 :     components$right <- components$left
84 :     }
85 :     }
86 :     if (side == "left") {
87 :     ## check for two different axes on left and right
88 :     if (!is.list(components$right)) {
89 :     labels <- "no"
90 :     }
91 :     }
92 :     }
93 : felix 162 }
94 :     ## use axis.text for ticks because axis.line$col might be transparent
95 :     axis.text <- trellis.par.get("axis.text")
96 :     axis.default(side, scales = scales,
97 :     components = components, ...,
98 :     labels = labels, ticks = ticks,
99 :     line.col = axis.text$col)
100 :     ## now draw grid lines corresponding to horizontal axis ticks.
101 :     ## can only do this with the bottom and right sides;
102 :     ## otherwise the strip viewports are current, not panel.
103 :     if (side %in% c("top", "left"))
104 :     return()
105 :     if (side == "right") {
106 :     comp.list <- components[["right"]]
107 :     if (!is.list(comp.list))
108 :     comp.list <- components[["left"]]
109 : felix 165 panel.refline(h = comp.list$ticks$at)
110 : felix 162 ## draw axis line along bottom (assuming transparent axis.line)
111 :     lims <- current.panel.limits()
112 :     panel.abline(h = lims$y[1], col = axis.text$col)
113 :     }
114 :     }
115 :    
116 : felix 148 asTheEconomist <-
117 : felix 162 function(x, ...,
118 : felix 148 type = "l",
119 : felix 162 ylab = expression(NULL),
120 :     xlab = expression(NULL),
121 : felix 148 par.settings =
122 :     theEconomist.theme(with.bg = with.bg, box = "transparent"),
123 :     with.bg = FALSE,
124 : felix 162 par.strip.text = list(font = 2))
125 : felix 148 {
126 :     ans <- x
127 :     ## make nice left-aligned title
128 :     title <- ans$main
129 :     if (is.null(title)) title <- ans$ylab
130 :     if (is.null(title)) title <- ans$ylab.default
131 : felix 165 ans <- update(ans, main = title,
132 : felix 148 type = type, ylab = ylab, xlab = xlab,
133 :     par.settings = par.settings,
134 :     par.strip.text = par.strip.text,
135 : felix 165 between = list(x = 0.8, y = 0.8),
136 : felix 162 scales = list(y = list(axs = "i", alternating = 2)),
137 :     skip.boundary.labels = 0,
138 :     lattice.options = list(
139 :     layout.widths =
140 :     list(axis.left = list(x = 0, units = "char"),
141 : felix 165 axis.right = list(x = 6, units = "char"))
142 : felix 162 )
143 :     )
144 :     ## these do not get through update()
145 :     ans$axis <- theEconomist.axis
146 :     ans$xscale.components <- xscale.components.subticks
147 : felix 148 ans$call <- match.call()
148 :     ans
149 :     }
150 :    
151 :    
152 :     genGillSans <- function()
153 :     {
154 :     ## generate AFM font metrics of GillSans - for ps/pdf
155 :     ## TODO: is there a similar looking free/open font?
156 :     oldwd <- getwd()
157 :     on.exit(setwd(oldwd))
158 :     setwd(system.file("afm", package = "grDevices"))
159 :     fnames <- c("GIL_____", "GILB____", "GILI____", "GILBI___")
160 :     for (fn in fnames) {
161 :     system(sprintf("ttf2afm -o %s.afm %s.TTF", fn,
162 :     file.path(Sys.getenv("windir"), "Fonts", fn)))
163 :     system(sprintf("gzip %s.afm", fn))
164 :     }
165 :     TheEconomistLike <- Type1Font("TheEconomistLike",
166 :     paste(fnames, ".afm", sep = ""))
167 :     postscriptFonts(TheEconomistLike = TheEconomistLike)
168 :     pdfFonts(TheEconomistLike = TheEconomistLike)
169 :     ps.options(fonts = c("sans", "serif", "mono", "Times", "Helvetica", "Courier", "URWHelvetica", "TheEconomistLike"))
170 :     pdf.options(fonts = ps.options()$fonts)
171 :     ## TODO: problem: after this, plots generated by bitmap() use wrong font
172 :     }

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