suppressPackageStartupMessages({
library("dplyr")
library("purrr")
library("tibble")
library("rlang")
library("yaml")
library("xml2")
})
utf_8_to_pch <- function(x) {
as.integer(-1L * map_int(x, ~ utf8ToInt(.x)[[1]]))
}
ggthemes_data <- new_environment()
load_stata <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "stata.yml"))
out$colors$names <- map_dfr(out$colors$names, as_tibble)
for (i in names(out$colors$schemes)) {
out$colors$schemes[[i]] <-
tibble(name = out$colors$schemes[[i]]) %>%
left_join(out$colors$names, by = "name")
}
out$shapes <- select(map_dfr(out$shapes, as_tibble), -comment) %>%
mutate(pch = utf_8_to_pch(character))
out
}
ggthemes_data$stata <- load_stata()
load_economist <- function() {
out <- yaml.load_file(here::here(
"data-raw", "theme-data",
"economist.yml"
))
map(out, ~ map_dfr(., as_tibble))
}
ggthemes_data$economist <- load_economist()
load_few <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "few.yml"))
out$colors <- map(out$colors, ~ map_dfr(., as_tibble))
out$shapes <- map_dfr(out$shapes, as_tibble)
out
}
ggthemes_data$few <- load_few()
load_wsj <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "wsj.yml"))
out$bg <- set_names(map_chr(out$bg, "value"), map_chr(out$bg, "name"))
out$palettes <- map(out$palettes, ~ map_dfr(., as_tibble))
out
}
ggthemes_data$wsj <- load_wsj()
load_colorblind <- function() {
yaml.load_file(here::here(
"data-raw", "theme-data",
"colorblind.yml"
)) %>%
map_dfr(as_tibble)
}
ggthemes_data$colorblind <- load_colorblind()
load_ptol <- function() {
yaml.load_file(here::here("data-raw", "theme-data", "pault.yml"))
}
ggthemes_data$ptol <- load_ptol()
load_manyeyes <- function() {
yaml.load_file(here::here("data-raw", "theme-data", "manyeyes.yml"))
}
ggthemes_data$manyeyes <- load_manyeyes()
load_fivethirtyeight <- function() {
yaml.load_file(here::here("data-raw", "theme-data", "fivethirtyeight.yml")) %>%
map_dfr(as_tibble)
}
ggthemes_data$fivethirtyeight <- load_fivethirtyeight()
tableau_palette <- function(x) {
out <- list(
name = xml_attr(x, "name"),
type = xml_attr(x, "type")
)
out$colors <- tibble(value = rev(map_chr(xml_children(x), xml_text)))
out
}
tableau_classic <- function() {
read_xml(here::here("data-raw", "theme-data", "tableau-classic.xml")) %>%
xml_children() %>%
map(tableau_palette)
}
load_tableau <- function() {
tableau <- yaml.load_file(here::here("data-raw", "theme-data", "tableau.yml"))
tableau[["color-palettes"]] <- map(
tableau[["color-palettes"]],
function(x) {
map(x, ~ map_dfr(., as_tibble))
}
)
tableau[["shape-palettes"]] <- map(tableau[["shape-palettes"]], function(x) {
map_dfr(x, as_tibble) %>%
mutate(pch = utf_8_to_pch(character))
})
classic <- tableau_classic()
for (pal in classic) {
tableau[["color-palettes"]][[pal[["type"]]]][[pal[["name"]]]] <-
pal[["colors"]]
}
tableau
}
ggthemes_data$tableau <- load_tableau()
best_colors <- function(colors, accent, n = 1) {
othercolors <- setdiff(names(colors), accent)
solarized <- as(as(colorspace::hex2RGB(colors), "LAB")@coords, "matrix")
solarized_dist <- as.matrix(dist(solarized, method = "euclidean"))
total_dist <- function(i) {
sum(solarized_dist[i, i][lower.tri(diag(length(i)))])
}
if (n == 1L) {
colorlist <- accent
} else {
combinations <- combn(othercolors, n - 1)
maxdist <-
which.max(apply(combinations, 2, function(x) total_dist(c(accent, x))))
colorlist <- c(accent, combinations[, maxdist])
}
unname(colors[colorlist])
}
load_solarized <- function(x) {
out <- yaml.load_file(here::here("data-raw", "theme-data", "solarized.yml"))
out$Accents <- map_dfr(out[["Accents"]], as_tibble)
out$Base <- map_dfr(out[["Base"]], as_tibble)
colors <- deframe(out[["Accents"]])
max_n <- length(colors)
out$palettes <- list()
for (accent in names(colors)) {
out$palettes[[accent]] <-
map(seq_len(max_n), ~ best_colors(colors, accent, .))
}
out
}
ggthemes_data$solarized <- load_solarized()
load_excel <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "excel.yml"))
out$shapes <- map_dfr(out$shapes, as_tibble) %>%
mutate(pch = utf_8_to_pch(character))
out$themes <-
yaml.load_file(here::here("data-raw", "theme-data", "excel-themes.yml"))
out
}
ggthemes_data$excel <- load_excel()
load_calc <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "libreoffice.yml")) %>%
map(~ map_dfr(., as_tibble))
out$shapes <- mutate(out$shapes, pch = utf_8_to_pch(character))
out
}
ggthemes_data$calc <- load_calc()
load_gdocs <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "gdocs.yml")) %>%
map(~ map_dfr(., as_tibble))
out$shapes <- mutate(out$shapes, pch = utf_8_to_pch(character))
out
}
ggthemes_data$gdocs <- load_gdocs()
load_shapes <- function() {
out <- yaml.load_file(here::here("data-raw", "theme-data", "shapes.yml"))
out$cleveland$default <- mutate(map_dfr(out$cleveland$default, as_tibble),
pch = utf_8_to_pch(character)
)
out$cleveland$overlap <- map_dfr(out$cleveland$overlap, as_tibble)
out$tremmel <- map(out$tremmel, ~ map_dfr(., as_tibble))
out$circlefill <- map_df(out$circlefill, as_tibble) %>%
mutate(pch = utf_8_to_pch(character))
out
}
ggthemes_data$shapes <- load_shapes()
load_hc <- function() {
yaml.load_file(here::here("data-raw", "theme-data", "hc.yml"))
}
ggthemes_data$hc <- load_hc()
# save
ggthemes_data <- as.list(ggthemes_data)
usethis::use_data(ggthemes_data, overwrite = TRUE)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.