symbolixau / colourvalues Goto Github PK

x <- factor(c("a","b"), levels = c("b","a"))

## summary should use the levels order
colour_values(x, summary = T)

#' Raster data to RGB
#'
#' Map a raster of numeric values to an RGB 3-layer raster brick.
#'
#' If no `col` is provided, the default image palette is used. The density
#' can be controlled with `n` and the mapping  with the optional
#' `breaks`. If `breaks` is included as well as `n`, `n` is ignored.
#'
#' Please note that this is fairly wasteful thing to do, the overall data is expanded
#' from a single layer to three - it fills a specific task which is to create
#' textures for 3D mapping, and this is the only way to do it currently. (Plus
#' sometimes it's handy for other reasons, creating PNGs etc.).
#' @param x raster of values (single layer only)
#' @param col function to generate colours, or a vector of hex colours
#' @param ... ignored
#' @param breaks optionally used to specify color mapping
#' @param n optionally used to specify density of colours from `col` (ignored if breaks is set)
#'
#' @return
#' @export
#' @name cv_rgb
#' @aliases raster_rgb stars_rgb
#' @examples
#' library(raster)
#' im <- raster_rgb(volcano)
#' plotRGB(im)
#' vv <- unique(quantile(volcano, seq(0, 1, length = 12)))
#' plotRGB(raster_rgb(volcano, breaks = vv))
#' plotRGB(raster_rgb(volcano, breaks = vv[-c(4, 6)], col = gray.colors(9)))
#' plotRGB(raster_rgb(volcano, n = 4))
#' plotRGB(raster_rgb(volcano, col = grey(seq(0.2, 0.8, by = 0.1))))
#'
#' plotRGB(raster_rgb(volcano, col = viridis::magma(24)))
raster_rgb <- function(x, col, ..., breaks = NULL, n = NULL) {
  ## for matrix input
  if (is.matrix(x)) {
    x <- raster::setExtent(raster::raster(x), raster::extent(0, ncol(x), 0, nrow(x)))
  }
  vv <- raster::values(x[[1L]])
  outcols <- cv_rgb(vv, col = col, ..., breaks = breaks, n = n)
  ## used to need to give a 3 layer brick to setValues, but one layer is enough it expands by the values given
  raster::setValues(raster::brick(x[[1]]), t(col2rgb(outcols)))
}
#' @name cv_rgb
#' @export
#' @examples
#' library(stars)
#' x <- st_as_stars(volcano)
#' plot(stars_rgb(x), rgb = 1:3)
#' plot(stars_rgb(x, col = gray.colors), rgb = 1:3)
#' plot(stars_rgb(x))
#' plot(stars_rgb(x, col = rainbow, breaks = c(94, 100, 120, 150, 195)), rgb = 1:3)
stars_rgb <- function(x, col, ..., breaks = NULL, n = NULL) {
  hex <- cv_rgb(x[[1L]], col = col, ..., breaks = breaks, n = n)  ## we aint proxy yet
  dm <- dim(x[[1L]])
  ## this is not completely proper stars fix-up yet :)
  out <- c(x, x, x, along = 3)
  out[[1L]] <- array(t(col2rgb(hex)), c(dm, 3L))
  out
}
#' @name cv_rgb
#' @export
cv_rgb <- function(x, col, ..., breaks = NULL, n = NULL) {
  if (missing(col)) {
    ## just not sure how to use hcl.colors to get a function, so ...
    col <- colorRampPalette(hcl.colors(12, "YlOrRd", rev = TRUE))
  }
  if (!is.null(breaks)) n <- length(breaks) - 1L
  if (is.function(col)) {
    if (is.null(n)) {
      n <- 24
    }
    col <- col(n)
  }
  ## scales::rescale(x)
  scl <- function(x) (x - min(x,na.rm= TRUE))/diff(range(x, na.rm = TRUE))
  if (!is.null(breaks)) {
    col <- colorRampPalette(col)(length(breaks) - 1)
    outcols <- col[cut(x, breaks)]
  } else {
    outcols <- col[scl(x) * (length(col) - 1) + 1]
  }
 outcols
}

