tidyexplain/R/process_data_helpers.R

#' Preprocess data
#'
#' @param x a left dataset
#' @param y a right dataset
#' @param by a by argument for joins / set operations
#'
#' @return a preprocessed dataset
#'
#' @examples
#' NULL
preprocess_data <- function(x, y, by) {

  xvars <- names(x) %>% str_subset("^[^\\.]")
  yvars <- names(y) %>% str_subset("^[^\\.]")

  x <- x %>%
    unite(one_of(by), col = ".id", remove = FALSE) %>%
    unite(one_of(xvars), col = ".id_long", remove = FALSE)

  y <- y %>%
    unite(one_of(by), col = ".id", remove = FALSE) %>%
    unite(one_of(yvars), col = ".id_long", remove = FALSE)

  ids <- unique(c(x$.id, y$.id))

  x_ <- process_data(x, ids, by) %>%
    mutate(.id_long = paste(.id_long, .side, .r, sep = "_"))
  y_ <- process_data(y, ids, by) %>%
    mutate(.x = .x + ncol(x),
           .id_long = paste(.id_long, .side, .r, sep = "_"))

  return(list(x = x_, y = y_))
}


#' Processes the data
#'
#' @param x a preprocessed dataset
#' @param ids a vector of ids
#' @param by a vector of by-arguments
#' @param width the width of the tiles
#' @param side the side (x or y, lhs or rhs, etc)
#'
#' @return a data_frame including all necessary information
#'
#' @examples
#' NULL
process_data <- function(x, ids, by, width = 1, side = NA) {
  if (is.na(side)) side <- deparse(substitute(x))

  x_names <- names(x) %>% str_subset("^[^\\.]")
  x_keys <- 1:length(x_names)
  names(x_keys) <- x_names

  special_vars <- names(x) %>% str_subset("^\\.")

  x <- x %>%
    mutate(.r = row_number()) %>%
    gather_(key = "col", value = "val", names(x) %>% str_subset("^[^.]")) %>%
    mutate(.x = x_keys[col],
           .y = -.r) %>%
    bind_rows(data_frame(.id = ".header",
                         .id_long = paste(".header", x_names, sep = "_"),
                         .r = 0, col = x_names, val = x_names,
                         .x = x_keys, .y = 0), .) %>%
    mutate(.width = width,
           .side = side)

  add_color(x, ids, by)
}

#' Adds Color to a processed data_frame
#'
#' @param x a processed data_frame
#' @param ids a vector of ids for the color-matching
#' @param by a vector of column names that constitute the by-argument of joins/sets
#' @param color_header color for the header
#' @param color_other color for "inactive" values
#' @param color_missing color for missing values
#'
#' @return the processed data_frame with a new column .color
#'
#' @examples
#' NULL
add_color <- function(x, ids, by, color_header = "#bdbdbd", color_other = "#d0d0d0", color_missing = "#ffffff") {
  colors <- c(color_header, scales::brewer_pal(type = "qual", "Set1")(length(ids)))
  names(colors) <- c(".header", ids)

  x %>%
    mutate(.color = ifelse(is.na(val), color_missing, colors[.id]),
           .color = ifelse(col %in% by, .color, color_other))
}