Lösung zu Übung 9

Daten & Packages laden

Laden Sie die folgenden Packages und Data-Frames:

library(tidyverse)
library(broom)
library(emmeans)

urla = "https://www.phonetik.uni-muenchen.de/"
urlb = "studium_lehre/lehrmaterialien/R_speech_processing/Rdf/"
url = paste0(urla, urlb)
l.df = read.table(file.path(url, "l.df.txt"), 
                  stringsAsFactors = T)
franken.df = l.df %>% 
  filter(Dial == "J") %>%
  select(Urteil, stim)

tap.df = read.table(file.path(url, "alvtap.txt"), 
                    stringsAsFactors = T)

ucla = read.csv("https://stats.idre.ucla.edu/wp-content/uploads/2016/02/sample.csv")
ucla = ucla %>%
  mutate(female = ifelse(female == 0, "M", "F"),
         hon = ifelse(hon == 0, "yes", "no"), 
         female = factor(female), 
         hon = factor(hon))
names(ucla)[1] = "sex"

a.df = read.table(file.path(url, "adaten.df.txt"),
                  stringsAsFactors = T)
cont2.df = read.table(file.path(url, "cont2.df.txt"), 
                    stringsAsFactors = T)
sigmoid = function(x, k = 0, m = 1) {
  exp(m * x + k) / (1 + exp(m * x + k))
}

• Q1: Für den Data-Frame franken.df wurde ein Stimulus Kontinuum synthetisiert, indem im Wort leiden in 7 Stufen das Verhältnis Vokaldauer:Verschlussdauer manipuliert wurde (stim). Die Hörer mussten pro Beobachtung zwischen leiden und leiten unterscheiden (Urteil). Was ist der Umkipppunkt zwischen leiden und leiten? Was müssten laut diesem Modell die Proportion der leiden-Antworten bei Stimulus 2 sein? Prüfen Sie mit einer geeigneten Abbildung und statistischem Test, ob das Urteil (ob leiden oder leiten) vom Stimulus beeinflusst wurde.

# Proportionen berechnen
p1 = franken.df %>%
  # NB: stim an erster Stelle!
  group_by(stim, Urteil) %>%
  summarise(n = n()) %>%
  mutate(prop = n/sum(n)) %>%
  filter(Urteil == levels(Urteil)[2]) %>%
  # und Proportionen abbilden
  ggplot() +
  aes(y = prop, x = stim) +
  geom_point() +
  ylab("Proportion 'leiten'")

## `summarise()` has grouped output by 'stim'. You can override using the
## `.groups` argument.

p1

# Sigmoid berechnen und darauf überlagern
franken.km = franken.df %>%
  glm(Urteil ~ stim, ., family=binomial) %>%
  coef()
franken.km

## (Intercept)        stim 
##   -5.380750    1.496371

p2 = p1 + 
  # Sigmoid abbilden
  stat_function(fun = sigmoid, 
                args = list(k = franken.km[1], 
                            m = franken.km[2]), col="blue")
p2 

# Umkipppunkt 
-franken.km[1]/franken.km[2]

## (Intercept) 
##    3.595866

# Darauf überlagern und vielleicht den Bereich der 
# x-Achse nach links verlängern
p3 = p2 +
  # Umkipppunkt
  geom_vline(xintercept = -franken.km[1]/franken.km[2], lty=2) +
  scale_x_continuous(limits = c(1,7)) +
  scale_y_continuous(limits = c(0,1))
p3

# Proportion leiden Stimulus 2:
1 - sigmoid(2, k = franken.km[1], m = franken.km[2])

##      stim 
## 0.9159083

# statistischer Test
franken.df %>%
  glm(Urteil ~ stim, ., family = binomial) %>%
  anova(., test = 'Chisq')

## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: Urteil
## 
## Terms added sequentially (first to last)
## 
## 
##      Df Deviance Resid. Df Resid. Dev  Pr(>Chi)    
## NULL                    69     96.124              
## stim  1   53.243        68     42.881 2.947e-13 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Die Wahl zwischen leiden und leiten wurde signifikant (\(X^2\)[1] = 53.243, p < 0.001) vom Stimulus beeinflusst.

