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 164, Sat Jul 31 11:34:36 2010 UTC revision 165, Sun Aug 1 12:55:44 2010 UTC
# Line 21  Line 21 
21           box.3d = list(col = box),           box.3d = list(col = box),
22           strip.border = list(col = box),           strip.border = list(col = box),
23           strip.background = list(col = if (with.bg) "white" else "#CBDDE6"),           strip.background = list(col = if (with.bg) "white" else "#CBDDE6"),
24           strip.shingle = list(col = if (with.bg) "#CBDDE6" else "white", alpha = 0.5),           strip.shingle = list(col = if (with.bg) "#CBDDE6" else "#00A3DB", alpha = 0.5),
25           par.main.text = list(font = 1),           par.main.text = list(font = 1, just = "left", x = grid::unit(5, "mm")),
26           par.sub.text = list(font = 1),           par.sub.text = list(font = 1, just = "left", x = grid::unit(5, "mm")),
27           axis.text = list(cex = 0.8)           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           )           )
32      if (.Platform$OS.type == "windows" && !is.null(win.fontfamily)) {      if (.Platform$OS.type == "windows" && !is.null(win.fontfamily)) {
33          windowsFonts(TheEconomistLike = win.fontfamily)          windowsFonts(TheEconomistLike = win.fontfamily)
# Line 32  Line 35 
35      } else {      } else {
36          ## TODO: how do fonts work on linux etc?          ## TODO: how do fonts work on linux etc?
37      }      }
38      modifyList(theme, simpleTheme(...))      modifyList(modifyList(standard.theme("pdf"), theme), simpleTheme(...))
39  }  }
40    
41  theEconomist.opts <- function()  theEconomist.opts <- function()
# Line 40  Line 43 
43      list(default.args =      list(default.args =
44           list(axis = theEconomist.axis,           list(axis = theEconomist.axis,
45                xscale.components = xscale.components.subticks,                xscale.components = xscale.components.subticks,
46                yscale.components = theEconomist.yscalecomps,                between = list(x = 0.8, y = 0.8)),
47                between = list(x = 1, y = 1)),           axis.padding = list(numeric = 0, factor = 0.6),
          axis.padding = list(numeric = 0.02, factor = 0.6),  
48           skip.boundary.labels = 0,           skip.boundary.labels = 0,
49           layout.widths =           layout.widths =
50           list(axis.left = list(x = 0, units = "char"),           list(axis.left = list(x = 0, units = "char"),
51                axis.right = list(x = 5, units = "char"))                axis.right = list(x = 6, units = "char"))
52           )           )
53  }  }
54    
 theEconomist.yscalecomps <- function(lim, ...) {  
     ans <- yscale.components.default(lim = lim, ...)  
     if (!is.list(ans$right)) {  
         ans$right <- ans$left  
         ans$left$ticks$at <- numeric()  
         ans$left$labels$at <- numeric()  
         ans$left$labels$labels <- character()  
     }  
     ans  
 }  
   
55  theEconomist.axis <-  theEconomist.axis <-
56      function(side = c("top", "bottom", "left", "right"),      function(side = c("top", "bottom", "left", "right"),
57               scales, components, ...,               scales, components, ...,
# Line 73  Line 64 
64      side <- match.arg(side)      side <- match.arg(side)
65      labels <- match.arg(labels)      labels <- match.arg(labels)
66      ticks <- match.arg(ticks)      ticks <- match.arg(ticks)
67        if (side %in% c("bottom", "top")) {
68            if (side == "top")
69      ticks <- "no"      ticks <- "no"
70      if (!is.list(components$top)) {          if (scales$relation == "same") {
71          if (side == "top") {              scales$alternating <- 1 ## bottom side only
             labels <- "no"  
72          }          }
73      }      }
74        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") {      if (side == "right") {
81          labels <- "yes"                  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      }      }
94      ## use axis.text for ticks because axis.line$col might be transparent      ## use axis.text for ticks because axis.line$col might be transparent
95      axis.text <- trellis.par.get("axis.text")      axis.text <- trellis.par.get("axis.text")
# Line 93  Line 102 
102      ## otherwise the strip viewports are current, not panel.      ## otherwise the strip viewports are current, not panel.
103      if (side %in% c("top", "left"))      if (side %in% c("top", "left"))
104          return()          return()
     ref.line <- trellis.par.get("reference.line")  