vals <- c("a","b",NA_character_, "d", "e","f","g")
colourvalues::color_values( vals, summary = T)

$colours
[1] "#440154FF" "#414487FF" "#808080FF" "#2A788EFF" "#22A884FF" "#7AD151FF" "#FDE725FF"

$summary_values
[1] "a" "b" "d" "e" "f" "g" NA 

$summary_colours
[1] "#440154FF" "#443A83FF" "#31688EFF" "#21908CFF" "#35B779FF" "#8FD744FF" "#FDE725FF"

library(microbenchmark)
library(ggplot2)
library(scales)
library(viridisLite)

mkfun <-
  function (alpha = 1, begin = 0, end = 1, direction = 1, option = "D")
  {
    if (begin < 0 | begin > 1 | end < 0 | end > 1) {
      stop("begin and end must be in [0,1]")
    }
    if (abs(direction) != 1) {
      stop("direction must be 1 or -1")
    }
    if (direction == -1) {
      tmp <- begin
      begin <- end
      end <- tmp
    }
    option <- switch(EXPR = option, A = "A", magma = "A", B = "B",
                     inferno = "B", C = "C", plasma = "C", D = "D", viridis = "D",
                     E = "E", cividis = "E", {
                       warning(paste0("Option '", option, "' does not exist. Defaulting to 'viridis'."))
                       "D"
                     })
    map <- viridisLite::viridis.map[viridisLite::viridis.map$opt ==
                                      option, ]
    map_cols <- grDevices::rgb(map$R, map$G, map$B)
    grDevices::colorRampPalette(map_cols, space = "Lab",
                                interpolate = "spline")
  }

## a closure to pre-calc
fn_cols_ <- mkfun()
viridis_ <- function(n) {
  fn_cols_(n)
}


n <- 1e6
df <- data.frame(x = rnorm(n = n))
pal <- viridis::viridis(256)

m <- microbenchmark(
  RcppViridis = { RcppViridis::colour_values(x = df$x) },
  ## closure result, return value from colorRampPalette
  scales_prefun = {viridis_(256)[scales::rescale(df$x, to = c(1, 256))]},
  ## viridis() in its glory
  scales_live = {viridis::viridis(256)[scales::rescale(df$x, to = c(1, 256))]},
   ## cheating with a colour ramp saved already 
  scales_precache = {pal[scales::rescale(df$x, to = c(1, 256))]},
  #scales = { col_numeric(palette = rgb(subset(viridis.map, opt=="D")[, 1:3]), domain = range(df$x))(df$x) },
  times = 250
)
m


x <- data.frame(a = 10, x = 1:256)
x$rcpp <- RcppViridis::colour_values(x$x)
x$prefun <- viridis_(256)[scales::rescale(x$x, to = c(1, 256))]
x$live <- viridis::viridis(256)[scales::rescale(x$x, to = c(1, 256))]
x$precache <- pal[scales::rescale(x$x, to = c(1, 256))]

barplot(height = x$a, col = x$rcpp, border = NA, space = 0)
barplot(height = x$a, col = x$prefun, border = NA, space = 0)
barplot(height = x$a, col = x$live, border = NA, space = 0)
barplot(height = x$a, col = x$precache, border = NA, space = 0)

x <- rnorm(50)
x[25] <- NA

cols <- colour_values(x, n_summaries = 5)
cols$summary_values

df <- data.frame(a = 10, x = 1:2)
df$col <- colour_variables(df$x, palette = "viridis")
barplot(height = df$a, col = df$col, border = NA, space = 0)

n <- 2
df <- data.frame(a = 10, x = 1:n)
df$col <- scales::col_numeric(viridisLite::viridis(2), domain = df$x)(df$x)
barplot(height = df$a, col = df$col, border = NA, space = 0)

