post

Sound Energy Aggregate (SEA) Analysis

Statistics of Sound

calendar_today Sun, Feb 2, 2020 - person Stephen
+R +Analysis #Music #Musical Composition #Composition #Chi squared

The Sound Energy Aggregate

Each musical element contributes a shape, an energy contour, and that the interaction of those energies creates the flow of shifting musical energies. The composite is the Sound-Energy Aggregate (SEA) Learn more about the SEA.

Study Description

Note: terminology used throughout this article have their first instance italicized. Each unitalicized reference to this term will imply this specific term and it’s definition for this study. The study involved the creation of 35 musical examples performed by John Morrison, each of which demonstrates three variations in four musical parameters:

opts <- list(params = params <- list(register = c("low", "mid", "high"), dynamic = c("ppp", 
    "mp", "ff"), tempo = c("Molto Largo", "Moderato", "Prestissimo"), articulation = c("legato", 
    "neutral", "staccato")), variations = expand.grid(purrr::map(params, ~{
    factor(.x, levels = .x)
})), affect = c("0 Other", "1 Forceful: aggressive, piercing, angry, shocking", "2 Assertive: bold, stern, decisive, declamatory", 
    "3 Energetic: brave, frantic, lively, angular", "4 Light: airy, dreamy, bright, delicate", 
    "5 Gentle: sweet, pleasant, shy, calm", "6 Playful: cheerful, dancing, joking, jaunty", 
    "7 Melancholy: sad, nostalgic, dark, longing", "8 Moving: majestic, heroic, awe-inspiring") %>% 
    str_remove("\\d\\s") %>% as_tibble() %>% separate(value, into = c("affect", "desc"), 
    sep = "\\:\\s") %>% replace_na(list(desc = "other")) %>% mutate_at(vars(affect), 
    ~factor(., levels = .)))
opts$params %>% {
    tagList(tags$ul(class = "nested", tagList(purrr::imap(., ~{
        tags$li(.y, tags$ul(tagList(purrr::map(.x, ~{
            tags$li(.x)
        }))))
    }))))
}
  • register
    • low
    • mid
    • high
  • dynamic
    • ppp
    • mp
    • ff
  • tempo
    • Molto Largo
    • Moderato
    • Prestissimo
  • articulation
    • legato
    • neutral
    • staccato

If each combination of the three levels of each of the four parameters were considered, that would result in \(3^4 = 81\) combinations. Of course, this would be quite laborious to perform for any musician, so 35 are considered. These 35 are listed in the table below:

.dat %>% # Select the IMA cols
select(-starts_with(".")) %>% # get the first 4 rows
extract(1:4, ) %>% # unnest the data
unnest() %>% # make first row into rownames
{
    column_to_rownames(., var = names(.)[1])
} %>% # transpose
t %>% # rename rownames
set_rownames(1:nrow(.)) %>% # Save examples
assign("examples", ., envir = .GlobalEnv) %>% # show
DT::datatable()

Subjects voluntarily took a survey in which they were randomized to encounter five examples each. Some subjects experienced the examples at random where multiple parameters could change dramatically from encounter to encounter. Others experienced (a random set of examples) that were selected in sequential order from the examples, where parameters changed incrementally from one encounter to the next.

For each encounter a subject was prompted to rate their subjective assessment of the affect of the example, and the strength to which they attributed the affect to the example. The affects and their descriptions are listed below:

opts$affect
affect desc
Other other
Forceful aggressive, piercing, angry, shocking
Assertive bold, stern, decisive, declamatory
Energetic brave, frantic, lively, angular
Light airy, dreamy, bright, delicate
Gentle sweet, pleasant, shy, calm
Playful cheerful, dancing, joking, jaunty
Melancholy sad, nostalgic, dark, longing
Moving majestic, heroic, awe-inspiring

Data Acquisition and Cleaning

The raw data was collected via Google Spreadsheet. Each row corresponds to an observation, except where responses were separate by randomization group. Here we use googlesheets4 to read the data from the google sheet. The column names are non-standard, so standardized column names are applied. Rows where randomization group are labelled are removed and the sheet is split into a list containing the corresponding observations.

.dat_raw <- googlesheets4::read_sheet("https://docs.google.com/spreadsheets/d/1k174OGNWjmUXtzzo0-v99ABH80V2cw2KDek630FsCL8/edit#gid=2004007850", 
    range = "'Form Responses 1'!A:Z", col_names = F)