105      if (side == "right") {      if (side == "right") {
106          comp.list <- components[["right"]]          comp.list <- components[["right"]]
107          if (!is.list(comp.list))          if (!is.list(comp.list))
108              comp.list <- components[["left"]]              comp.list <- components[["left"]]
109          tck <- abs(comp.list$ticks$tck)          panel.refline(h = comp.list$ticks$at)
         panel.refline(h = comp.list$ticks$at,  
                       lwd = ref.line$lwd * tck,  
                       alpha = ref.line$alpha * tck / max(tck, na.rm = TRUE))  
110          ## draw axis line along bottom (assuming transparent axis.line)          ## draw axis line along bottom (assuming transparent axis.line)
111          lims <- current.panel.limits()          lims <- current.panel.limits()
112          panel.abline(h = lims$y[1], col = axis.text$col)          panel.abline(h = lims$y[1], col = axis.text$col)
# Line 116  Line 121 
121               par.settings =               par.settings =
122                 theEconomist.theme(with.bg = with.bg, box = "transparent"),                 theEconomist.theme(with.bg = with.bg, box = "transparent"),
123               with.bg = FALSE,               with.bg = FALSE,
              titleSpec = list(x = grid::unit(5, "mm"), just = "left"),  
124               par.strip.text = list(font = 2))               par.strip.text = list(font = 2))
125  {  {
126      ans <- x      ans <- x
# Line 124  Line 128 
128      title <- ans$main      title <- ans$main
129      if (is.null(title)) title <- ans$ylab      if (is.null(title)) title <- ans$ylab
130      if (is.null(title)) title <- ans$ylab.default      if (is.null(title)) title <- ans$ylab.default
131      if (!is.list(title)) title <- list(label = title)      ans <- update(ans, main = title,
     ans <- update(ans, main = modifyList(title, titleSpec))  
     if (!is.null(ans$sub)) {  
         sub <- ans$sub  
         if (!is.list(sub)) sub <- list(sub)  
         ans <- update(ans, sub = modifyList(sub, titleSpec))  
         ## would like to have 'sub' above plot (below main)  
         ## can't do it with a frameGrob because we lose the lattice style.  
 #            subGrob <- do.call(textGrob, modifyList(sub, titleSpec))  
 #            mainGrob <- do.call(textGrob, modifyList(title, titleSpec))  
 #            titleGrob <- frameGrob(name = "titleFrame")  
 #            titleGrob <- packGrob(titleGrob, mainGrob, side = "top")  
 #            titleGrob <- packGrob(titleGrob, subGrob, side = "bottom")  
 #            ans <- update(ans, main = titleGrob,  
 #                          sub = expression(NULL))  
     }  
     ans <- update(ans,  
132                    type = type, ylab = ylab, xlab = xlab,                    type = type, ylab = ylab, xlab = xlab,
133                    par.settings = par.settings,                    par.settings = par.settings,
134                    par.strip.text = par.strip.text,                    par.strip.text = par.strip.text,
135                    between = list(x = 1, y = 1),                    between = list(x = 0.8, y = 0.8),
136                    scales = list(y = list(axs = "i", alternating = 2)),                    scales = list(y = list(axs = "i", alternating = 2)),
137                    skip.boundary.labels = 0,                    skip.boundary.labels = 0,
138                    lattice.options = list(                    lattice.options = list(
139                    layout.widths =                    layout.widths =
140                    list(axis.left = list(x = 0, units = "char"),                    list(axis.left = list(x = 0, units = "char"),
141                         axis.right = list(x = 3, units = "char"))                         axis.right = list(x = 6, units = "char"))
142                    )                    )
143                    )                    )
144      ## these do not get through update()      ## these do not get through update()
145      ans$axis <- theEconomist.axis      ans$axis <- theEconomist.axis
146      ans$xscale.components <- xscale.components.subticks      ans$xscale.components <- xscale.components.subticks
     ans$yscale.components <- theEconomist.yscalecomps  
147      ans$call <- match.call()      ans$call <- match.call()
148      ans      ans
149  }  }

Legend:
Removed from v.164  
changed lines
  Added in v.165

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