length(unique(colour_variables(1:256)))

m <- grDevices::colorRamp(c("red","green","blue","yellow"))(0:1000/1000)
colour_values(1, palette = m )  ## fine
colour_values("a", palette = m) ## error

x <- 1:10
x[c(3,9)] <- NA

colour_values(x, alpha = 1:10, n_summaries = 5)
$colours
 [1] "#44015400" "#4828781C" "#808080FF" "#31688E55" "#26838E71" "#1F9D898D" "#35B779AA" "#6CCE59C6" "#808080FF"
[10] "#FDE725FF"

$summary_values
[1] "1.00"  "3.25"  "5.50"  "7.75"  "10.00"

$summary_colours
[1] "#440154FF" "#3B528BFF" "#21908CFF" "#5DC963FF" "#FDE725FF"

colour_values(1L:20L, n_summaries = 5)
#...
$summary_values
[1]  1.00  5.75 10.50 15.25 20.00
#...

colour_values(1L:20L, n_summaries = 5)
#...
$summary_values
[1]  1  6 10 15 20
#...

  df <- data.frame(a = 10, x = 1:20)
  m <- matrix(c(rep(100, 4*25)), ncol = 4)
  df2$col <- colour_values(df2$x, palette = m)

colour_values( 1:256, begin = 0.0, end = 0.75 )

pal <- colourvalues::get_palette( "viridis" )[1:192, ]

l <- list(x = 1, y = 2, z = "a")
colour_values( l )

## benchmarking numbers vs categories
n <- 1e7
x <- rnorm(n = n)

library(stringi)
y <- do.call(paste0, Map(stri_rand_strings, n=n, length=c(5, 4, 1),
                         pattern = c('[A-Z]', '[0-9]', '[A-Z]')))


library(microbenchmark)

microbenchmark(
  numeric = { v1 <- colourvalues::colour_values( x ) },
  character = { v2 <- colourvalues::colour_values( y ) },
  times = 5
)


library(Rcpp)

cppFunction('Rcpp::NumericVector range_sort( Rcpp::NumericVector x) {
  //NumericVector y = clone(x);
  int n = x.size() - 1;
  std::sort(x.begin(), x.end());
  Rcpp::NumericVector rng(2);
  rng[0] = x[0];
  rng[1] = x[n];
  return rng;
}')

cppFunction('Rcpp::NumericVector range_min_max( Rcpp::NumericVector x) {
  //NumericVector y = clone(x);
  Rcpp::NumericVector rng(2);
  rng[0] = min( na_omit(x) );
  rng[1] = max( na_omit(x) );
  return rng;
}')

cppFunction('Rcpp::NumericVector for_min_max( Rcpp::NumericVector x ) {
  //NumericVector y = clone(x);
  int n = x.size();

  double min;
  double max;
  bool first_value = false;

  for( int i = 0; i < n; i++) {

    if( !ISNAN( x[i] ) ) {
      if( !first_value ) {
        min = x[i];
        max = x[i];
        first_value = true;
      } else {
        if( x[i] < min ) {
          min = x[i];
        } else if ( x[i] > max) {
          max = x[i];
        }
      }
    }
  }
  return NumericVector::create(min, max);
}')

cppFunction('Rcpp::NumericVector rng( Rcpp::NumericVector x) {
  NumericVector y = clone(x);
  return range(x);
}')

for_min_max(1:20)
rng(1:20)

n <- 1e7
x <- rnorm(n = n)

microbenchmark(
  range_sort = { range_sort( x ) },
  range_min_max = { range_min_max( x ) },
  for_min_max = { for_min_max( x ) },
  rng = { rng( x ) },
  times = 25
)

# Unit: milliseconds
#          expr      min       lq     mean   median       uq      max neval
#    range_sort 10.59129 11.61915 12.53094 12.47773 13.46021 14.14382    25
# range_min_max 78.81943 79.62402 83.29948 83.36582 85.20105 90.31657    25
#   for_min_max 33.78131 34.10332 35.19830 35.19227 35.75790 37.37187    25
#           rng 43.45526 46.92417 48.55556 48.48253 49.81096 53.31669    25

