Quantcast
Channel: Active questions tagged r - Stack Overflow
Viewing all articles
Browse latest Browse all 201894

How is this custom color palette function being passed the 'n' argument?

$
0
0

I'm using the attached R code to create a custom color palette in R, that returns hexadecimal values based on the number of levels. The attached code works perfectly, but I'm having trouble understanding how the code understands the number of levels in the input vector. 'N' is an argument in the function within the function (check_pal_n inside create_pal), but 'n' is not one of the arguments you can pass to 'create_pal'.

Obviously the code works, but I want to understand better how it is working. Any help is appreciated!

library(tidyverse)

# create a labeled list of colors
custom_color_hexcodes <- c(
  `blue`  = "#002F6C",
  `red`  = "#BA0C2F",
  `light blue`  = "#A7C6ED",
  `medium blue`  = "#006789",
  `dark red`  = "#631032",
  `web blue` = "#205493",
  `rich black`  = "#212721",
  `dark grey` = "#6C6463",
  `medium grey`= "#8C8983",
  `light grey`= "#CFCDC9")

# wrap that list in a callable function
custom_cols <- function(...) {
  cols <- c(...)
  if (is.null(cols))
    return (custom_color_hexcodes)
  custom_color_hexcodes[cols]
}


# There are 10 colors, so our max number of colors will be 10.
check_pal_n <- function(n, max_n) {
  if (n > max_n) {
    warning("This palette can handle a maximum of ", max_n, " values.",
            "You have supplied ", n, ".")
  } else if (n < 0) {
    stop("`n` must be a non-negative integer.")
  }
}


custom_pal <- function(fill=TRUE){
  colors <- custom_color_hexcodes
  if (fill){
    max_n <- 9
    f <- function(n) {
      check_pal_n(n, max_n)
      if (n == 1L) {
        i <- "blue"
      } else if (n == 2L) {
        i <- c("blue", "red")
      } else if (n == 3L) {
        i <- c("blue", "red", "light blue")
    } else if (n == 4L) {
      i <- c("blue", "red", "light blue", "dark red")
    } else if (n %in% 5:6) {
      ## 20120901_woc904
      i <- c("blue", "red", "light blue", "dark red",
             "dark grey", "light grey")
    } else if (n == 7L) {
      # 20120818_AMC820
      i <- c("blue", "red", "light blue", "dark red",
             "dark grey", "light grey", "medium blue")
    } else if (n >= 8L) {
      # 20120915_EUC094
      i <- c("blue", "red", "light blue", "dark red",
             "dark grey", "light grey", "medium blue", "rich black")
    }
    unname(colors[i][seq_len(n)])
  }
} else {
  max_n <- 9
  f <- function(n) {
    check_pal_n(n, max_n)
    if (n <= 3) {
      i <- c("blue", "red", "light blue")
    } else if (n %in% 4:5) {
      # i <- c("blue", "red", "light blue", "dark red")
      i <- c("blue", "red", "light blue", "dark red", "dark grey")
    } else if (n == 6) {
      # 20120825_IRC829
      i <- c("blue", "red", "light blue", "dark red",
             "dark grey", "light grey")
    } else if (n > 6) {
      # 20120825_IRC829
      i <- c("blue", "red", "light blue", "dark red",
             "dark grey", "light grey", "medium blue", "rich black",
             "web blue", "medium grey")
      }
      unname(colors[i][seq_len(n)])
    }
  }
  attr(f, "max_n") <- max_n
  f
}


scale_colour <- function(...) {
  discrete_scale("colour", "custom_cols", custom_pal(), ...)
}

scale_fill <- function(...) {
  discrete_scale("fill", "custom_cols", custom_pal(), ...)
}

Viewing all articles
Browse latest Browse all 201894

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>