R/chord_shapes.R

In wkostelecki/circly: Package for chord diagrams

#' @importFrom reshape2 dcast
#' @export
chord_shapes = function(data,
                        from_amount = 'OUT',
                        to_amount = 'IN',
                        from_label = 'FROM',
                        to_label = 'TO'){
  
  if (length(intersect(unique(data[[from_label]]),
                       unique(data[[to_label]]))) > 0){
    stop('shared labels not yet (?) supported')
  }
  
  gap_width = 0.005
  ROI = 1
  
  #----
  
  data = rename_(data,
                 FROM = from_label,
                 TO = to_label,
                 OUT = from_amount,
                 IN = to_amount)
  
  segment = outer_spacing(data, gap_width = gap_width, ROI = ROI)
  outer_segments = outer_segments(segment)
  
  #browser()
  
  M1 = dcast(data,
             as.formula(paste(to_label, '~', from_label)),
             value.var = from_amount) %>%
    subset(select = 2:ncol(.), drop = FALSE) %>%
    as.matrix %>%
    unname
  
  M2 = dcast(data,
             as.formula(paste(to_label, '~', from_label)),
             value.var = to_amount) %>%
    subset(select = 2:ncol(.), drop = FALSE) %>%
    as.matrix %>%
    unname
  
  ROI = sum(M2) / sum(M1)
  
  NCOL = ncol(M1)
  NROW = nrow(M1)
  NSEGMENT = NCOL + NROW
  
  gap_total = pmin(gap_width * (NSEGMENT), 0.9)
  gap_width = gap_total / (NSEGMENT)
  
  M1 = M1 / sum(M1)
  out_end = cumsum(apply(M1, 2, sum))
  out_start = c(0, out_end[setdiff(0:(length(out_end) - 1), 0)])
  
  M2 = M2 / sum(M2)
  in_end = cumsum(apply(M2, 1, sum))
  in_start = c(0, in_end[setdiff(0:(length(in_end) - 1), 0)])
  
  # ----
  compress = 1 - gap_width * length(out_start) / (1 / (ROI + 1))
  gaps = (gap_width / 2 + (gap_width * 0:(length(out_start) - 1))) / (1 / (ROI + 1))
  
  out_start = (out_start * compress + gaps - 0.5) * (1 / (ROI + 1)) + 0.75
  out_end = (out_end * compress + gaps - 0.5) * (1 / (ROI + 1)) + 0.75
  
  # ----
  compress = 1 - gap_width * length(in_start) / (ROI / (ROI + 1))
  gaps = (gap_width / 2 + (gap_width * 0:(length(in_start) - 1))) / (ROI / (ROI + 1))
  
  in_start = -(in_start * compress + gaps - 0.5) * (ROI / (ROI + 1)) + 0.25
  in_end = -(in_end * compress + gaps - 0.5) * (ROI / (ROI + 1)) + 0.25
  
  inner_r = 1.03
  outer_r = 1.1
  
  start = c(out_start, in_start)
  end = c(out_end, in_end)
  
  IDS = c(paste('OUT', 1:length(out_start)),
          paste('IN', 1:length(in_start)))
  
  outer_segments = lapply(
    1:length(start),
    function(i){
      circly:::outer_segment(start[i], end[i], inner_r, outer_r) %>%
        mutate(ID = IDS[i])
    }
  ) %>%
    do.call(rbind, .) %>%
    mutate(ID = factor(ID, IDS))
  
  chords = chord_segments(data)
  
  return(list(crust = outer_segments,
              chords = chords))
  
}