# Get the rows where sections begin & end by their null value and create a run
# length encoding
.sections <- purrr::map_lgl(.dat_raw[[1]], is.null) %>% {
    HDA::rleIndex(rle(.))
}
# Parse the run length encoding to get vectors of the row indices for each
# section
.sections_ind <- apply(.sections, 1, .dat_raw = .dat_raw, function(.r, .dat_raw) {
    if (.r["values"] == F) {
        .out <- (.r["start"] + 1):.r["end"]
    } else NULL
}) %>% purrr::compact()
# Split the data into the respective sections
.dat_sections <- apply(.sections, 1, .dat_raw = .dat_raw, function(.r, .dat_raw) {
    if (.r["values"] == F) {
        .out <- .dat_raw[(.r["start"] + 1):.r["end"], ]
        .out
    } else NULL
    
}) %>% purrr::compact()

There is one observation that can be assumed invalid by the bogus answers provided (Location was indicated as 42). This invalid entry is removed.

# Remove invalid entry
.dat_sections[[7]] <- .dat_sections[[7]][-6, ]
# Rename according to the trial
names(.dat_sections) <- as.character(20:1)

The example and corresponding parameters for each encounter are listed in an accessible tabular format to the right of the form responses. These are matched to the encounter. Columns are renamed with legible and interpretable names.

.dat_params <- googlesheets4::read_sheet("https://docs.google.com/spreadsheets/d/1uZiG2f2sZ1IeyNcGQUV9Nw-K_LDpAOMwAdtI5_ZED08/edit#gid=164770121", 
    range = "'Form Responses (dealing with mulitples)'!AV1:EV474", col_names = F)
.col_names <- googlesheets4::read_sheet("https://docs.google.com/spreadsheets/d/1uZiG2f2sZ1IeyNcGQUV9Nw-K_LDpAOMwAdtI5_ZED08/edit#gid=164770121", 
    range = "'Form Responses (dealing with mulitples)'!AV1:EV1", col_names = T)
names(.dat_params) <- names(.col_names)
.dat_params <- .dat_params %>% mutate_all(~{
    purrr::map(., ~{
        ifelse(is.null(unlist(.x)), NA, as.double(unlist(.x)))
    })
})  # remove the list column and retain numbers
.test <- apply(.dat_params, 1, .n = names(.dat_params), function(.r, .n) {
    # which(!is.na(is.numeric(.r)))
    .str <- {
        names(.r)[which(purrr::map_lgl(.r, ~{
            !is.na(.x) | !nchar(.x) < 1
        }))] %>% str_subset("strength")
    }
    .n[which(.n %in% .str) - 1]
})
.param_vals <- purrr::map(.sections_ind, ~{
    .out <- .test[.x] %>% purrr::map(~{
        str_extract(.x, "\\d+")
    }) %>% do.call(rbind.data.frame, .) %>% {
        set_names(., value = 1:ncol(.))
    } %>% set_rownames(value = .x)
    
})
# Remove a row corresponding to the invalid entry
.param_vals[[7]] <- .param_vals[[7]][-6, ]
# bind the number of each of the 5 encounters to the observation
dat_flat <- purrr::map2(.dat_sections, .param_vals, cbind.data.frame) %>% # combine into df
bind_rows(.id = "sets") %>% # name accordingly
set_names(value = c("sets", "timestamp", "name_email.dem", "age.dem", "gender.dem", 
    "ctry.dem", "ed.dem", "music_train.dem", "music_desc.dem", "place.dem", "loc.dem", 
    "referral.dem", paste0(rep(1:5, each = 3), ".", c("encounter", "other", "strength")), 
    1:5))

Purpose and hypotheses of this analysis

With this analysis we intend to discover if:
\(H_a\). A shift in a specific parameter causes a shift in the assessment of affect, and if so what magnitude of shift in a parameter (ie low - mid or low - high etc) results in a change in the assessment of affect.
\(H_{a0}\) The general null hypothesis is to assume that shifts in all levels of all parameters will have no effect on affect.


\(H_b\). If there are associations between a specific parameter and a specific affect, and if so what degree of association there is.
\(H_{b0}\) The null hypothesis is to assume that there is no association between a specific parameter and a specific affect.

Analysis

To begin analyzing such a strata of categorical data and progress in a systematic way, we will format the data in a 2-D table such that each example, it’s parameters, and the examples to which it will be compared can be easily viewed left to right. This table can serve as a map for the statistical analyses to be performed later. The comparisons requested are provided as text in an email. We’re going to start with a comparison of the example that is neutral in all parameters (example 1), to each example that varies from all neutral by a change in only a single parameter. However, there will be one exception, as there are not examples that deviate from neutral in the register parameter. The progression of comparisons across parameters can be viewed on the diagonal in the table below. All but the first two will be compared to all neutral example 1.