R version 3.6.2 (2019-12-12)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 7 x64 (build 7601) Service Pack 1

Matrix products: default

locale:
  [1] LC_COLLATE=English_United States.1252  LC_CTYPE=English_United States.1252   
[3] LC_MONETARY=English_United States.1252 LC_NUMERIC=C                          
[5] LC_TIME=English_United States.1252    

attached base packages:
  [1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
  [1] viridis_0.5.1      viridisLite_0.3.0  colourvalues_0.3.1

loaded via a namespace (and not attached):
  [1] splines_3.6.2         gtools_3.8.1          StanHeaders_2.19.0   
[4] threejs_0.3.1         shiny_1.4.0           assertthat_0.2.1     
[7] stats4_3.6.2          pillar_1.4.3          lattice_0.20-38      
[10] glue_1.3.1            digest_0.6.23         promises_1.1.0       
[13] minqa_1.2.4           colorspace_1.4-1      htmltools_0.4.0      
[16] httpuv_1.5.2          Matrix_1.2-18         plyr_1.8.5           
[19] dygraphs_1.1.1.6      pkgconfig_2.0.3       rstan_2.19.2         
[22] purrr_0.3.3           xtable_1.8-4          scales_1.1.0         
[25] processx_3.4.1        later_1.0.0           lme4_1.1-21          
[28] tibble_2.1.3          bayesplot_1.7.1       ggplot2_3.2.1        
[31] DT_0.11               shinyjs_1.0           lazyeval_0.2.2       
[34] cli_2.0.0             survival_3.1-8        magrittr_1.5         
[37] crayon_1.3.4          mime_0.8              ps_1.3.0             
[40] fansi_0.4.0           nlme_3.1-143          MASS_7.3-51.5        
[43] xts_0.11-2            pkgbuild_1.0.6        colourpicker_1.0     
[46] rsconnect_0.8.16      tools_3.6.2           loo_2.2.0            
[49] prettyunits_1.0.2     lifecycle_0.1.0       matrixStats_0.55.0   
[52] stringr_1.4.0         munsell_0.5.0         packrat_0.5.0        
[55] callr_3.4.0           compiler_3.6.2        rlang_0.4.2          
[58] grid_3.6.2            nloptr_1.2.1          ggridges_0.5.1       
[61] rstudioapi_0.10       rstanarm_2.19.2       htmlwidgets_1.5.1    
[64] crosstalk_1.0.0       igraph_1.2.4.2        miniUI_0.1.1.1       
[67] base64enc_0.1-3       boot_1.3-24           codetools_0.2-16     
[70] gtable_0.3.0          inline_0.3.15         markdown_1.1         
[73] reshape2_1.4.3        R6_2.4.1              gridExtra_2.3        
[76] rstantools_2.0.0.9000 zoo_1.8-6             dplyr_0.8.3          
[79] fastmap_1.0.1         shinystan_2.5.0       shinythemes_1.1.2    
[82] stringi_1.4.3         parallel_3.6.2        Rcpp_1.0.3           
[85] tidyselect_0.2.5     

library(colourvalues)
library(viridis)
set.seed(123)

x <- runif(10,-10,10)
y <- x
x
y
z <- color_values(y, palette = t(col2rgb(viridis::cividis(256, direction = -1))))
x
y

> x <- runif(10,-10,10)
> y <- x
> x
 [1] -4.2484496  5.7661027 -1.8204616  7.6603481  8.8093457 -9.0888700  0.5621098
 [8]  7.8483809  1.0287003 -0.8677053
> y
 [1] -4.2484496  5.7661027 -1.8204616  7.6603481  8.8093457 -9.0888700  0.5621098
 [8]  7.8483809  1.0287003 -0.8677053
> z <- color_values(y, palette = t(col2rgb(cividis(256, direction = -1))))
> x
 [1] 0.2704415 0.8299695 0.4060968 0.9358038 1.0000000 0.0000000 0.5392146 0.9463095
 [9] 0.5652837 0.4593287
> y
 [1] 0.2704415 0.8299695 0.4060968 0.9358038 1.0000000 0.0000000 0.5392146 0.9463095
 [9] 0.5652837 0.4593287

print_values <- function(x, ... ) {
  m <- colourvalues::colour_values_rgb(x, ...)
  ## copied from crayon:::ansi256_rgb_index
  v <- 16 + rowSums(floor(6 * m[,1:3] / 256 ) * matrix(c(36,6,1), ncol = 3, nrow = nrow(m), byrow = T)) + 1
  cat(paste0("\033[48;5;",v, 'm',x,"\033[39m"))
}

df <- data.frame(
  x = round( rnorm(500), 2 )
)

print_values( df$x, palette = "inferno" )

print_values( sort( df$x ), palette = "sequential_hcl" )

## benchmarking numbers vs categories
n <- 1e7
x <- rnorm(n = n)

library(stringi)
y <- do.call(paste0, Map(stri_rand_strings, n=n, length=c(5, 4, 1),
                         pattern = c('[A-Z]', '[0-9]', '[A-Z]')))


library(microbenchmark)

microbenchmark(
  numeric = { v1 <- colourvalues::colour_values( x ) },
  character = { v2 <- colourvalues::colour_values( y ) },
  times = 5
)

# Unit: seconds
#       expr       min        lq      mean    median       uq       max neval
#   numeric  1.609049  1.627812  1.849422  1.635453  1.67614  2.698658     5
# character 11.787047 11.852525 12.743274 12.068627 13.64671 14.361460     5

library(microbenchmark)
n <- 1e6
x <- c("a",NA, "d","f",NA)
y <- do.call(paste0, Map(stri_rand_strings, n=n, length=c(5, 4, 1),
                         pattern = c('[A-Z]', '[0-9]', '[A-Z]')))

y1 <- y2 <- y

colourvalues:::rcpp_string_to_number( c("a","b","a","c") )
colourvalues:::std_string_to_number( c("a","b","a","c") )

microbenchmark(
  std = { colourvalues:::std_string_to_number( y1 ) },
  rcpp = { colourvalues:::rcpp_string_to_number( y2 ) },
  times = 5
)
# Unit: milliseconds
# expr      min       lq     mean   median       uq      max neval
#  std 847.5170 853.7199 898.1696 867.4735 953.1030 969.0347     5
# rcpp 663.0899 667.6588 697.9915 678.4175 694.9871 785.8042     5

std = colourvalues:::std_sort_unique( y1 )
rcpp = colourvalues:::rcpp_sort_unique( y2 )

all.equal(std, rcpp)
# [1] TRUE

colourvalues::color_values(1:2, alpha = 1:2)

Error in rcpp_colour_num_value_string_palette_hex(x, palette, na_colour,  : 
  Interpolation using a cubic b spline with derivatives estimated at the endpoints requires at least 5 points.

# integer works as expected
set.seed(23)
v = sample.int(100, 10)
v
# [1] 58 23 33 69 79 41 91 94 78 93
clrs = colour_values_rgb(v, include_alpha = FALSE) / 255
v
# [1] 58 23 33 69 79 41 91 94 78 93

# numeric gets mumbled
set.seed(23)
v = as.numeric(sample.int(100, 10))
v
# [1] 58 23 33 69 79 41 91 94 78 93
clrs = colour_values_rgb(v, include_alpha = FALSE) / 255
v
# [1] 0.4929577 0.0000000 0.1408451 0.6478873 0.7887324 0.2535211 0.9577465 1.0000000 0.7746479 0.9859155

df <- data.frame(id = 1:5, o = rep(5,5))
colour_values(x = df$id, alpha = df$o )
df