Added ggassoc, export of jazzomat_palette, fixed bug in build_bigram_stack

Author: klaus

.Rbuildignore

@@ -3,3 +3,4 @@
 .travis.yml
 ^Makefile
 data_raw
+^data/.+$

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: parkR
 Type: Package
 Title: Generating monophonic jazz solos for chord sequences
-Version: 0.5.0
+Version: 0.5.1
 Authors@R: c(
   person("Klaus", "Frieler", email = "[email protected]", role = c("aut","cre"))
   )

NAMESPACE

@@ -21,6 +21,7 @@ export(fuzzyint_hist)
 export(generate_solo)
 export(get_cdpcx)
 export(get_scale_degree_code)
+export(ggassoc)
 export(int_hist)
 export(int_span)
 export(key_analysis)

R/bigram_stack.R

@@ -62,13 +62,16 @@ build_bigram_stack <- function(x, max_level = 3, sd_threshold = 1.0, ids = NULL,
         ids <- ids$id
     }
     messagef("Adding ids")
-    if(!early_break){
-      ret <- ret %>% arrange(pos)
-      ret$id <- rep(ids, each = max_level)
-    }
-    else{
-      ret <- ret %>% left_join(tibble(pos = 1:length(ids), id = unique(ids)), by = "pos")
-    }
+    max_level <- max(ret$level)
+    ret <- ret %>% arrange(pos)
+    ret$id <- rep(ids, each = max_level)
+    # if(early_break){
+    #   ret <- ret %>% arrange(pos)
+    #   ret$id <- rep(ids, each = max_level)
+    # }
+    # else{
+    #   #ret <- ret %>% left_join(tibble(pos = 1:length(ids), id = unique(ids)), by = "pos")
+    # }
     messagef("Adding document frequencies")
     ret <- ret %>% group_by(bigram_id) %>% mutate(DF = n_distinct(id)) %>% ungroup()
   } else{

R/data.R

@@ -140,3 +140,11 @@ NULL
 #' @name labels
 #' @docType data
 NULL
+
+
+#' jazzomat_palette
+#'
+#' Palette used in the "Inside the Jazzomat" book
+#' @name jazzomat_palette
+#' @docType data
+NULL

R/ggassoc.R

@@ -0,0 +1,91 @@
+chisq.residuals <- function (tab, digits = 2, std = FALSE, raw = FALSE)
+{
+  if (all(std, raw))
+    stop("Choose between standardized and raw residuals.")
+  k = stats::chisq.test(tab)
+  if (raw) {
+    res <- k$observed - k$expected
+  }
+  else if (std) {
+    res <- k$stdres
+  }
+  else {
+    res <- k$residuals
+  }
+  round(res, digits)
+}
+
+#' ggassoc
+#' Plots chisquare residuals for 2 x N tables, similar to vcd::asso
+#' @param cont_tab (table) 2 x N Contingency table
+#' @param x_lab (string) Label for x-axis
+#' @param y_lab (string) Label for y-axis
+#' @param subtitle (string) subtitle for plot
+#' @param spread (numeric) Spread factor for boxes
+#' @param text_size (integer) Text size
+#' @param fill_colors (string) 2-element vector of color values for filling boxes, defaults to black and red
+#'
+#' @return ggplot2
+#' @export
+ggassoc <- function(cont_tab, x_lab = "", y_lab = "", subtitle = "", spread = 2.25, text_size = 3, fill_colors = c("black", "red")){
+  names <- dimnames(cont_tab)
+  if(length(names[[1]]) != 2){
+    stop("Currently only available for 2 x N tables!")
+  }
+  if(is.null(x_lab) || nchar(x_lab) == 0){
+    x_lab <- "target"
+  }
+  if(is.null(y_lab) || nchar(y_lab) == 0){
+    y_lab <- "group"
+  }
+  #browser()
+  cont_tab <- cont_tab[,colSums(cont_tab) != 0]
+  group_labels <- names[[1]]
+  target_labels <- names[[2]]
+  num_cats <- length(target_labels)
+  resid_df <- chisq.residuals(cont_tab) %>%
+    t() %>%
+    as.data.frame() %>%
+    set_names(x_lab, y_lab, "residual") %>%
+    mutate(resid_norm = residual/max(abs(residual), na.rm = T),
+           group = factor(!!sym(y_lab)))
+  sum_stats  <-  (colSums(cont_tab)/sum(cont_tab)) %>%
+    as.data.frame() %>%
+    rownames_to_column() %>%
+    set_names("target_cat", "width") %>%
+    mutate(width = sqrt(2 * width / max(width))) %>%
+    mutate(xpos = cumsum(c(0, width[-length(width)])))
+  max_resid <- max(abs(resid_df$resid_norm))
+  #browser()
+  resid_df <- resid_df %>%
+    mutate(group_f = spread * (as.numeric(group) - 1)  -  spread/2,
+           target_f = as.numeric(factor(!!sym(x_lab)))) %>%
+    mutate(xmin = rep(sum_stats$xpos, 2),
+           xmax = rep(sum_stats$xpos + sum_stats$width, 2),
+           ymin = group_f,
+           ymax = group_f  + resid_norm,
+           sign_dev = residual > 0)
+  #browser()
+  if(nchar(subtitle) == 0){
+    subtitle <- sprintf("%s x %s", x_lab, y_lab)
+  }
+  q <- resid_df %>% ggplot(aes())
+  q <- q + geom_rect(data  = resid_df, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = sign_dev), color = "white")
+  q <- q + theme_classic()
+  q <- q + theme(legend.position = "none",
+                 axis.line.x = element_blank(),
+                 axis.line.y = element_blank(),
+                 axis.ticks.y = element_blank(),
+                 axis.text.y = element_text(size = 12, face = "bold"))
+  q <- q + labs(x = "", y = "",
+                subtitle = subtitle, title = "Chi-Square Residuals")
+  q <- q + scale_fill_manual(values = fill_colors[1:2])
+  q <- q + scale_x_continuous(breaks = NULL)
+  q <- q + scale_y_continuous(breaks = c(-spread/2, spread/2), labels = group_labels)
+  q <- q + geom_text(data = sum_stats,
+                     aes(x = xpos + .5 * width,
+                         y = .1 + .1 * (as.integer(factor(target_cat)) %% 3- 1),
+                         label = target_cat, hjust = 0.5, size = width ))
+  q <- q +  scale_size(range = c(3, 5))
+  q
+}