test_parameters <- purrr::imap(names(opts$params) %>% setNames(nm = .), .var = opts$variations, 
    .neutral = rep(2, 4) %>% setNames(names(opts$params)), function(.x, .y, .var, 
        .neutral) {
        # looking at the high variant of the parameter first
        .neutral[.y] <- 3
        # print(.neutral) print(.y)
        .sym <- as.symbol(.y)
        # print(.y) Transform the parameter names that aren't the one mapped into a regex
        .syms <- names(.var)[!names(.var) %in% .y] %>% paste(collapse = "|")
        # print(.syms) Parameters are factors, hence the as.numeric
        .hi <- .var %>% # Filter for all the examples where the mapped parameter is high
        filter(.neutral[.y] == as.numeric(!!.sym)) %>% # Filter for the examples where all other parameters are neutral
        filter_at(vars(matches(.syms)), all_vars(as.numeric(.) == 2))
        # looking at the low variant next
        .neutral[.y] <- 1
        # Same as above
        .lo <- .var %>% filter(.neutral[.y] == as.numeric(!!.sym)) %>% filter_at(vars(matches(.syms)), 
            all_vars(as.numeric(.) == 2))
        
        return(rbind.data.frame(.hi, .lo))
    }) %>% do.call(rbind.data.frame, .)
# Combine with examples: Sat Jan 25 19:39:19 2020 ----
.examples <- googlesheets4::read_sheet("https://docs.google.com/spreadsheets/d/1nxcCqywl_VKdpiWU_CeyRmT7rZUWRBIDKXsJ2I0DzAg/edit#gid=0", 
    range = "'examples in order'!A3:E38")

(test_parameters <- left_join(test_parameters, .examples, by = c("register", "dynamic", 
    "tempo", "articulation")))
register dynamic tempo articulation example
high mp Moderato neutral NA
low mp Moderato neutral NA
mid ff Moderato neutral 3
mid ppp Moderato neutral 2
mid mp Prestissimo neutral 7
mid mp Molto Largo neutral 6
mid mp Moderato staccato 5
mid mp Moderato legato 4

Parse comparisons from text

Here is the text of the rest of the guidance on comparisons. We can parse these into a data frame that can be iterated over to guide the comparison tests.

.comparisons <- "
1 to 2, 3, 4, 5, 6, 7

Also, each first extreme to the other:
2 to 3
4 to 5
6 to 7

First extreme to second in pairs (conflates the two steps above):
2 to 32 & 34
3 to 33 & 35
4 to 33 & 34
5 to 35

Impact of the third change across the board:  
24 to 28 
25 to 29
27 to 31  
26 to 30
26 to 27 (in many of these no prior pair to compare)
28 to 29
24 to 25
30 to 31

And of course,  from 2 extreme to 3 (connects to the set above)
32 to 24 & 28
33 to 25 & 29
34 to 26 & 30
35 to 27 & 31

Could test which parameter has the most impact: (examples below are 3 extreme, add fourth)
15 to 11 (tempo changed) vs. 
15 to 14 (dynamic changed, slow tempo) vs. 
11 to 10 (dynamic changed , fast tempo)

 3rd to 4th change:
24 to 8 & 20
25 to 9 & 21
26 to 10 & 22
27 to 11 & 23
28 to 12 & 16
29 to 13 & 17
30 to 14 & 18
31 to 15 & 19

33 to 29 
33 to 25
35 to 31
35 to 27
"
.comparisons <- strsplit(.comparisons, "\\n")[[1]]
# Extract the numbers for comparison
.init <- list()
.init$example <- .comparisons %>% str_extract_all("^[\\d]{1,2}")
.init$comparisons <- .comparisons %>% # Get everything after to
str_extract_all("(?<=to\\s).*") %>% # extract all digits
purrr::map(~{
    ifelse(is_character(., n = 1), str_extract_all(., "[0-9]+"), NA)
}) %>% purrr::map(unlist)
# Retrieve all starter examples
.guide <- purrr::map(1:35, .ex = .init$example, .co = .init$comparisons, function(.x, 
    .ex, .co) {
    # map through the starting example to find matches, if a match, then output the
    # comparison example no.s
    if (.x %in% as.numeric(.ex)) {
        purrr::map2(.ex, .co, .i = .x, function(.x, .y, .i) {
            .go <- try({
                length(.x) > 0 && !is.na(.x) && as.numeric(.x) == .i
            })
            if (.go) {
                as.numeric(.y)
            } else {
                NULL
            }
        }) %>% unlist
    } else {
        NULL
    }
})
# Turn this into a nested tibble
guide <- purrr::imap_dfr(.guide, ~{
    if (!is.null(.x)) {
        .co <- .x
    } else {
        .co <- NA
    }
    tibble(example = .y, comparisons = list(unique(.co)))
})
# Add the refer put these to Google sheets for John to take a look at .ssid <-
# googlesheets4::sheets_create('Comparisons') ss <-
# googlesheets4::sheets_get(.ssid) googlesheets4::sheets_write(ss = ss, data =
# comparisons)

1:1 \(\chi^2\) for Comparisons

