R/palette-fns.R

In doehm/myPalettes: Discover colour palettes

#' Get a palette
#'
#' Gets a palette from colour lovers or builds one from a custom palette
#'
#' @param method Either random hue or a use defined one (see details)
#' @param show Prints a colour scale
#' @param bg_hue Background hue (see details)
#' @param custom_pal A custom palette. Can be any number of hex codes
#' @param k Number of colours to generate
#' @param id ID of user on colorlovers
#' @param image Location of the image from which to extract a palette
#' @param custom_bg A custom background colour. Baically just adds it to the object.
#'
#' @details Hue can be monochrome, blue, red, green, yellow, pink, purple, orange or random. Utilises the random colour package.
#' @importFrom colourlovers clpalettes clpalette swatch
#' @importFrom randomcoloR randomColor
#' @return
#' @export
#'
#' @examples
get_palette <- function(method = 'random', show = TRUE, k = NULL, bg_hue = "monochrome", custom_pal = NULL, custom_bg = NULL,
                        id = NULL, image = NULL){

  if(is.null(k)) k <- 5

  # custom palette
  if(!is.null(custom_pal)){
    pal_n <- custom_pal
    api_call <- NULL

  # id for colourlovers
  }else if(!is.null(id)){
    api_call <- clpalette(id = id)
    pal_n <- sort(swatch(api_call)[[1]])
    pal_n <- pal_n[get_pal_order(pal_n)]

  # get palette from image
  }else if(!is.null(image)){
    api_call <- image
    if(!method %in% c('max', 'kmeans')) stop('if using an image, method must be either "max" or "kmeans"')
    pal_n <- get_pal_from_image(image, k = k, method = method)
    pal_n <- pal_n[get_pal_order(pal_n)]

  # get palette from colourlovers
  }else{
    api_call <- clpalettes(method)
    pal_n <- sort(swatch(api_call)[[1]])
    pal_n <- pal_n[get_pal_order(pal_n)]
  }

  if(!is.null(k)) pal_n <- colorRampPalette(colors = pal_n)(k)

  bg <- randomColor(luminosity = "light", hue = bg_hue)

  if(!is.null(custom_bg)) {
    bg = custom_bg
  }

  p <- list(
    pal = pal_n,
    bg = bg,
    source = api_call
  )

  if(show) print(show_palette(p))

  return(p)
}



#' Hue
#'
#' Gets hue from a colour palette
#'
#' @param pal The hex code for a colour
#'
#' @return
#' @export
#'
#' @importFrom grDevices col2rgb rgb2hsv
#'
#' @examples
get_pal_order <- function(pal){
  .rgb <- t(col2rgb(pal))
  .rgb <- cbind(.rgb, t(rgb2hsv(.rgb[,1], .rgb[,2], .rgb[,3])))
  d <- dist(.rgb)
  begin <- which(pal == sort(pal)[1])
  as.numeric(names(sort(as.matrix(d)[begin,])))
}






#' Gradient Descending palette function
#'
#' Generates a colour palette function for a discrete or continuous scale
#'
#' @param p The palette object
#' @param discrete Logical. Is the aesthetic discrete?
#' @param reverse Logical. Reverse the palette?
#'
#' @return
#' @export
#'
#' @importFrom grDevices colorRampPalette
#'
#' @examples
gd_pal <- function(p = active_palette, discrete = TRUE, reverse = FALSE) {
  cols <- p$pal
  if(reverse) cols <- rev(cols)
  if(discrete){
    function(n) {
      colorRampPalette(cols)(n)
    }
  }else{
    function(n) {
      colorRampPalette(cols)(200)[floor(n*199)+1]
    }
  }
}




