rblocks

rblocks.R

#' Creates a block grid of a given data type
#' 
#' @param nrow number of rows
#' @param ncol number of columns
#' @param type data type of object
#' @param fill default fill color
#' @export
#' @examples
#' grid1 = block_grid(10, 10)
#' grid1 = block_grid(10, 10, 'matrix')
#' grid1[1]  = 'red'
#' grid1
#' grid1 = block_grid(10, type = 'vector')
#' grid1[1]  = 'red'
#' grid1
block_grid = function(nrow, ncol = nrow, type = 'data.frame', fill = get_fill("")){
  data_ = matrix(fill, nrow, ncol)
  blk = switch(type,
    "data.frame" = as.data.frame(data_, stringsAsFactors = F),
    "matrix" = data_,
    "vector" = rep(fill, nrow)
  )
  as.block(blk)
}

#' Print a block object as raw data
#' 
#' @param x object to print
#' @export
print_raw = function(x){
  class(x) = class(x)[-1]
  print(x)
}

#' Add block class to an object
#' 
#' @param x object to add block class to
#' @keywords internal
as.block = function(x){
  class(x) = c('block', class(x))
  return(x)
}

#' Print a block object as a grid
#' 
#' @param x block object to display
#' @export
print.block = function(x){
  display(x)
}

#' Display a block grid
#' 
#' @param block an object of block class
#' @export
#' The implementation here is borrowed from sna::plot.sociomatrix
display = function(block, show_values = F, xlab = "", fills = NULL, ...){
  values = block
  if (!('block' %in% class(block))){
    block = make_block(block)
    show_values = TRUE
    fills = getFills(values)
  }
  kv = c(integer = 'blue', factor = 'lightblue', character = 'green',
    logical = 'red'
  )
  gap = 0.5
  if (!is.atomic(block) && is.null(dim(block))){
    maxLen = max(sapply(block, length)) 
    data = as.data.frame(matrix('white', maxLen, length(block)))
    datavalues = as.data.frame(matrix('', maxLen, length(block)))
    if (!is.null(names(block))) names(data) = names(block)
    for (i in seq_along(block)){
      data[i] <- c(
        block[[i]],
        rep('white', maxLen - length(block[[i]]))
      )
      datavalues[i] <- c(
        values[[i]],
        rep("", maxLen - length(values[[i]]))
      )
    }
  } else if (length(dim(block)) < 2){
    data <- matrix('white', length(block), length(block))
    datavalues <- matrix('', length(block), length(block))
    data[1,] = block
    datavalues[1,] = values
  } else {
    data = block
    datavalues = values
  }
  n = dim(data)[1]; o = dim(data)[2]
  drawlines = TRUE
  cur_mar = par('mar')
  par(mar = c(0.5, 0.5, 0.5, 0.5))
  plot(1, 1, xlim = c(0, o + 1), ylim = c(n + 1, 0), type = "n",
       axes = FALSE, xlab = xlab, ylab = "", asp = 1
  )
  if (is.data.frame(data)){
    segments(1, 0, o, 0, col = 'darkgray')
    # points(1:n, rep(0, o), pch = 16)
    text(1:o, rep(0, o), labels = names(data), font = 2, ...)
    # points(1:o, rep(0, o), pch = 21)
    segments(1:o, 0.1, 1:o, 0.5, col = 'darkgray')
    gap = 0.45
  }
  if (!is.null(fills)){
    data = fills
  }
  for (i in 1:n){
    for (j in 1:o) {
      rect(j - gap, i + gap, j + gap, i - gap, 
        col = data[i, j], xpd = TRUE, border = 'white'
      )
      # text(i, j, labels = paste("(", i, ",", j, ")"))
      # text(j, i, labels = paste("(", j, ",", i, ")"))
    }
  }
  
  if (show_values){
    for (i in 1:NCOL(datavalues)){
      for (j in 1:NROW(datavalues)) {
        text(i, j, labels = datavalues[j, i], ...)
      }
    }
  }
  
  rect(0.5, 0.5, o + 0.5, n + 0.5, col = NA, xpd = TRUE, border = 'white')
  par(mar = cur_mar)
}

getFills <- function(x){
  UseMethod('getFills')
}

getFills.data.frame <- function(x){
  fills = as.data.frame(matrix(NA, nrow = NROW(x), ncol = NCOL(x)))
  for (i in 1:NROW(x)){
    for(j in 1:NCOL(x)){
      fills[i, j] = fill_fun(x[i, j])
    }
  }
  return(fills)
}

getFills.matrix <- function(x){
  fills = matrix(NA, nrow = NROW(x), ncol = NCOL(x))
  for (i in 1:NROW(x)){
    for(j in 1:NCOL(x)){
      fills[i, j] = fill_fun(x[i, j])
    }
  }
  return(fills)
}


fill_fun <- function(x){
  switch(class(x),
    'integer' = '#91bfdb',
    'numeric' = '#4575b4',
    'double' = '#4575b4',
    'factor' = '#fee090',
    'logical' = '#fc8d59',
    '#d73027'
  )
}

getFills.list <- function(x){
  NROWS = max(sapply(x, length))
  as.data.frame(
    lapply(x, function(y){
      c(
        rep(fill_fun(y), length(y)),
        rep('white', NROWS - length(y))
      )
    }), stringsAsFactors = FALSE
  )
}

getFills.default <- function(x){
  y <- matrix('white', nrow = length(x), ncol = length(x))
  y[1,] <- rep(fill_fun(x), length(x))
  return(y)
}

make_block <- function(x, ...){
  UseMethod('make_block')
}

make_block.list <- function(x, ...){
  as.block(lapply(x, function(xi){
    rep(get_fill(xi), length(xi))
  }))
}

make_block.matrix <- function(x, ...){
  as.block(apply(x, 2, function(xi){
    rep(get_fill(xi), length(xi))
  }))
}

make_block.data.frame = function(x, ...){
  as.block(as.data.frame(lapply(x, function(xi){
    rep(get_fill(xi), length(xi))
  }), stringsAsFactors = F))
}

# make_block.default = function(x){
#   as.block(rep(get_fill(mode(xi)), length(x)))
# }

make_block.default = function(x, ...){
  if (length(x) > 1){
    return(as.block(rep(get_fill(x), length(x))))
  }
  dotlist = list(nrow = x, ...)
  if (!("type" %in% names(dotlist))){
    dotlist$type = infer_type(x)
  }
  if (dotlist$type == 'vector'){
    dotlist$ncol = x
  }
  do.call('block_grid', dotlist)
}



fill_by <- function(f){
  function(x){
    switch(f(x), 'numeric' = "#a6cee3", 'logical' = "#1f78b4", "#b2df8a")
  }
}


get_fill = function(x){
  getOption('fill_by', function(x){return("#b2df8a")})(x)
}


infer_type = function(x){
  if (is.data.frame(x)){
    'data.frame'
  } else if (is.matrix(x)){
    'matrix'
  } else if (is.list(x)) {
    'list'
  } else {
    'vector'
  }
}