The study design is the primary consideration for choosing the appropriate statistical measures to make claims about the associations in the data. The parameters and affects are categorical variables, where each of the parameter levels are ordered. The data is highly unbalanced as the randomization did not give each example the same exposure. Due to these constraints, the most appropriate test is \(\chi^2\).

Summarize Data for Examples

summarize_results <- function(.example, .dat, opts = opts, type = c("freq", "normal")[1]) {
    # print(type)
    .out <- purrr::imap(.example, ~{
        .vars <- 1:5 %>% as.character %>% purrr::map(as.symbol)
        .dat_filtered <- .dat %>% filter_at(vars(!!!.vars), any_vars(as.character(.) == 
            as.character(.x)))
        .enc_ind <- apply(.dat_filtered[, purrr::map_chr(1:5, as.character)], 1, 
            .x = .x, function(.r, .x) {
                names(.r)[which(as.character(.r) == as.character(.x))]
            })
        if (is.null(.enc_ind)) 
            return(NULL)
        # Create an index of column symbols corresponding to the encounter data columns
        .cols <- paste0(.enc_ind, ".encounter") %>% purrr::map(as.symbol)
        # Select those columns
        .affect_dat <- .dat_filtered %>% select(!!!.cols)
        # Create a regex of the affects
        .reg <- opts$affect$affect %>% as.character() %>% paste0(collapse = "|") %>% 
            regex()
        # Extract all the affect tokens from the responses
        .all_tokens <- str_match_all(.affect_dat[[1]], .reg)
        # Compute the proportions
        if (type == "freq") {
            .total_freq <- unlist(.all_tokens) %>% table() %>% prop.table()
        } else {
            .total_freq <- unlist(.all_tokens) %>% table() %>% scale() %>% t %>% 
                .[1, ]
        }
        
        # Fill the affect df with the props
        .out <- opts$affect %>% select(-desc)
        .out$freq <- opts$affect$affect %>% purrr::map_dbl(.freq = .total_freq, function(.x, 
            .freq) {
            ifelse(is.na(.freq[as.character(.x)]), 0, .freq[as.character(.x)])
        })
        .out$count <- purrr::map_dbl(.out$freq %>% set_names(value = .out$affect), 
            .t = nrow(.affect_dat), function(.x, .t) {
                round(.x * .t, 0)
            })
        .out
    })
    .out
}
# single_var_props <- summarize_results(test_parameters %>%
# filter(!is.na(example)) %>% extract2('example') %>% {set_names(., value = .)},
# dat_flat, opts)

The data for each of the examples that will be used in the comparisons above must be summarized to prepare for the \(\chi^2\) tests.

all_results <- summarize_results(1:35, dat_flat, opts)
names(all_results) <- 1:35
all_results <- purrr::compact(all_results)

Now the counts of an affect across all encounters for a given example are computed from the aggregate frequencies of the affects associated with that example multiplied by the total number of tests using that example (note: not test-takers). Here are the results for the 35th example:

all_results$`35` %>% kableExtra::kable("html") %>% kableExtra::kable_styling(position = "center")
tone freq count
Other 0.1224490 5
Forceful 0.1632653 7
Assertive 0.2244898 9
Energetic 0.2448980 10
Light 0.0408163 2
Gentle 0.0000000 0
Playful 0.1836735 7
Melancholy 0.0000000 0
Moving 0.0204082 1

\(\chi^2\) Tests

The guide table can be iterated over to guide the \(\chi^2\) comparisons. The output for each test needs to be easily discernible. To make them discernible, the example numbers will need to appear alongside the actual combination of parameters using in the example. We can join the parameters pertaining to each example with the guide table to make this possible.

# They share the example column
comparisons <- left_join(.examples %>% mutate_at(vars(-one_of("example")), as.factor), 
    guide, by = "example")
# The google sheet was updated with this info
comparisons %>% kableExtra::kable("html") %>% kableExtra::kable_styling(position = "center", 
    bootstrap_options = c("striped", "responsive"))
