Loading data and setting up.


install.packages('tidyverse') # only need to do this first time - can delete or comment using "#" after
install.packages('abind') # also need to install abind
install.packages('MASS') # same
install.packages('readr') # last one - this one reads CSV files faster and has some useful defaults, though it is not necessary

Will only use one function from abind, readr, and MASS, so don’t have to load them using library

library(tidyverse) 

setwd('~/dropbox/1_research/generality') # change this to folder that has the data

data <- readr::read_csv("all_observations.csv") 
data # print the data, equivalent to using print(data)

data <- rbind(data, c(NA, '3.1', '3.1', NA)) # this is because `7C_8-3` and `7C_12-2` have no 3.1 obs - will remove this later

data[, 2:4] <- sapply(data[, 2:4], function(x) floor(as.numeric(x))) # this recodes our 10 variables to just six (0, 1, 2, 3, 4, and 5)

Look at likelihood of profile (using all data & six codes).

to_prep <- tidyr::gather(data, key, val, -id)

to_plot <- to_prep %>% 
    group_by(key, val) %>% 
    summarize(n = n()) %>% 
    filter(!is.na(val)) %>% 
    tidyr::spread(val, n, fill = 0) %>% 
    tidyr::gather(Code, the_val, -key) %>% 
    group_by(key) %>% 
    mutate(the_val = as.numeric(the_val),
           the_val = the_val / sum(the_val))

to_plot$key <- factor(to_plot$key,
                      levels = c("7C_8-3", "7C_12-2", "8B_6-2"))

to_plot$the_key <- factor(to_plot$Code)

to_plot <- to_plot %>% arrange(key, Code)

t1_freq <- as.vector(table(data$`7C_8-3`))
t2_freq <- as.vector(table(data$`7C_12-2`))
t3_freq <- as.vector(table(data$`8B_6-2`))
the_mat <- cbind(t1_freq, t2_freq, t3_freq)
row.names(the_mat) <- sort(unique(data$`8B_6-2`))
colnames(the_mat) <- names(data)[2:4] 

This throws a warning (not an error) because some cells have few (< 5) cases; it’s probably okay as long as we interpret those cells with caution.

chi_sq_output <- chisq.test(the_mat) 

Here are the z-scores (> 1.96 means cell is more likely than expected; < 1.96 means cell is less likely than expected). This finds cells (i.e., shifts) which are more (+) or less (-) expected, or as frequent as expected (=).

round(chi_sq_output$stdres, 3)  

Here is the plot.

to_plot$sig <- ifelse(as.vector(chi_sq_output$stdres) >= 1.96, "+",
                      ifelse(as.vector(chi_sq_output$stdres) <= -1.96, "-",
                             "="))

ggplot(to_plot, aes(x = key, y = the_val, color = Code, group = Code, label = sig)) +
    geom_point(size = 1.5) +
    geom_line() +
    ggrepel::geom_label_repel(show.legend = F) +
    ylab("Proportion of Responses") +
    xlab(NULL) +
    theme(text = element_text(size = 14)) +
    theme(legend.title = element_blank()) +
    labs(
        title = "Number of Responses by Code for All Observations",
        caption = "Note. +, -, and = labels indicate code is more likely than expected evaluated using a chi-square test of proportions."
    ) +
    theme(text = element_text(family = "Times")) +
    theme(plot.caption = element_text(size = 8))