R/plot_util.R

@@ -328,6 +328,7 @@ add_histogram <- function(q, percentage = T, binwidth = NULL, fill_var = NULL, c
 cdpcx_hist <- function(data, id = NULL, colour_chromatic = T, percentage = T, fill_var = NULL, cdpcx_col = "cdpcx_raw_all"){
   tmp <- select_by_id(data, id)
   tmp <- tmp[tmp[[cdpcx_col]] != "X",]
+  tmp <- tmp[tmp[[cdpcx_col]] != "",]
   if (nrow(tmp) == 0){
     return(NULL)
     # tmp <- select_by_id(data, id)
@@ -442,14 +443,14 @@ mcm_hist <- function(data, id = NULL, percentage = T, fill_var = NULL, mcm48_col
 #'
 #' @return ggplot2 object
 #' @export
-int_hist <- function(data, id = NULL, cut_off = 25, percentage = T, int_col = "int_raw"){
+int_hist <- function(data, id = NULL, cut_off = 25, percentage = T, int_col = "int_raw", fill_var = NULL, reduced_labels = T){
   tmp <- select_by_id(data, id)
   tmp <- tmp[!is.na(tmp[[int_col]]),]
   tmp <- tmp[abs(tmp[[int_col]]) < cut_off,]
   ext <- max(abs(min(tmp[[int_col]])), abs(max(tmp[[int_col]])))
   tmp[[int_col]] <-  factor(tmp[[int_col]], levels = -ext:ext)
   labels <- rep("", 49)
-  if (ext > 14){
+  if (reduced_labels || ext > 14){
     marks = c(-24, -19, -12, -7, -5, -2, 0, 2, 7, 5, 12, 19, 24)
     labels[marks + 25] = marks
     labels <- labels[(25 - ext):(25 + ext + 1)]
@@ -458,7 +459,7 @@ int_hist <- function(data, id = NULL, cut_off = 25, percentage = T, int_col = "i
     labels = -ext:ext
   }
   q <- ggplot(tmp, aes(x=!!sym(int_col)))
-  q <- add_geom_bar(q, percentage)
+  q <- add_geom_bar(q, percentage, fill_var = fill_var)
 
   q <- q + get_default_theme() + theme(legend.position = "none")
   q <- q + scale_x_discrete(name = "Semitone Interval", drop = FALSE, labels = labels)