example register dynamic tempo articulation comparisons
1 mid mp Moderato neutral c(2, 3, 4, 5, 6, 7)
2 mid ppp Moderato neutral c(3, 32, 34)
3 mid ff Moderato neutral c(33, 35)
4 mid mp Moderato legato c(5, 33, 34)
5 mid mp Moderato staccato 35
6 mid mp Molto Largo neutral 7
7 mid mp Prestissimo neutral NA
8 high ppp Prestissimo legato NA
9 high ff Prestissimo legato NA
10 high ppp Prestissimo staccato NA
11 high ff Prestissimo staccato 10
12 high ppp Molto Largo legato NA
13 high ff Molto Largo legato NA
14 high ppp Molto Largo staccato NA
15 high ff Molto Largo staccato c(11, 14)
16 low ppp Molto Largo legato NA
17 low ff Molto Largo legato NA
18 low ppp Molto Largo staccato NA
19 low ff Molto Largo staccato NA
20 low ppp Prestissimo legato NA
21 low ff Prestissimo legato NA
22 low ppp Prestissimo staccato NA
23 low ff Prestissimo staccato NA
24 mid ppp Prestissimo legato c(28, 25, 8, 20)
25 mid ff Prestissimo legato c(29, 9, 21)
26 mid ppp Prestissimo staccato c(30, 27, 10, 22)
27 mid ff Prestissimo staccato c(31, 11, 23)
28 mid ppp Molto Largo legato c(29, 12, 16)
29 mid ff Molto Largo legato c(13, 17)
30 mid ppp Molto Largo staccato c(31, 14, 18)
31 mid ff Molto Largo staccato c(15, 19)
32 mid ppp Moderato legato c(24, 28)
33 mid ff Moderato legato c(25, 29)
34 mid ppp Moderato staccato c(26, 30)
35 mid ff Moderato staccato c(27, 31)
# Split according to the comparisons that will be made
all_chisq <- apply(comparisons, 1, .all_results = all_results, .comparisons = comparisons, 
    function(r, .all_results, .comparisons) {
        # Get the comparisons to be performed
        
        .compare <- unlist(r$comparisons) %>% purrr::keep(!is.na(.)) %>% trimws() %>% 
            as.numeric %>% {
            set_names(., .)
        }
        # if no comparisons, return null
        .example <- as.numeric(trimws(r["example"]))
        if (length(.compare) < 1) 
            return(NULL)
        # for each comparison use example and comparison identifier to index into results
        # and retrieve the data,
        purrr::imap(.compare, function(.x, .y) {
            .out <- chisq.test(x = rbind(.all_results[[.example]]$count, .all_results[[.x]]$count), 
                simulate.p.value = T)
            .out[["data.name"]] <- tibble(Parameter = names(opts$params), `:=`((!!glue::glue("Example: {.example}")), 
                .comparisons[.example, names(opts$params)] %>% unlist %>% as.character()), 
                `:=`((!!glue::glue("Comparison: {.x}")), .comparisons[.x, names(opts$params)] %>% 
                  unlist %>% as.character()))
            # paste0( paste0( paste0( names(opts$params),':' , ), collapse = '|' ), ' v ',
            # paste0( paste0( names(opts$params),':' , ), collapse = '|' ) )
            .out
        })
        
        
    })

Correlations between parameter and affect

In working with the data, we became curious about general correlation between parameters and attributions of affect. The attributions of affect by example are summarized and normalized.

dat_freq <- purrr::map(all_results, ~{
    # Affect and Count
    .x[, c(1, 3)] %>% # transpose
    t %>% # to tibble
    as_tibble() %>% # set names to affect
    set_names(value = .[1, ]) %>% # remove affect row
    extract(-1, ) %>% mutate_all(as.numeric)
}) %>% # bind by the example #
bind_rows(.id = "id")

The frequencies by example are then joined with the corresponding parameters for ease of labelling and differentiating results.

sets_x_freq <- left_join(dat_freq, .examples %>% mutate_at(vars(example), as.character), 
    by = c(id = "example"))
names(sets_x_freq)[2:10] <- str_c(names(sets_x_freq)[2:10], "_affect")
names(sets_x_freq)[11:14] <- str_c(names(sets_x_freq)[11:14], "_par")
# factorize
sets_x_freq[, 11:14] <- purrr::imap(sets_x_freq %>% select(ends_with("par")), ~{
    .y <- str_extract(.y, "[a-z]+(?=\\_par)")
    factor(.x, levels = opts$params[[.y]])
})
head(sets_x_freq, 5) %>% kableExtra::kable("html") %>% kableExtra::kable_styling(position = "center", 
    bootstrap_options = c("striped", "responsive"))
id Other_affect Forceful_affect Assertive_affect Energetic_affect Light_affect Gentle_affect Playful_affect Melancholy_affect Moving_affect register_par dynamic_par tempo_par articulation_par
1 48 1 12 4 45 118 15 142 1 mid mp Moderato neutral
2 14 0 0 0 9 11 1 17 1 mid ppp Moderato neutral
3 7 4 19 1 2 4 2 6 1 mid ff Moderato neutral
4 7 1 5 3 7 16 2 16 2 mid mp Moderato legato
5 13 1 1 4 17 13 37 5 0 mid mp Moderato staccato

Linear regression is then used to determine the degree of association between the specific affect and the parameters. The top two parameters that show the highest \(\beta\) values, indicating they have the largest effect on the perception of that affect, are listed with corresponding \(\beta\) and \(\text{Adjusted}\ R^2\) values. The \(\beta\) value indicates the magnitude of effect that the shift in parameter has on the perception of affect. Given that the parameters are ordered, a negative value indicates that as the level of the parameter decreases, the association with the affect increases. The \(\text{Adjusted}\ R^2\) on a scale from 0-1 indicates how well the parameter explains the variation in attribution of the affect, ie the higher the value the stronger the explanatory value of the association between the parameter and affect.