• Q2: Der Data-Frame tap.df zeigt, wie oft australisch-englische Sprecher einen post-vokalischen Alveolar (in z.B. ‘water’) mit einem /ɾ/ (einem Tap) (JA) oder einem /t/ (NEIN) produziert haben (K). Wird die Wahl des Konsonanten (K) vom Herkunftsland (Her: “E” = England oder “I” = Irland) beeinflusst?

# Die Analyse ist K ~ Her, daher wie unten.
# Das Bild zeigt: die Iren produzieren 
# proportional mehr Taps als die Engländer
summary(tap.df)

##  K       Alter   Her     Gender      Jahre            Vpn     
##  J:106   a:198   E:345   m:495   Min.   : 5.00   S1     :  1  
##  N:444   j:352   I:205   w: 55   1st Qu.: 5.00   S10    :  1  
##                                  Median : 5.00   S100   :  1  
##                                  Mean   :12.42   S101   :  1  
##                                  3rd Qu.:25.00   S102   :  1  
##                                  Max.   :25.00   S103   :  1  
##                                                  (Other):544

tap.df %>%
  ggplot() +
  aes(fill = K, x = Her) +
  geom_bar(position="fill") +
  ylab("Proportion") +
  xlab("Herkunftsland")

# Test
tap.df %>%
  glm(K ~ Her, ., family = binomial) %>%
  anova(test = 'Chisq')

## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: K
## 
## Terms added sequentially (first to last)
## 
## 
##      Df Deviance Resid. Df Resid. Dev Pr(>Chi)  
## NULL                   549     539.17           
## Her   1   4.4156       548     534.75  0.03561 *
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Die Wahl zwischen einem Tap und [t] wurde signifikant (\(X^2\)[1] = 4.4156, p < 0.05) vom Herkunfsland beeinflusst.

• Q3: Der Data-Frame ucla zeigt ob Männer oder Frauen (sex) in eine sogenannte ‘Honors’ Gruppe (hon) an der Universität aufgenommen wurden (yes) oder nicht (no). Prüfen Sie durch eine Abbildung und statistischen Test, ob die Aufnahme in die Honors Gruppe vom Geschlecht beeinflusst wurde.

summary(ucla)

##  sex          read           write            math        hon     
##  F:109   Min.   :28.00   Min.   :31.00   Min.   :33.00   no : 49  
##  M: 91   1st Qu.:44.00   1st Qu.:45.75   1st Qu.:45.00   yes:151  
##          Median :50.00   Median :54.00   Median :52.00            
##          Mean   :52.23   Mean   :52.77   Mean   :52.65            
##          3rd Qu.:60.00   3rd Qu.:60.00   3rd Qu.:59.00            
##          Max.   :76.00   Max.   :67.00   Max.   :75.00            
##   femalexmath   
##  Min.   : 0.00  
##  1st Qu.: 0.00  
##  Median :40.00  
##  Mean   :28.55  
##  3rd Qu.:53.00  
##  Max.   :72.00

# Das Bild zeigt: Männer wurden bevorzugt aufgenommen.
ucla %>%
  ggplot() +
  aes(x = sex, fill = hon) +
  geom_bar(position = "fill") +
  ylab("Proportion accepted into honors")

# test
ucla %>%
  glm(hon ~ sex, ., family=binomial) %>%
  anova(test = 'Chisq')

## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: hon
## 
## Terms added sequentially (first to last)
## 
## 
##      Df Deviance Resid. Df Resid. Dev Pr(>Chi)  
## NULL                   199     222.71           
## sex   1   3.1038       198     219.61  0.07811 .
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Es gab eine nicht signifikante (p = 0.078) Tendenz, Männer bevorzugt in Honors aufzunehmen.

• Q4: In dem Dataframe a.df wurden offene Vokale synthetisiert, indem F1 geändert wurde. Die Hörer mussten pro Stimulus zwischen /a/ (Lamm) und /a:/ (lahm) wählen. Prüfen Sie, durch eine Abbildung und statistischen Test, ob die Wahl zwischen /a/ und /a:/ durch F1 beeinflusst wurde. Bei welchem F1-Wert ist der /a ~ a:/ Umkipppunkt? Was sind die eingeschätzen propotionalen Werte zu F1-Frequenzen 750, 800, und 850 Hz?