#' Show palette
#'
#' Shows the palette
#'
#' @param p Palette object
#' @param n Number of colours to show. Defaults to c(length(pal), 200)
#' @param bg Which background to show
#'
#' @return
#' @export
#'
#' @import ggplot2
#'
#' @examples
show_palette <- function(p = active_palette, n = NULL, bg = NULL){

  if(is.null(n)) n <- c(length(p$pal), 200)
  if(is.null(bg)) {
    bg <- "white"
  }else{
    bg <- p$bg[[bg]]
  }

  x <- seq(0, 1, length = n[1]+1)
  y <- c(0.05, 1)
  type <- paste0("x", 1:(n[1]+1))
  df1 <- data.frame(xmin = x[-(n[1]+1)], xmax = x[-1]+0.001, ymin = y[1], ymax = y[2], type = type[-1])

  x <- seq(0, 1, length = n[2]+1)
  y <- c(-1, -0.05)
  type <- paste0("x", 1:(n[2]+1))
  df2 <- data.frame(xmin = x[-(n[2]+1)], xmax = x[-1]+0.001, ymin = y[1], ymax = y[2], type = type[-1])

  x_text <- seq(0, 1, length = n[1]+1)
  d <- mean(df1$xmin[1:2])
  g <- ggplot() +
    theme_void() +
    annotate("rect", xmin = df2$xmin-d, xmax = df2$xmax+d, ymin = -1.25, ymax = 1.25, fill = bg) +
    annotate("rect", xmin = df1$xmin, xmax = df1$xmax, ymin = df1$ymin, ymax = df1$ymax, fill = colorRampPalette(p$pal)(n[1])) +
    annotate("rect", xmin = df2$xmin, xmax = df2$xmax, ymin = df2$ymin, ymax = df2$ymax, fill = colorRampPalette(p$pal)(n[2]))
    # annotate("text", x = x_text[-1]-1/(2*n[1]), y = 0, label = 1:n[1])

  return(g)
}




#' Switch palette colours
#'
#' Switch the order of colours in the palette
#'
#' @param p Palette object
#' @param id ID of the new positions e.g. c(2, 1, 3, 4)
#'
#' @return
#' @export
#'
#' @examples
switch_cols <- function(p, id){
  p$pal <- p$pal[id]
  print(show_palette(p))
  return(p)
}


#' Scale fill aesthetic
#'
#' Generalises the scale aesthetics
#'
#' @param p Palette object
#' @param discrete Logical. Is the aesthetic discrete?
#' @param reverse Logical. Reverse the palette?
#' @param ... Dots
#'
#' @return
#' @export
#'
#' @import ggplot2
#'
#' @examples
scale_fill_gd <- function(p = active_palette, discrete = TRUE, reverse = FALSE, ...) {
  if(discrete){
    ggplot2::discrete_scale("fill", "gd", gd_pal(p, reverse = reverse, ...))
  }else{
    ggplot2::continuous_scale("fill", "gd", gd_pal(p, FALSE, reverse = reverse), guide = "colorbar", ...)
  }
}



#' Scale colour aesthetic
#'
#' Generalises the scale aesthetics
#'
#' @param p Palette object
#' @param discrete Logical. Is the aesthetic discrete?
#' @param reverse Logical. Reverse the palette?
#' @param ... Dots
#'
#' @return
#' @export
#'
#' @import ggplot2
#'
#' @examples
scale_colour_gd <- function(p = active_palette, discrete = TRUE, reverse = FALSE, ...) {
  if(discrete){
    ggplot2::discrete_scale("colour", "gd", gd_pal(p, reverse = reverse), ...)
  }else{
    ggplot2::continuous_scale("colour", "gd", gd_pal(p, FALSE, reverse = reverse), guide = "colorbar", ...)
  }
}






#' New background colour
#'
#' @description Randomly chooses a new background colour
#'
#' @param p The palette object
#' @param bg_hue The hue of the background (see details)
#' @details Hue can be monochrome, blue, red, green, yellow, pink, purple, orange or random. Utilises the random colour package.
#'
#' @return
#' @export
#'
#' @importFrom randomcoloR randomColor
#'
#' @examples
new_bg <- function(p, bg_hue) {
  p$bg <- randomColor(luminosity = "light", hue = bg_hue)
  return(p$bg)
}