# psych::corPlot(cor(sets_x_freq %>% select(ends_with('affect')) %>%
# mutate_all(as.numeric), sets_x_freq %>% select(ends_with('par')) %>%
# mutate_all(as.numeric)), symmetric = F, numbers = T)
.formulae <- purrr::map(str_subset(names(sets_x_freq), "affect$"), ~{
    str_subset(names(sets_x_freq), "par$") %>% paste0(collapse = " + ") %>% {
        paste0(paste0(.x, " ~ "), .)
    } %>% as.formula()
})
names(.formulae) <- str_subset(names(sets_x_freq), "affect$")
affect_parameter_associations <- purrr::imap(.formulae, ~{
    .out <- lm(.x, data = sets_x_freq %>% mutate_at(vars(ends_with("par")), as.numeric))
    .top2 <- sort(abs(.out[["coefficients"]][-1])) %>% tail(2) %>% names
    .out <- c(.out[["coefficients"]][.top2], R2 = summary(.out)[["r.squared"]]) %>% 
        as.data.frame %>% t
})
affect_parameter_associations %>% purrr::iwalk(~{
    tagList(tags$strong(.y), HTML(.x %>% kableExtra::kable("html") %>% kableExtra::kable_styling(position = "center"))) %>% 
        print
})
Other_affect
articulation_par register_par R2
. 0.5666667 -0.625 0.0104598
Forceful_affect
dynamic_par register_par R2
. 0.5333333 -1.0625 0.1205102
Assertive_affect
dynamic_par register_par R2
. 1.866667 -3.5625 0.2456306
Energetic_affect
articulation_par register_par R2
. 1.5 -1.5 0.3227889
Light_affect
register_par dynamic_par R2
. 1.6875 -2.2 0.0899952
Gentle_affect
dynamic_par register_par R2
. -1.133333 4.0625 0.024808
Playful_affect
register_par articulation_par R2
. -1.75 3.7 0.252222
Melancholy_affect
tempo_par register_par R2
. -2.615385 2.75 0.0166181
Moving_affect
articulation_par tempo_par R2
. -0.2 0.4615385 0.1000999

Conclusions

Chi-squared comparisons

all_sig <- purrr::map_depth(all_chisq %>% purrr::set_names(nm = 1:length(all_chisq)), 
    2, ~{
        
        if (is.null(.x) || is_empty(.x) || is.na(.x[["p.value"]])) 
            return(NULL)
        .x
    }) %>% purrr::map(purrr::compact) %>% purrr::compact()

Now that all of the \(\chi^2\) Tests have been performed, we can filter for the comparisons that resulted in a statistically significant shift in affect and display them in the tables below.

purrr::iwalk(all_sig, ~ {
  if (length(.x) < 1) {
    # If no comparisons were made
    print(p("No Comparisons"))
  } else {
    # map over comparisons
    tagList(
      h4(.y),
      purrr::map(.x, ~ {
        tagList(
          HTML(.x$data.name %>%
            # split by each side of test
            kableExtra::kable("html") %>%
            kableExtra::kable_styling(position = "center")),
          HTML(glue::glue("&chi;<sup>2</sup> (N={sum(.x$observed)}) = {round(.x$statistic, 2)}, {HDA::p.txt(.x$p.value)}"))
        )
      })
    ) %>% print
    
  }
  
})

1

Parameter Example: 1 Comparison: 2
register mid mid
dynamic mp ppp
tempo Moderato Moderato
articulation neutral neutral
χ2 (N=439) = 14.89, p<.1
Parameter Example: 1 Comparison: 3
register mid mid
dynamic mp ff
tempo Moderato Moderato
articulation neutral neutral
χ2 (N=432) = 128.57, p<.001
Parameter Example: 1 Comparison: 4
register mid mid
dynamic mp mp
tempo Moderato Moderato
articulation neutral legato
χ2 (N=445) = 20.58, p<.05
Parameter Example: 1 Comparison: 5
register mid mid
dynamic mp mp
tempo Moderato Moderato
articulation neutral staccato
χ2 (N=477) = 132.37, p<.001
Parameter Example: 1 Comparison: 7
register mid mid
dynamic mp mp
tempo Moderato Prestissimo
articulation neutral neutral
χ2 (N=421) = 184.74, p<.001

2

Parameter Example: 2 Comparison: 3
register mid mid
dynamic ppp ff
tempo Moderato Moderato
articulation neutral neutral
χ2 (N=99) = 39.35, p<.001
Parameter Example: 2 Comparison: 34
register mid mid
dynamic ppp ppp
tempo Moderato Moderato
articulation neutral staccato
χ2 (N=143) = 39.33, p<.001

