hierarchical_color_palettes.R

extract_color_space <- function(hmin=0, hmax=360, cmin=0, cmax=180, lmin=0, lmax=100) {
  
  # This is a pared down version of the code to generate a 
  
  # Presently doesn't allow hmax > hmin (H is circular)
  # hmin: lower bound of hue (0-360)
  # hmax: upper bound of hue (0-360)
  # cmin: lower bound of chroma (0-180)
  # cmax: upper bound of chroma (0-180)
  # lmin: lower bound of luminance (0-100)
  # lmax: upper bound of luminance (0-100)
  
  require(colorspace)
  stopifnot(hmin >= 0, cmin >= 0, lmin >= 0, 
            hmax <= 360, cmax <= 180, lmax <= 100, 
            hmin <= hmax, cmin <= cmax, lmin <= lmax)
  
  lab <- LAB(as.matrix(expand.grid(seq(0, 100, 1), 
                                   seq(-100, 100, 5), 
                                   seq(-110, 100, 5))))
  if (any((hmin != 0 || cmin != 0 || lmin != 0 ||
           hmax != 360 || cmax != 180 || lmax != 100))) {
    hcl <- as(lab, 'polarLUV')
    hcl_coords <- coords(hcl)
    hcl <- hcl[which(hcl_coords[, 'H'] <= hmax & hcl_coords[, 'H'] >= hmin &
                       hcl_coords[, 'C'] <= cmax & hcl_coords[, 'C'] >= cmin & 
                       hcl_coords[, 'L'] <= lmax & hcl_coords[, 'L'] >= lmin), ]
    lab <- as(hcl, 'LAB')    
  }
  return(coords(lab[which(!is.na(hex(lab))), ]))
}

identify_color_hierarchy <- function(hierarchical_data, available_colors, weight_column = NULL){
  
  # take a hierarchy of categories (with optional weight)
  
  require(dplyr)
  
  # standardize formatting
  hierarchical_data <- hierarchical_data %>% ungroup
  # enforce that all names in hierarchy are unique
  # names cannot appear in multiple layers
  # names must have same parent
  
  tiers <- setdiff(colnames(hierarchical_data), weight_column)
  
  if(is.null(weight_column)){
    top_level <- hierarchical_data %>% select_(Category = tiers[1]) %>% count(Category)
  }else{
    top_level <- hierarchical_data %>% select_(Category = tiers[1], wt = weight_column) %>% count(Category, wt = wt)
  }
  color_clusters <- partition_colors(top_level, available_colors)
  
  track_colors <- data.frame(Tier = tiers[1], color_clusters$center_colors)
  partitioned_colors <- list()
  partitioned_colors[[tiers[1]]] <- color_clusters$partitioned_colors
  
  for(a_tier in tiers[-1]){
    
    parent_tier = tiers[which(a_tier == tiers)-1]
    parent_categories <- hierarchical_data %>% select_(.dots = parent_tier) %>% unlist() %>% unique
    
    partitioned_colors[[a_tier]] <- list()
    
    for(a_parent in parent_categories){
      
      filter_criteria <- lazyeval::interp(~ tier == entry,
                                          tier = as.name(parent_tier),
                                          entry = a_parent)
      
      if(is.null(weight_column)){
        a_level <- hierarchical_data %>%
          filter_(filter_criteria) %>%
          select_(Category = a_tier) %>% count(Category)
      }else{
        a_level <- hierarchical_data %>%
          filter_(filter_criteria) %>%
          select_(Category = a_tier, wt = weight_column) %>% count(Category, wt = wt)
      }
      
      if(nrow(a_level) == 1){
        # same membership as parent
        color_clusters <- list()
        color_clusters[["center_colors"]] <- data.frame(Category = a_level$Category,
                                                        Color = track_colors$Color[track_colors$Category == a_parent])
        color_clusters[["partitioned_colors"]][[a_level$Category]] <- partitioned_colors[[parent_tier]][[a_parent]]
        
      }else{
        # identify colors that are available to category
        parent_available_colors <- partitioned_colors[[parent_tier]][[a_parent]]
        # partition categories between daughters
        color_clusters <- partition_colors(a_level, parent_available_colors)
      }
      
      track_colors <- track_colors %>% bind_rows(
        data.frame(Tier = a_tier, color_clusters$center_colors))
      
      partitioned_colors[[a_tier]] <- append(partitioned_colors[[a_tier]], color_clusters$partitioned_colors) 
      
      }
    }

  return(track_colors)
}

partition_colors <- function(cluster_counts, available_colors){
  
  require(dplyr)
  
  kclust <- kmeans(available_colors, nrow(cluster_counts), iter.max = 50)
  
  cluster_attr <- cluster_counts %>%
    arrange(desc(n)) %>%
    mutate(cluster_num = order(kclust$size, decreasing = T))
  
  center_colors <- cluster_attr %>%
    select(Category) %>%
    mutate(Color = hex(LAB(kclust$centers[cluster_attr$cluster_num,])))
  
  partitioned_colors <- lapply(1:nrow(cluster_attr), function(i){
    available_colors[kclust$cluster == cluster_attr$cluster_num[i],]
  })
  names(partitioned_colors) <- cluster_attr$Category
  
  return(list(center_colors = center_colors, partitioned_colors = partitioned_colors))
  
}