#' Load font
#'
#' Grabs the user defined Google font
#'
#' @param font Google font name
#'
#' @description Loads the font Bitter from Google Fonts
#'
#' @details Some good fonts: Viga, Bitter, Abel, Raleway
#'
#' @return
#' @export
#'
#' @importFrom showtext showtext_auto
#' @importFrom sysfonts font_add_google
#'
#' @examples
load_font <- function(font){
  font_add_google(font, "userfont")
  message(font, " added and saved as 'userfont'")
  showtext_auto()
}




#' Gradient Descending theme
#'
#' @description Creates the theme object
#'
#' @param bg The background colour
#' @param scale Scalar for fixing font sizes
#' @param font Default 'userfont', output from load_font()
#'
#' @return
#' @export
#'
#' @import ggplot2
#'
#' @examples
theme_gd <- function(bg = NULL, scale = 1, font = "userfont") {

  font_col <- "grey10"
  if(is.null(bg)) bg <- active_palette$bg
  if(mean(col2rgb(bg)) < 255/3) font_col <- "white"
  theme_minimal() +
    theme(
      plot.title = element_text(family = font, colour = font_col, size = 26*scale, hjust = 0.5, face = "bold", lineheight = 0.5,
                                margin = margin(1, 0, 1, 0, "cm")),
      plot.subtitle = element_text(family = font, colour = font_col, size = 22*scale, hjust = 0.5),
      plot.caption = element_text(family = font, colour = font_col, size = 12*scale, margin = margin(1, 0, 1, 0, "cm")),
      axis.title.y = element_text(family = font, colour = font_col, size = 16*scale, margin = margin(0, 1, 0, 1, "cm")),
      axis.title.x = element_text(family = font, colour = font_col, size = 16*scale, margin = margin(1, 0, 1, 0, "cm")),
      axis.text = element_text(family = font, colour = font_col, size = 12*scale),
      legend.title = element_text(family = font, colour = font_col, size = 12*scale),
      legend.text = element_text(family = font, colour = font_col, size = 12*scale),
      plot.background = element_rect(fill = bg, colour = NA),
      panel.background = element_rect(fill = bg, colour = NA),
      legend.background = element_rect(fill = bg, colour = NA),
      legend.box.background = element_rect(fill = bg, colour = NA),
      panel.grid = element_line("grey40")
    )
}


#' Gradient Descending theme
#'
#' @description Creates the wide theme object
#'
#' @param bg The background colour
#' @param scale Scalar for fixing font sizes
#' @param font Default 'userfont', output from load_font()
#'
#' @return
#' @export
#'
#' @import ggplot2
#'
#' @examples
theme_gd_wide <- function(bg = NULL, scale = 1, font = "userfont") {

  font_col <- "grey10"
  if(is.null(bg)) bg <- active_palette$bg
  if(mean(col2rgb(bg)) < 255/3) font_col <- "white"
  theme_minimal() +
    theme(
      plot.margin = margin(0, 2, 0, 2, "in"),
      plot.title = element_text(family = font, colour = font_col, size = 26*scale, hjust = 0.5, face = "bold", lineheight = 0.35,
                                margin = margin(1.5, 1, 0.25, 1, "in")),
      plot.subtitle = element_text(family = font, colour = font_col, size = 12*scale, hjust = 0.5, margin = margin(0, 0, 0.25, 0, "in"), lineheight = 0.35,),
      plot.caption = element_text(family = font, colour = font_col, size = 12*scale, margin = margin(0, 0, 0.25, 0, "in")),
      axis.title.y = element_text(family = font, colour = font_col, size = 16*scale, margin = margin(0, 1, 0, 1, "in")),
      axis.title.x = element_text(family = font, colour = font_col, size = 16*scale, margin = margin(0.5, 0, 1, 0, "in")),
      axis.text = element_text(family = font, colour = font_col, size = 12*scale),
      legend.title = element_text(family = font, colour = font_col, size = 12*scale),
      legend.text = element_text(family = font, colour = font_col, size = 12*scale),
      plot.background = element_rect(fill = bg, colour = NA),
      panel.background = element_rect(fill = bg, colour = NA),
      legend.background = element_rect(fill = bg, colour = NA),
      legend.box.background = element_rect(fill = bg, colour = NA),
      panel.grid = element_line("grey40")
    )
}