3

Parameter Example: 3 Comparison: 35
register mid mid
dynamic ff ff
tempo Moderato Moderato
articulation neutral staccato
χ2 (N=87) = 24.66, p<.001

4

Parameter Example: 4 Comparison: 5
register mid mid
dynamic mp mp
tempo Moderato Moderato
articulation legato staccato
χ2 (N=150) = 43.41, p<.001
Parameter Example: 4 Comparison: 33
register mid mid
dynamic mp ff
tempo Moderato Moderato
articulation legato legato
χ2 (N=118) = 24.35, p<.01
Parameter Example: 4 Comparison: 34
register mid mid
dynamic mp ppp
tempo Moderato Moderato
articulation legato staccato
χ2 (N=149) = 24.32, p<.01

5

Parameter Example: 5 Comparison: 35
register mid mid
dynamic mp ff
tempo Moderato Moderato
articulation staccato staccato
χ2 (N=132) = 57.66, p<.001

6

Parameter Example: 6 Comparison: 7
register mid mid
dynamic mp mp
tempo Molto Largo Prestissimo
articulation neutral neutral
χ2 (N=73) = 57.88, p<.001

24

Parameter Example: 24 Comparison: 25
register mid mid
dynamic ppp ff
tempo Prestissimo Prestissimo
articulation legato legato
χ2 (N=80) = 33.28, p<.001
Parameter Example: 24 Comparison: 20
register mid low
dynamic ppp ppp
tempo Prestissimo Prestissimo
articulation legato legato
χ2 (N=89) = 30.06, p<.001

25

Parameter Example: 25 Comparison: 29
register mid mid
dynamic ff ff
tempo Prestissimo Molto Largo
articulation legato legato
χ2 (N=81) = 52.28, p<.001
Parameter Example: 25 Comparison: 9
register mid high
dynamic ff ff
tempo Prestissimo Prestissimo
articulation legato legato
χ2 (N=91) = 36.08, p<.001
Parameter Example: 25 Comparison: 21
register mid low
dynamic ff ff
tempo Prestissimo Prestissimo
articulation legato legato
χ2 (N=90) = 28.3, p<.001

26

Parameter Example: 26 Comparison: 30
register mid mid
dynamic ppp ppp
tempo Prestissimo Molto Largo
articulation staccato staccato
χ2 (N=118) = 14.91, p<.1
Parameter Example: 26 Comparison: 10
register mid high
dynamic ppp ppp
tempo Prestissimo Prestissimo
articulation staccato staccato
χ2 (N=111) = 23.86, p<.01
Parameter Example: 26 Comparison: 22
register mid low
dynamic ppp ppp
tempo Prestissimo Prestissimo
articulation staccato staccato
χ2 (N=118) = 32.81, p<.001

27

Parameter Example: 27 Comparison: 11
register mid high
dynamic ff ff
tempo Prestissimo Prestissimo
articulation staccato staccato
χ2 (N=105) = 68.2, p<.001
Parameter Example: 27 Comparison: 23
register mid low
dynamic ff ff
tempo Prestissimo Prestissimo
articulation staccato staccato
χ2 (N=90) = 13.95, p<.05

29

Parameter Example: 29 Comparison: 13
register mid high
dynamic ff ff
tempo Molto Largo Molto Largo
articulation legato legato
χ2 (N=80) = 34.3, p<.001
Parameter Example: 29 Comparison: 17
register mid low
dynamic ff ff
tempo Molto Largo Molto Largo
articulation legato legato
χ2 (N=92) = 35.17, p<.001

31

Parameter Example: 31 Comparison: 19
register mid low
dynamic ff ff
tempo Molto Largo Molto Largo
articulation staccato staccato
χ2 (N=129) = 17.16, p<.05

33

Parameter Example: 33 Comparison: 25
register mid mid
dynamic ff ff
tempo Moderato Prestissimo
articulation legato legato
χ2 (N=100) = 21.84, p<.01
Parameter Example: 33 Comparison: 29
register mid mid
dynamic ff ff
tempo Moderato Molto Largo
articulation legato legato
χ2 (N=99) = 32.58, p<.001

34

Parameter Example: 34 Comparison: 26
register mid mid
dynamic ppp ppp
tempo Moderato Prestissimo
articulation staccato staccato

χ2 (N=160) = 22.87, p<.01

chisq_df <- purrr::flatten_dfr(purrr::map_depth(all_sig, 2, ~{
    data.frame(Example = stringr::str_extract(colnames(.x$data.name[2]), "\\d+"), 
        Comparison = stringr::str_extract(colnames(.x$data.name[3]), "\\d+"), N = sum(.x$observed, 
            na.rm = T), Chi = round(.x$statistic, 2), p = .x$p.value, Sig.Level = HDA::p.txt(.x$p.value))
}))