# Proportionen erstellen, und Abbildung speichern
p1 = a.df %>%
  group_by(F1, V) %>%
  summarise(n = n()) %>%
  mutate(prop = n/sum(n)) %>%
  filter(V == levels(V)[2]) %>%
  ggplot() +
  aes(y = prop, x = F1) +
  geom_point() +
  ylab("Proportion /a:/")

## `summarise()` has grouped output by 'F1'. You can override using the `.groups`
## argument.

p1

# Sigmoid-Koeffizienten:
km = a.df %>%
  glm(V ~ F1, ., family=binomial) %>%
  coef()

# überlagern und Bild speichern
p2 = p1 + 
  stat_function(fun = sigmoid, 
                args = list(k = km[1], m = km[2]), col="blue")
p2

# Mit Umkipppunkt - der liegt weit nach rechts, also bei 809 Hz
-km[1]/km[2]

## (Intercept) 
##     809.931

p2 + geom_vline(xintercept = -km[1]/km[2], lty=2)

# Statistik
a.df %>%
  glm(V ~ F1, ., family=binomial) %>%
  anova(test = "Chisq")

## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: V
## 
## Terms added sequentially (first to last)
## 
## 
##      Df Deviance Resid. Df Resid. Dev  Pr(>Chi)    
## NULL                   399     499.98              
## F1    1    13.92       398     486.06 0.0001907 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

# Vorhergesagte Proportionen für F1 = 750, 800, 850 Hz
sigmoid(c(750, 800, 850), km[1], km[2])

## [1] 0.4465338 0.4911072 0.5358224

Die Wahl ob /a/ oder /a:/ wurde signifikant von F1 beeinflusst (\(X^2\)[1] = 13.92, p < 0.001).

• Q5: Für den Data-frame cont2.df wurden F2 Werte automatisch in y oder u (Urteil) für verschiedene Regionen (Region) und Altersgruppen (Alter) von einem Spracherkennungssystem klassifiziert. Prüfen Sie mit Abbildungen und statistischen Tests ob:

• 1. Urteil von Alter beeinflusst wird
• 2. Urteil von F2 beeinflusst wird.

Für (b), bei welchem F2-Wert liegt der Umkipppunkt zwischen /y/ und /u/?

cont2.df %>% 
  ggplot +
  aes(x = Alter, fill = Urteil) +
  geom_bar(position="fill") +
  ylab("Proportion")

Das Urteil wird nicht signifikant vom Alter beeinflusst.

cont2.df %>% 
  glm(Urteil ~ Alter, family=binomial, .) %>%
  anova(test='Chisq')

## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: Urteil
## 
## Terms added sequentially (first to last)
## 
## 
##       Df Deviance Resid. Df Resid. Dev Pr(>Chi)
## NULL                    172     225.76         
## Alter  2   2.5261       170     223.23   0.2828

Abbildung

p1 = cont2.df %>% 
  group_by(F2, Urteil) %>%
  summarise(n = n()) %>%
  mutate(prop = n/sum(n)) %>%
  filter(Urteil == levels(Urteil)[2]) %>%
  ggplot() +
  aes(y = prop, x = F2) +
  geom_point() +
  ylab("Proportion 'y' ")

## `summarise()` has grouped output by 'F2'. You can override using the `.groups`
## argument.

p1

Koeffiziente

km = 
  cont2.df %>% glm(Urteil ~ F2, family=binomial, .) %>%
  coef()

Überlagerter Sigmoid

p1 +
  stat_function(fun = sigmoid, args= list(k = km[1], m = km[2]))

Umkipppunkt

-km[1]/km[2]

## (Intercept) 
##    1591.883

Das Urteil wird signifikant (X^2[1] = 29.488, p < 0.001) beeinflusst.

cont2.df %>% 
  glm(Urteil ~ F2, family=binomial, .) %>%
  anova(test='Chisq')

## Analysis of Deviance Table
## 
## Model: binomial, link: logit
## 
## Response: Urteil
## 
## Terms added sequentially (first to last)
## 
## 
##      Df Deviance Resid. Df Resid. Dev  Pr(>Chi)    
## NULL                   172     225.76              
## F2    1   29.488       171     196.27 5.627e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1