data-raw/hexwall.R

In saiemgilani/sportsdataverse-R: Easily Install and Load the 'SportsDataverse'

# Dependencies
library(magick)
library(purrr)

# path:             The path to a folder of hexagon stickers
# sticker_row_size: The number of stickers in the longest row
# sticker_width:    The width of each sticker in pixels
# remove_small:     Should hexagons smaller than the sticker_width be removed?
# coords:           A data.frame of coordinates defining the placement of hexagons
# scale_coords:     Should the coordinates be scaled to the hexagon size?
# remove_size:      Should hexagons of an abnormal size be removed?
# sort_mode:        How should the files be sorted?
# background_color: The colour of the background canvas
# n_stickers:       The number of hexagons to produce. Recycled in file order.
hexwall <- function(path="data-raw/samplehex",
                    sticker_row_size = 5,
                    sticker_width = 500,
                    remove_small = TRUE,
                    total_stickers = 18,
                    remove_size = TRUE,
                    coords = NULL,
                    scale_coords = TRUE,
                    sort_mode = c("filename", "random", "color", "colour"),
                    background_color = 'transparent',
                    n_stickers = NULL){
  sort_mode <- match.arg(sort_mode)

  # Load stickers
  sticker_files <- list.files(path)
  if(is.null(n_stickers)) n_stickers <- length(sticker_files)
  sticker_files <- rep_len(sticker_files, n_stickers)
  stickers <- file.path(path, sticker_files) %>%
    map(function(path){
      switch(tools::file_ext(path),
             svg = image_read_svg(path),
             pdf = image_read_pdf(path),
             image_read(path))
    }) %>%
    map(image_transparent, "transparent") %>%
    map(image_trim) %>%
    set_names(sticker_files)

  # Low resolution stickers
  low_res <- stickers %>%
    map_lgl(~ remove_small && image_info(.x)$width < (sticker_width-1)/2 && image_info(.x)$format != "svg")
  which(low_res)

  stickers <- stickers %>%
    map(image_scale, sticker_width)

  # Incorrectly sized stickers
  bad_size <- stickers %>%
    map_lgl(~ remove_size && with(image_info(.x), height < (median(height)-2) | height > (median(height) + 2)))
  which(bad_size)

  # Remove bad stickers
  sticker_rm <- low_res | bad_size
  stickers <- stickers[!sticker_rm]

  if(any(sticker_rm)){
    message(sprintf("Automatically removed %i incompatible stickers: %s",
                    sum(sticker_rm), paste0(names(sticker_rm[sticker_rm]), collapse = ", ")))
  }

  if(is.null(total_stickers)){
    if(!is.null(coords)){
      total_stickers <- NROW(coords)
    }
    else{
      total_stickers <- length(stickers)
    }
  }

  # Coerce sticker sizes
  sticker_height <- stickers %>%
    map(image_info) %>%
    map_dbl("height") %>%
    median
  stickers <- stickers %>%
    map(image_resize, paste0(sticker_width, "x", sticker_height, "!"))

  # Repeat stickers sorted by file name
  stickers <- rep_len(stickers, total_stickers)

  if(sort_mode == "random"){
    # Randomly arrange stickers
    stickers <- sample(c(stickers, sample(stickers, total_stickers - length(stickers), replace = TRUE)))
  }
  else if(sort_mode %in% c("color", "colour")){
    # Sort stickers by colour
    sticker_col <- stickers %>%
      map(image_resize, "1x1!") %>%
      map(image_data) %>%
      map(~paste0("#", paste0(.[,,1], collapse=""))) %>%
      map(colorspace::hex2RGB) %>%
      map(as, "HSV") %>%
      map_dbl(~.@coords[,1]) %>%
      sort(index.return = TRUE) %>%
      .$ix

    stickers <- stickers[sticker_col]
  }

  if(is.null(coords)){
    # Arrange rows of stickers into images
    sticker_col_size <- ceiling(length(stickers)/(sticker_row_size-0.5))
    row_lens <- rep(c(sticker_row_size,sticker_row_size-1), length.out=sticker_col_size)
    row_lens[length(row_lens)] <- row_lens[length(row_lens)]  - (length(stickers) - sum(row_lens))
    sticker_rows <- map2(row_lens, cumsum(row_lens),
                         ~ seq(.y-.x+1, by = 1, length.out = .x)) %>%
      map(~ stickers[.x] %>%
            invoke(c, .) %>%
            image_append)

    # Add stickers to canvas
    canvas <- image_blank(sticker_row_size*sticker_width,
                          sticker_height + (sticker_col_size-1)*sticker_height/1.33526, "white")
    reduce2(sticker_rows, seq_along(sticker_rows),
            ~ image_composite(
              ..1, ..2,
              offset = paste0("+", ((..3-1)%%2)*sticker_width/2, "+", round((..3-1)*sticker_height/1.33526))
            ),
            .init = canvas)
  }
  else{
    sticker_pos <- coords
    if(scale_coords){
      sticker_pos <- sticker_pos %>%
        as_tibble %>%
        mutate_all(function(x){
          x <- x-min(x)
          dx <- diff(sort(abs(x)))
          x / min(dx[dx!=0])
        }) %>%
        mutate(y = y / min(diff(y)[diff(y)!=0])) %>%
        mutate(x = x*sticker_width/2,
               y = abs(y-max(y))*sticker_height/1.33526)
    }

    # Add stickers to canvas
    canvas <- image_blank(max(sticker_pos$x) + sticker_width,
                          max(sticker_pos$y) + sticker_height, background_color)
    reduce2(stickers, sticker_pos%>%split(1:NROW(.)),
            ~ image_composite(
              ..1, ..2,
              offset = paste0("+", ..3$x, "+", ..3$y)
            ),
            .init = canvas)
  }
}
png <- hexwall()
magick::image_write(magick::image_scale(png,geometry="1000"), path = "man/figures/sdv-wall.png", format = "png")