googlesheets4::write_sheet(chisq_df, ss = "https://docs.google.com/spreadsheets/d/1fsyZ1NVZ2WtYdCFTxQed5WE4KzvTvSC2b7-joD6rieE/edit", 
    sheet = "ChiSq_Results")

General associations between affect and parameter

Cohen (1992) provides thresholds for determining the magnitude of effect sizes as follows: |d|<0.2 “negligible”, |d|<0.5 “small”, |d|<0.8 “medium”, otherwise “large”. These can be applied to the \(\text{Adjusted}\ R^2\) to highlight the most notable associations between affect and parameter: Assertive, Energetic, Playful. The tables above allow us to draw the following conclusions: * the perception of an energetic affect has a small association with increases in the level of tempo and articulation. * the perception of a gentle affect has a small association with a decrease in dynamic and an increase in register. * the perception of playfulness has a small association with an increase in articulation and a decrease in register. * the perception of being moved has a small association with a decrease in dynamic and a decrease in tempo.

examples <- examples %>% tibble::as_tibble() %>% tibble::rownames_to_column("example") %>% 
    dplyr::mutate_all(~tolower(substr(., 0, 3))) %>% dplyr::mutate_at("example", 
    as.numeric) %>% dplyr::arrange(example) %>% dplyr::mutate_at("example", as.factor)
params$tempo[1] <- "largo"
params <- params %>% purrr::map(~{
    factor(tolower(substr(.x, 0, 3)), levels = tolower(substr(.x, 0, 3)))
})


examples_long <- examples[-1] %>% setNames(colnames(.)) %>% purrr::imap_dfc(~{
    .l <- factor(.x, levels = substr(tolower(levels(params[[.y]])), 0, 3))
    purrr::map_dbl(as.numeric(.l), ~c(-1, 0, 1)[.x])
}) %>% {
    setNames(., paste0(names(.), "_p"))
} %>% tibble::rownames_to_column("example") %>% tidyr::pivot_longer(cols = tidyr::ends_with("p"), 
    names_to = "param", values_to = "value") %>% dplyr::mutate_at("param", ~stringr::str_remove(., 
    "_p$")) %>% dplyr::mutate_at("example", as.numeric) %>% dplyr::mutate(vf = factor(value, 
    levels = c(1, 0, -1)))
.g <- examples_long %>% split(f = .$example) %>% purrr::imap(~{
    .p <- ggplot2::ggplot(.x, ggplot2::aes(x = as.factor(substr(toupper(param), 0, 
        1)), y = value)) + ggplot2::geom_col(position = "dodge", ggplot2::aes(fill = vf)) + 
        ggplot2::scale_fill_manual(values = RColorBrewer::brewer.pal(3, "Accent") %>% 
            setNames(c(1, 0, -1))) + ggplot2::geom_hline(yintercept = 0) + ggplot2::labs(title = glue::glue("Ex. {.y}")) + 
        ggplot2::theme(plot.title = element_text(hjust = 0.5), plot.subtitle = element_text(hjust = 0.5), 
            legend.position = "none", axis.text.x = element_text(size = rel(0.75)), 
            axis.title = element_blank()) + ggplot2::scale_y_continuous(breaks = c(1, 
        0, -1), labels = c(1, 0, -1), limits = c(-1, 1))
    .p
}) %>% gridExtra::grid.arrange(grobs = ., nrows = 7)

ggplot2::ggsave("example_params.jpg", .g, device = "jpg", width = 1366/150, height = 970/150, 
    dpi = 150)
sg_results <- dplyr::bind_rows(all_results, .id = "example") %>% dplyr::mutate_at("example", 
    as.numeric) %>% dplyr::arrange(example) %>% dplyr::mutate_at("example", as.factor)

.g_area <- sg_results %>% dplyr::filter(example %in% c(1, 2, 32, 28, 16)) %>% dplyr::arrange(match(example, 
    c(1, 2, 32, 28, 16))) %>% ggplot2::ggplot() + ggplot2::geom_area(ggplot2::aes(x = factor(example, 
    levels = c(1, 2, 32, 28, 16)), y = freq, fill = affect, group = affect)) + ggplot2::scale_x_discrete(labels = rlang::as_function(~{
    purrr::map_chr(.x, ~{
        examples %>% dplyr::filter(example == .x) %>% dplyr::select(dynamic, articulation, 
            tempo, register) %>% unlist %>% paste(collapse = "-")
    })
})) + labs(title = "Parameters on Affect", subtitle = "D-A-T-R Sequential Reduction", 
    caption = "", x = "Parameters", y = "Affect") + theme(plot.title = element_text(hjust = 0.5), 
    plot.subtitle = element_text(hjust = 0.5), axis.text.x = element_text(angle = 45, 
        hjust = 1.2))