#' Test plots
#'
#' Plots 4 examples of different types and aesthetics. Allows you to
#'
#' @param p The palette object
#' @param bg The background
#' @param save File name to save plot
#' @param scale Scalar for theme_gd()
#' @param reverse Default FALSE
#'
#' @return
#' @import ggplot2
#' @import dplyr
#' @import png
#' @import patchwork
#' @importFrom gridExtra grid.arrange
#' @export
#'
#' @examples
plot_test <- function(p, bg = NULL, save = NULL, scale = 2, reverse = FALSE) {

  bg <- p$bg

  line_col <- "grey20"
  if(mean(col2rgb(bg)) < 255/3) line_col <- "grey80"

  df <- data.frame(x = rnorm(1e4), y = rnorm(1e4)) %>%
    mutate(d = sqrt(x^2+y^2))

  # fill gradient test
  g_fill_cont <- ggplot(df, aes(x = x, y = y, col = d)) +
    geom_hex(size = 3) +
    scale_fill_gd(p, discrete = FALSE, reverse = reverse) +
    theme_gd(bg, scale = scale) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_blank(),
      plot.margin = unit(c(2,2,2,2), "cm"),
      legend.position = "none",
      axis.title = element_blank()
    ) +
    labs(
      title = "Fill (Continuous)"
    ) +
    coord_cartesian(xlim = c(-5, 5))

  g_col_cont <- ggplot2::mpg %>%
    ggplot(aes(x = cty, y = hwy, col = displ)) +
    geom_point(size = 6*scale) +
    scale_colour_gd(p, FALSE, reverse = reverse) +
    theme_gd(bg, scale = scale) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_line(linetype = 2),
      plot.margin = unit(c(2,2,2,2), "cm")
    ) +
    labs(
      title = "Colour (Continuous)",
      y = "Miles per gallon (highway)",
      x = "Miles per gallon (city)",
      colour = "Engline\nDisplacement"
    ) +
    guides(colour = guide_colourbar(barwidth = 2*scale, barheight = 10*scale))


  # fill test
  g_fill_dis <- ggplot2::mpg %>%
    ggplot(aes(x = displ, fill = class)) +
    geom_histogram(col = "grey20") +
    scale_fill_gd(p, TRUE, reverse = reverse) +
    scale_colour_gd(p, TRUE, reverse = reverse) +
    theme_gd(bg, scale = scale) +
    theme(
      panel.grid.major = element_blank(),
      panel.grid.minor = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank(),
      plot.margin = unit(c(2,2,2,2), "cm")
    ) +
    labs(
      title = "Fill (Discrete)",
      x = "Engine size (L)",
      fill = "Class"
    ) +
    guides(fill = guide_legend(keywidth = 2*scale, keyheight = 2*scale))

  # colour test
  g_col_dis <- ggplot2::mpg %>%
    ggplot(aes(x = displ, y = hwy, col = as.factor(cyl))) +
    geom_point(size = 6*scale) +
    scale_colour_gd(p, TRUE, reverse = reverse) +
    theme_gd(bg, scale = scale) +
    theme(
      panel.grid.minor = element_blank(),
      panel.grid.major = element_line(linetype = 2),
      plot.margin = unit(c(2,2,2,2), "cm")
    ) +
    labs(
      title = "Colour (Discrete)",
      y = "Miles per gallon (highway)",
      x = "Engine displacement",
      colour = "Cylinders"
    ) +
    guides(colour = guide_legend(keywidth = 2*scale, keyheight = 2*scale))


  # print plots
  if(is.null(save)){
    grid.arrange(g_col_cont, g_fill_cont, g_col_dis, g_fill_dis)
  }else{
    png(save, height = 2*1080, width = 2*1920)
    grid.arrange(g_col_cont, g_fill_cont, g_col_dis, g_fill_dis)
    dev.off()
  }
}