# save figure in working directory
ggsave("bar_chart_all_observations.png", width = 8, height = 6) 
LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKTG9hZGluZyBkYXRhIGFuZCBzZXR0aW5nIHVwLgoKYGBge3J9CgppbnN0YWxsLnBhY2thZ2VzKCd0aWR5dmVyc2UnKSAjIG9ubHkgbmVlZCB0byBkbyB0aGlzIGZpcnN0IHRpbWUgLSBjYW4gZGVsZXRlIG9yIGNvbW1lbnQgdXNpbmcgIiMiIGFmdGVyCmluc3RhbGwucGFja2FnZXMoJ2FiaW5kJykgIyBhbHNvIG5lZWQgdG8gaW5zdGFsbCBhYmluZAppbnN0YWxsLnBhY2thZ2VzKCdNQVNTJykgIyBzYW1lCmluc3RhbGwucGFja2FnZXMoJ3JlYWRyJykgIyBsYXN0IG9uZSAtIHRoaXMgb25lIHJlYWRzIENTViBmaWxlcyBmYXN0ZXIgYW5kIGhhcyBzb21lIHVzZWZ1bCBkZWZhdWx0cywgdGhvdWdoIGl0IGlzIG5vdCBuZWNlc3NhcnkKCmBgYAoKV2lsbCBvbmx5IHVzZSBvbmUgZnVuY3Rpb24gZnJvbSBhYmluZCwgcmVhZHIsIGFuZCBNQVNTLCBzbyBkb24ndCBoYXZlIHRvIGxvYWQgdGhlbSB1c2luZyBsaWJyYXJ5CgpgYGB7cn0KbGlicmFyeSh0aWR5dmVyc2UpIAoKc2V0d2QoJ34vZHJvcGJveC8xX3Jlc2VhcmNoL2dlbmVyYWxpdHknKSAjIGNoYW5nZSB0aGlzIHRvIGZvbGRlciB0aGF0IGhhcyB0aGUgZGF0YQoKZGF0YSA8LSByZWFkcjo6cmVhZF9jc3YoImFsbF9vYnNlcnZhdGlvbnMuY3N2IikgCmRhdGEgIyBwcmludCB0aGUgZGF0YSwgZXF1aXZhbGVudCB0byB1c2luZyBwcmludChkYXRhKQoKZGF0YSA8LSByYmluZChkYXRhLCBjKE5BLCAnMy4xJywgJzMuMScsIE5BKSkgIyB0aGlzIGlzIGJlY2F1c2UgYDdDXzgtM2AgYW5kIGA3Q18xMi0yYCBoYXZlIG5vIDMuMSBvYnMgLSB3aWxsIHJlbW92ZSB0aGlzIGxhdGVyCgpkYXRhWywgMjo0XSA8LSBzYXBwbHkoZGF0YVssIDI6NF0sIGZ1bmN0aW9uKHgpIGZsb29yKGFzLm51bWVyaWMoeCkpKSAjIHRoaXMgcmVjb2RlcyBvdXIgMTAgdmFyaWFibGVzIHRvIGp1c3Qgc2l4ICgwLCAxLCAyLCAzLCA0LCBhbmQgNSkKYGBgCgpMb29rIGF0IGxpa2VsaWhvb2Qgb2YgcHJvZmlsZSAodXNpbmcgYWxsIGRhdGEgJiBzaXggY29kZXMpLgoKYGBge3J9CnRvX3ByZXAgPC0gdGlkeXI6OmdhdGhlcihkYXRhLCBrZXksIHZhbCwgLWlkKQoKdG9fcGxvdCA8LSB0b19wcmVwICU+JSAKICAgIGdyb3VwX2J5KGtleSwgdmFsKSAlPiUgCiAgICBzdW1tYXJpemUobiA9IG4oKSkgJT4lIAogICAgZmlsdGVyKCFpcy5uYSh2YWwpKSAlPiUgCiAgICB0aWR5cjo6c3ByZWFkKHZhbCwgbiwgZmlsbCA9IDApICU+JSAKICAgIHRpZHlyOjpnYXRoZXIoQ29kZSwgdGhlX3ZhbCwgLWtleSkgJT4lIAogICAgZ3JvdXBfYnkoa2V5KSAlPiUgCiAgICBtdXRhdGUodGhlX3ZhbCA9IGFzLm51bWVyaWModGhlX3ZhbCksCiAgICAgICAgICAgdGhlX3ZhbCA9IHRoZV92YWwgLyBzdW0odGhlX3ZhbCkpCgp0b19wbG90JGtleSA8LSBmYWN0b3IodG9fcGxvdCRrZXksCiAgICAgICAgICAgICAgICAgICAgICBsZXZlbHMgPSBjKCI3Q184LTMiLCAiN0NfMTItMiIsICI4Ql82LTIiKSkKCnRvX3Bsb3QkdGhlX2tleSA8LSBmYWN0b3IodG9fcGxvdCRDb2RlKQoKdG9fcGxvdCA8LSB0b19wbG90ICU+JSBhcnJhbmdlKGtleSwgQ29kZSkKCnQxX2ZyZXEgPC0gYXMudmVjdG9yKHRhYmxlKGRhdGEkYDdDXzgtM2ApKQp0Ml9mcmVxIDwtIGFzLnZlY3Rvcih0YWJsZShkYXRhJGA3Q18xMi0yYCkpCnQzX2ZyZXEgPC0gYXMudmVjdG9yKHRhYmxlKGRhdGEkYDhCXzYtMmApKQp0aGVfbWF0IDwtIGNiaW5kKHQxX2ZyZXEsIHQyX2ZyZXEsIHQzX2ZyZXEpCnJvdy5uYW1lcyh0aGVfbWF0KSA8LSBzb3J0KHVuaXF1ZShkYXRhJGA4Ql82LTJgKSkKY29sbmFtZXModGhlX21hdCkgPC0gbmFtZXMoZGF0YSlbMjo0XSAKYGBgCgpUaGlzIHRocm93cyBhIHdhcm5pbmcgKG5vdCBhbiBlcnJvcikgYmVjYXVzZSBzb21lIGNlbGxzIGhhdmUgZmV3ICg8IDUpIGNhc2VzOyBpdCdzIHByb2JhYmx5IG9rYXkgYXMgbG9uZyBhcyB3ZSBpbnRlcnByZXQgdGhvc2UgY2VsbHMgd2l0aCBjYXV0aW9uLgoKYGBge3J9CmNoaV9zcV9vdXRwdXQgPC0gY2hpc3EudGVzdCh0aGVfbWF0KSAKYGBgCgpIZXJlIGFyZSB0aGUgei1zY29yZXMgKD4gMS45NiBtZWFucyBjZWxsIGlzIG1vcmUgbGlrZWx5IHRoYW4gZXhwZWN0ZWQ7IDwgMS45NiBtZWFucyBjZWxsIGlzIGxlc3MgbGlrZWx5IHRoYW4gZXhwZWN0ZWQpLiBUaGlzIGZpbmRzIGNlbGxzIChpLmUuLCBzaGlmdHMpIHdoaWNoIGFyZSBtb3JlICgrKSBvciBsZXNzICgtKSBleHBlY3RlZCwgb3IgYXMgZnJlcXVlbnQgYXMgZXhwZWN0ZWQgKD0pLgoKYGBge3J9CnJvdW5kKGNoaV9zcV9vdXRwdXQkc3RkcmVzLCAzKSAgCmBgYAoKSGVyZSBpcyB0aGUgcGxvdC4KCmBgYHtyfQp0b19wbG90JHNpZyA8LSBpZmVsc2UoYXMudmVjdG9yKGNoaV9zcV9vdXRwdXQkc3RkcmVzKSA+PSAxLjk2LCAiKyIsCiAgICAgICAgICAgICAgICAgICAgICBpZmVsc2UoYXMudmVjdG9yKGNoaV9zcV9vdXRwdXQkc3RkcmVzKSA8PSAtMS45NiwgIi0iLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICI9IikpCgpnZ3Bsb3QodG9fcGxvdCwgYWVzKHggPSBrZXksIHkgPSB0aGVfdmFsLCBjb2xvciA9IENvZGUsIGdyb3VwID0gQ29kZSwgbGFiZWwgPSBzaWcpKSArCiAgICBnZW9tX3BvaW50KHNpemUgPSAxLjUpICsKICAgIGdlb21fbGluZSgpICsKICAgIGdncmVwZWw6Omdlb21fbGFiZWxfcmVwZWwoc2hvdy5sZWdlbmQgPSBGKSArCiAgICB5bGFiKCJQcm9wb3J0aW9uIG9mIFJlc3BvbnNlcyIpICsKICAgIHhsYWIoTlVMTCkgKwogICAgdGhlbWUodGV4dCA9IGVsZW1lbnRfdGV4dChzaXplID0gMTQpKSArCiAgICB0aGVtZShsZWdlbmQudGl0bGUgPSBlbGVtZW50X2JsYW5rKCkpICsKICAgIGxhYnMoCiAgICAgICAgdGl0bGUgPSAiTnVtYmVyIG9mIFJlc3BvbnNlcyBieSBDb2RlIGZvciBBbGwgT2JzZXJ2YXRpb25zIiwKICAgICAgICBjYXB0aW9uID0gIk5vdGUuICssIC0sIGFuZCA9IGxhYmVscyBpbmRpY2F0ZSBjb2RlIGlzIG1vcmUgbGlrZWx5IHRoYW4gZXhwZWN0ZWQgZXZhbHVhdGVkIHVzaW5nIGEgY2hpLXNxdWFyZSB0ZXN0IG9mIHByb3BvcnRpb25zLiIKICAgICkgKwogICAgdGhlbWUodGV4dCA9IGVsZW1lbnRfdGV4dChmYW1pbHkgPSAiVGltZXMiKSkgKwogICAgdGhlbWUocGxvdC5jYXB0aW9uID0gZWxlbWVudF90ZXh0KHNpemUgPSA4KSkKCiMgc2F2ZSBmaWd1cmUgaW4gd29ya2luZyBkaXJlY3RvcnkKZ2dzYXZlKCJiYXJfY2hhcnRfYWxsX29ic2VydmF0aW9ucy5wbmciLCB3aWR0aCA9IDgsIGhlaWdodCA9IDYpIApgYGAK