a sketch of theme-like behaviour for base r plots

styles_sketch.R

# styles for plotting
library(default)

.old_par <- list()
.current_style <- list()
.shims <- new.env()

remove_shims <- function () {
  if ("shims" %in% search())
    detach ("shims")
}

add_shims <- function () {
  attach (.shims,
          name = "shims",
          warn.conflicts = FALSE)
}

set_default <- function (fun_name, value, package = "graphics") {
  
  ns <- asNamespace(package)
  fun <- get(fun_name, ns)
  default(fun) <- value
  
  unlockBinding(fun_name, ns)
  ns[[fun_name]] <- fun
  lockBinding(fun_name, ns)
  
  .shims[[fun_name]] <- fun
  
}

remove_default <- function (fun_name, package = "graphics") {
  
  ns <- asNamespace(package)
  fun <- get(fun_name, ns)
  fun <- reset_default(fun)
  
  unlockBinding(fun_name, ns)
  ns[[fun_name]] <- fun
  lockBinding(fun_name, ns)
  
  rm(list = fun_name, envir = .shims)
  
}

check_style <- function (list) {}

apply_defaults <- function (style) {
  
  package_styles <- style[names(style) != "par"]
  package_names <- names(package_styles)
  
  for (i in seq_along(package_styles)) {
    
    package <- package_styles[[i]]
    fun_names <- names(package)
    
    for (j in seq_along(package))
      set_default(fun_names[j], package[[j]], package = package_names[i])
    
  }
  
}

remove_defaults <- function () {
  
  package_styles <- .current_style[names(.current_style) != "par"]
  package_names <- names(package_styles)
  
  for (i in seq_along(package_styles)) {
    
    lapply(names(package_styles[[i]]),
           remove_default,
           package = package_names[i])
    
  }
  
}

# this stashes the par from before applying the style
get_old_par <- function (style) {
  op <- par(no.readonly = TRUE)
  op <- op[names(style$par)]
  .old_par <<- op
}

# export:
new_style <- function (..., inherit = list()) {
  list <- list(...)
  check_style(list)
  inherit[names(list)] <- list
  inherit
}

style <- function (style) {
  check_style()
  remove_style()
  .current_style <<- style
  get_old_par(style)
  par(style$par)
  apply_defaults(style)
  add_shims()
  invisible(NULL)
}

remove_style <- function() {
  remove_shims()
  par(.old_par)
  remove_defaults()
  .current_style <<- list()
}


# create a new style:
colour <- greta:::greta_col("dark")
colour_light <- scales::alpha(colour, 0.5)

better <- new_style(par = list(pch = 16,
                               fg = grey(0.6),
                               col.axis = grey(0.4),
                               col.lab = grey(0.2),
                               las = 1,
                               col.main = grey(0.4),
                               col.sub = grey(0.4),
                               tcl = -0.25),
                    graphics = list(axis = list(hadj = 0.5),
                                    hist.default = list(col = colour,
                                                        border = "white",
                                                        main = "",
                                                        ylab = "count"),
                                    plot.xy = list(col = colour,
                                                   lwd = 2.5,
                                                   cex = 1.5),
                                    barplot.default = list(col = colour,
                                                           border = NA,
                                                           space = 0.3),
                                    boxplot.default = list(col = colour_light,
                                                           border = colour,
                                                           pars = list(boxwex = 0.8,
                                                                       staplewex = 0.5,
                                                                       outwex = 0.5,
                                                                       cex = 1,
                                                                       whisklty = "solid")),
                                    title = list(line = 2)))


# use it for a bunch of different plots
plot_all <- function () {
  
  with(mtcars, hist(qsec))
  
  plot(mpg ~ wt, data = mtcars)
  
  tab <- tapply(mtcars$qsec, paste(mtcars$cyl, "cyl"), mean)
  barplot(tab, ylab = "qsec")
  
  boxplot(qsec ~ paste(mtcars$gear, "gear"),
          data = mtcars,
          ylab = "qsec")
  
}

plot_mat <- matrix(1:8, nrow = 2, byrow = FALSE)
layout(plot_mat)

plot_all()

style(better)
plot_all()

remove_style()

# need printing and inheritance for styles

# default still needs a way to handle calls/expressions?