#' Choose background
#' @description Manually choose background from a selection given the hue. (Temp until I work on a better option)
#'
#' @param p Palette object
#' @param bg_hue Background hue
#'
#' @details Reading from left to right 1-5, second row 6-10, etc
#'
#' @importFrom grDevices colorRampPalette
#' @importFrom glue glue
#'
#' @return
#' @export
#'
#' @examples
choose_bg <- function(p, bg_hue = NULL){

  curr <- p$bg

  # set colours to shoose from
  l <- 0
  while (l == 0) {

    if(!is.null(bg_hue)) p$bg <- new_bg(p, bg_hue = bg_hue)
    n <- 12
    bg <- colorRampPalette(c("white", p$bg, "black"))(n)

    # plot palette
    x <- seq(0, 1, length = n[1]+1)
    y <- c(0.05, 1)
    type <- paste0("x", 1:(n[1]+1))
    df1 <- data.frame(xmin = x[-(n[1]+1)], xmax = x[-1]+0.001, ymin = y[1], ymax = y[2], type = type[-1])
    g <- ggplot() +
      theme_void() +
      annotate("rect", xmin = df1$xmin, xmax = df1$xmax, ymin = df1$ymin, ymax = df1$ymax, fill = colorRampPalette(bg)(n[1])) +
      annotate("rect", xmin = min(df1$xmin), xmax = max(df1$xmax), ymin = 1, ymax = 1.2, fill = curr) +
      annotate("text", x = x[-1]-1/(2*n), y = 0, label = 1:n)
    print(g)

    message(glue("choose background (1-20)\nselect 0 to reset selection\n"))
    l <- as.numeric(readline(": "))

  }

  p$bg <- bg[l]
  return(p)
}



#' Select palette
#'
#' Function to select from the list of palettes saved
#'
#' @param dir Path. Defauls to normal root dir
#'
#' @return
#' @export
#'
#' @importFrom purrr map_dfr
#' @importFrom stringr str_extract
#'
#' @examples
choose_palette <- function(dir = .libPaths()){
  palettes_df <- map_dfr(dir, ~{
    tibble(
      palettes = list.files(paste0(.x, "/myPalettes/data")),
      palettes_full = list.files(paste0(.x, "/myPalettes/data"), full.names = TRUE),
      name = str_extract(palettes, "[a-z0-9\\-[:space:]]+")
      )
    })
  selected_palette <- select.list(palettes_df$name)
  palette_file <- palettes_df$palettes_full[which(palettes_df$name == selected_palette)]
  p <- readRDS(palette_file)
  print(show_palette(p))
  active_palette <<- p
  message(glue("{selected_palette} set to active palette"))
}






# palette from image

#' Get palette from image
#'
#' Takes an image and creates a palette
#'
#' @param pic Image
#' @param k Number of colours
#' @param method Method. Available options: max, kmeans
#' @param seed Set seed for kmeans
#'
#' @return
#' @export
#'
#' @importFrom magick image_read
#'
#' @examples
get_pal_from_image <- function(pic, k, method = "max", seed = sample(1:1e4, 1)){

  if(!is.null(seed)) set.seed(seed)
  message("seed: ", seed)

  # pic <- image_read(path)
  cols <- sample(as.raster(pic), 1e3)

  # max
  if(method == "max"){ # fix this it's shit
    pal <- cols[get_pal_order(cols)]
    id <- seq(1, length(cols), k + 2)[-c(1, length(cols))]
    pal <- pal[id]

  # kmeans
  }else if(method == "kmeans"){
    cols_rgb <- t(col2rgb(cols))/255
    km <- kmeans(cols_rgb, k, nstart = 100)
    pal <- rgb(km$centers[,1], km$centers[,2], km$centers[,3])
  }

  return(pal)
}



#' Save a palette
#'
#' @param pal Palette object
#' @param name Name of palette object
#' @param loc
#'
#' @return
#' @export
#'
#' @importFrom readr write_rds
#'
#' @examples
save_palette <- function(pal, name, loc = getwd()) {
  # loc <- .libPaths()[1]
  write_rds(pal, glue("{loc}/{name}.rds"))
}