4  Lösungswege

Gerade als Anfänger:in sollten Sie zumindest versuchen, die Aufgaben selbstständig zu lösen, bevor Sie sich die Lösungswege anschauen. Kopf hoch, Sie schaffen das!

Cheat Sheet

Auf GitHub ist ein schöner Cheat-Sheet für data.table vorhanden, der bei der Lösung der Aufgaben hilfreich sein könnte. Das PDF können Sie unter https://raw.githubusercontent.com/rstudio/cheatsheets/master/datatable.pdf herunterladen.

4.1 Lösung zur Aufgabe 3.1 Größe und Gewicht

a) Überführen Sie die Daten in eine data.table mit den Variablen Groesse und Gewicht.
# Paket aktivieren
library(data.table)

# Überführe in eine data.table
dt <- data.table(Groesse = c(1.68, 1.87, 1.95, 1.74, 1.80, 1.75, 1.59, 
                             1.77, 1.82, 1.74),
                 Gewicht = c(78500, 110100, 97500, 69200, 82500, 71500, 
                             81500, 87200, 75500, 65500)
)

# anzeigen
dt
    Groesse Gewicht
      <num>   <num>
 1:    1.68   78500
 2:    1.87  110100
 3:    1.95   97500
 4:    1.74   69200
 5:    1.80   82500
 6:    1.75   71500
 7:    1.59   81500
 8:    1.77   87200
 9:    1.82   75500
10:    1.74   65500

 

b) Rechnen Sie das Gewicht um in Kilogramm, und speichern Sie Ihr Ergebnis in der neuen Variable Kilogramm
# Umrechnen in Kilogramm
dt[, Kilogramm := Gewicht / 1000]

# anzeigen
dt
    Groesse Gewicht Kilogramm
      <num>   <num>     <num>
 1:    1.68   78500      78.5
 2:    1.87  110100     110.1
 3:    1.95   97500      97.5
 4:    1.74   69200      69.2
 5:    1.80   82500      82.5
 6:    1.75   71500      71.5
 7:    1.59   81500      81.5
 8:    1.77   87200      87.2
 9:    1.82   75500      75.5
10:    1.74   65500      65.5

 

c) Lassen Sie die Daten von Proband 4, 7 und 9 ausgeben
# Ausgabe der Daten von Proband 4, 7 und 9
dt[c(4, 7, 9)]
   Groesse Gewicht Kilogramm
     <num>   <num>     <num>
1:    1.74   69200      69.2
2:    1.59   81500      81.5
3:    1.82   75500      75.5

 

d) Lassen Sie die Daten der Probanden ausgeben, deren Gewicht größer ist als 80kg
dt[Kilogramm > 80]
   Groesse Gewicht Kilogramm
     <num>   <num>     <num>
1:    1.87  110100     110.1
2:    1.95   97500      97.5
3:    1.80   82500      82.5
4:    1.59   81500      81.5
5:    1.77   87200      87.2

 

e) Lassen Sie die Daten der Probanden ausgeben, die größer als 1,7m sind und leichter als 85kg
dt[Groesse > 1.7 & Kilogramm < 85]
   Groesse Gewicht Kilogramm
     <num>   <num>     <num>
1:    1.74   69200      69.2
2:    1.80   82500      82.5
3:    1.75   71500      71.5
4:    1.82   75500      75.5
5:    1.74   65500      65.5

 

f) Speichern Sie Ihr data.table-Objekt in die Datei groegew.csv. Lassen Sie sich dabei zunächst anzeigen, was in die Datei geschrieben werden wird.
# zeige, was in die Datei gespeichert würde
fwrite(dt)
Groesse,Gewicht,Kilogramm
1.68,78500,78.5
1.87,110100,110.1
1.95,97500,97.5
1.74,69200,69.2
1.8,82500,82.5
1.75,71500,71.5
1.59,81500,81.5
1.77,87200,87.2
1.82,75500,75.5
1.74,65500,65.5
# speichere in Datei groegew.csv
fwrite(dt, "groegew.csv")

 

4.2 Lösung zur Aufgabe 3.2 Datentabelle

a) Übertragen Sie die Daten in eine data.table mit dem Namen chol.
# übertrage die Daten
chol <- data.table(Name = c("Anna Tomie", "Bud Zillus", "Dieter Mietenplage", 
                            "Hella Scheinwerfer", "Inge Danken", "Jason Zufall"),
                   Geschlecht = c("W", "M", "M", "W", "W", "M"),
                   Gewicht = c(85, 115, 79, 60, 57, 96),
                   Größe = c(179, 173, 181, 170, 158, 174),
                   Cholesterol = c(182, 232, 191, 200, 148, 249)
)
# anzeigen
chol
                 Name Geschlecht Gewicht Größe Cholesterol
               <char>     <char>   <num> <num>       <num>
1:         Anna Tomie          W      85   179         182
2:         Bud Zillus          M     115   173         232
3: Dieter Mietenplage          M      79   181         191
4: Hella Scheinwerfer          W      60   170         200
5:        Inge Danken          W      57   158         148
6:       Jason Zufall          M      96   174         249

 

b) Erstellen Sie eine neue Variable Alter, die zwischen Name und Geschlecht liegt
# Alter der Probanden
alter <- c(18, 32, 24, 35, 46, 68)

# Neue Spalte 'Alter' 
chol[, Alter := alter]

# Spalte 'Alter' zwischen `Name` und `Geschlecht`
setcolorder(chol, c("Name", "Alter", "Geschlecht", "Gewicht", 
                    "Größe", "Cholesterol"))

# Ausgabe der data.table
chol
                 Name Alter Geschlecht Gewicht Größe Cholesterol
               <char> <num>     <char>   <num> <num>       <num>
1:         Anna Tomie    18          W      85   179         182
2:         Bud Zillus    32          M     115   173         232
3: Dieter Mietenplage    24          M      79   181         191
4: Hella Scheinwerfer    35          W      60   170         200
5:        Inge Danken    46          W      57   158         148
6:       Jason Zufall    68          M      96   174         249

 

c) Fügen Sie einen weiteren Fall mit folgenden Daten dem Datenframe hinzu
# Neuer Fall
neu <- data.table(Name = "Mitch Mackes",
                  Alter = 44,
                  Geschlecht = "M",
                  Gewicht = 92,
                  Größe = 178,
                  Cholesterol = 220
)

# mit rbind zusammenbringen
chol <- rbind(chol, neu)

# anzeigen
chol
                 Name Alter Geschlecht Gewicht Größe Cholesterol
               <char> <num>     <char>   <num> <num>       <num>
1:         Anna Tomie    18          W      85   179         182
2:         Bud Zillus    32          M     115   173         232
3: Dieter Mietenplage    24          M      79   181         191
4: Hella Scheinwerfer    35          W      60   170         200
5:        Inge Danken    46          W      57   158         148
6:       Jason Zufall    68          M      96   174         249
7:       Mitch Mackes    44          M      92   178         220

 

d) Erzeugen Sie eine neue Variable BMI.
# BMI berechnen
chol[, BMI := Gewicht / (Größe / 100)^2]

# anzeigen
chol
                 Name Alter Geschlecht Gewicht Größe Cholesterol      BMI
               <char> <num>     <char>   <num> <num>       <num>    <num>
1:         Anna Tomie    18          W      85   179         182 26.52851
2:         Bud Zillus    32          M     115   173         232 38.42427
3: Dieter Mietenplage    24          M      79   181         191 24.11404
4: Hella Scheinwerfer    35          W      60   170         200 20.76125
5:        Inge Danken    46          W      57   158         148 22.83288
6:       Jason Zufall    68          M      96   174         249 31.70828
7:       Mitch Mackes    44          M      92   178         220 29.03674

 

e) Fügen Sie die Variable Adipositas hinzu, in welcher Sie die BMI-Werte wie folgt klassieren

Hierzu können wir entweder die fifelse()-Funktion nutzen…

# Klassifizieren mit fifelse
chol[, Adipositas := fifelse(BMI < 18.5, "Untergewicht",
                     fifelse(BMI >= 18.5 & BMI < 24.5, "Normalgewicht",
                     fifelse(BMI >= 24.5 & BMI <= 30, "Übergewicht", "Adipositas")))]

# anzeigen
chol
                 Name Alter Geschlecht Gewicht Größe Cholesterol      BMI
               <char> <num>     <char>   <num> <num>       <num>    <num>
1:         Anna Tomie    18          W      85   179         182 26.52851
2:         Bud Zillus    32          M     115   173         232 38.42427
3: Dieter Mietenplage    24          M      79   181         191 24.11404
4: Hella Scheinwerfer    35          W      60   170         200 20.76125
5:        Inge Danken    46          W      57   158         148 22.83288
6:       Jason Zufall    68          M      96   174         249 31.70828
7:       Mitch Mackes    44          M      92   178         220 29.03674
      Adipositas
          <char>
1:   Übergewicht
2:    Adipositas
3: Normalgewicht
4: Normalgewicht
5: Normalgewicht
6:    Adipositas
7:   Übergewicht

…oder mittels cut().

# Klassifizieren mit cut()
chol[, Adipositas := cut(BMI, 
                         breaks = c(-Inf, 18.5, 24.5, 30, Inf), 
                         labels = c("Untergewicht", "Normalgewicht", 
                                    "Übergewicht", "Adipositas"))]
# anzeigen
chol
                 Name Alter Geschlecht Gewicht Größe Cholesterol      BMI
               <char> <num>     <char>   <num> <num>       <num>    <num>
1:         Anna Tomie    18          W      85   179         182 26.52851
2:         Bud Zillus    32          M     115   173         232 38.42427
3: Dieter Mietenplage    24          M      79   181         191 24.11404
4: Hella Scheinwerfer    35          W      60   170         200 20.76125
5:        Inge Danken    46          W      57   158         148 22.83288
6:       Jason Zufall    68          M      96   174         249 31.70828
7:       Mitch Mackes    44          M      92   178         220 29.03674
      Adipositas
          <fctr>
1:   Übergewicht
2:    Adipositas
3: Normalgewicht
4: Normalgewicht
5: Normalgewicht
6:    Adipositas
7:   Übergewicht

 

f) Filtern Sie Ihren Datensatz, so dass Sie einen neuen Datensatz male erhalten, welcher nur die Daten der Männer beinhaltet.
male <- chol[Geschlecht == "M"]

# anzeigen
male
                 Name Alter Geschlecht Gewicht Größe Cholesterol      BMI
               <char> <num>     <char>   <num> <num>       <num>    <num>
1:         Bud Zillus    32          M     115   173         232 38.42427
2: Dieter Mietenplage    24          M      79   181         191 24.11404
3:       Jason Zufall    68          M      96   174         249 31.70828
4:       Mitch Mackes    44          M      92   178         220 29.03674
      Adipositas
          <fctr>
1:    Adipositas
2: Normalgewicht
3:    Adipositas
4:   Übergewicht

 

g) Speichern Sie die Objekte chol und male als Textdatei auf Ihre Festplatte. Lassen Sie sich dabei jeweils zuvor anzeigen, welcher Inhalt in die Textdatei geschrieben werden wird.
# zeige, was in chol.txt gespeichert würde
fwrite(chol)
Name,Alter,Geschlecht,Gewicht,Größe,Cholesterol,BMI,Adipositas
Anna Tomie,18,W,85,179,182,26.528510346119,Übergewicht
Bud Zillus,32,M,115,173,232,38.4242707741655,Adipositas
Dieter Mietenplage,24,M,79,181,191,24.1140380330271,Normalgewicht
Hella Scheinwerfer,35,W,60,170,200,20.7612456747405,Normalgewicht
Inge Danken,46,W,57,158,148,22.8328793462586,Normalgewicht
Jason Zufall,68,M,96,174,249,31.7082837891399,Adipositas
Mitch Mackes,44,M,92,178,220,29.0367377856331,Übergewicht
# zeige, was in male.txt gespeichert würde
fwrite(male)
Name,Alter,Geschlecht,Gewicht,Größe,Cholesterol,BMI,Adipositas
Bud Zillus,32,M,115,173,232,38.4242707741655,Adipositas
Dieter Mietenplage,24,M,79,181,191,24.1140380330271,Normalgewicht
Jason Zufall,68,M,96,174,249,31.7082837891399,Adipositas
Mitch Mackes,44,M,92,178,220,29.0367377856331,Übergewicht
# speichere in Datei chol.txt
fwrite(chol, "chol.txt")


# speichere in Datei male.txt
fwrite(male, "male.txt")

 

4.3 Lösung zur Aufgabe 3.3 Big Five

a) Lesen Sie den Datensatz big_five_scores.csv als data.table in Ihre R-Session.

Zunächst laden wir die Datei von https://www.produnis.de/tabletrainer/big_five.zip herunter und legen sie im data-Ordner (siehe Abschnitt 1.1) ab.

Wenn Sie dies bereits getan haben und die Datei big_five_scores.csv bereits entpackt ist, lautet der Befehl zum Einlesen der Daten:

# lese Daten ein
big5 <- fread("data/big_five_scores.csv")

Wir können die Datei aber auch direkt in R herunterladen und entpacken.

# File herunterladen und im "data" Ordner speichern
download.file("https://www.produnis.de/tabletrainer/data/big_five.zip", 
              destfile = "data/testbig_five.zip")

# entpacken in temporäres Verzeichnis
unzip("data/big_five.zip", 
      files = "big_five_scores.csv", 
      exdir = tempdir())

# speichere Pfad auf temporäre Datei
pfad <- file.path(tempdir(), "big_five_scores.csv")

Der Befehl zum Einlesen aus der temporären Datei lautet

fread(pfad)

Falls Sie das unzip Programm auf Ihrem PC installiert haben, können Sie direkt auf das ZIP-Paket zugreifen

fread(cmd = 'unzip -p data/big_five.zip big_five_scores.csv')

Wenn das ZIP-Paket nur eine Datei enthält, muss dessen Dateiname nicht extra angegeben werden.

fread(cmd = 'unzip -p data/big_five.zip')

Mit dem Datensatz vertraut machen:

str(big5)
Classes 'data.table' and 'data.frame':  307313 obs. of  9 variables:
 $ case_id                : int  1 3 4 5 6 7 8 9 10 11 ...
 $ country                : chr  "South Afri" "UK" "USA" "UK" ...
 $ age                    : int  24 24 36 19 17 17 28 28 18 17 ...
 $ sex                    : int  1 2 2 1 1 1 2 2 1 1 ...
 $ agreeable_score        : num  0.753 0.733 0.88 0.69 0.6 ...
 $ extraversion_score     : num  0.497 0.68 0.77 0.617 0.713 ...
 $ openness_score         : num  0.803 0.787 0.86 0.717 0.647 ...
 $ conscientiousness_score: num  0.887 0.747 0.897 0.637 0.633 ...
 $ neuroticism_score      : num  0.427 0.59 0.297 0.563 0.513 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Ändern Sie die Geschlechtskodierung, so dass männlich und weiblich verwendet werden.
# Ändere die Geschlechtskodierung
big5[, sex := fifelse(sex == 1, "männlich", "weiblich")]

str(big5)
Classes 'data.table' and 'data.frame':  307313 obs. of  9 variables:
 $ case_id                : int  1 3 4 5 6 7 8 9 10 11 ...
 $ country                : chr  "South Afri" "UK" "USA" "UK" ...
 $ age                    : int  24 24 36 19 17 17 28 28 18 17 ...
 $ sex                    : chr  "männlich" "weiblich" "weiblich" "männlich" ...
 $ agreeable_score        : num  0.753 0.733 0.88 0.69 0.6 ...
 $ extraversion_score     : num  0.497 0.68 0.77 0.617 0.713 ...
 $ openness_score         : num  0.803 0.787 0.86 0.717 0.647 ...
 $ conscientiousness_score: num  0.887 0.747 0.897 0.637 0.633 ...
 $ neuroticism_score      : num  0.427 0.59 0.297 0.563 0.513 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

c) Passen Sie das Skalenniveau der Variablen an.
# case_id und country sind nominale Variablen
big5[, let(case_id = factor(case_id),
           country = factor(country),
           sex     = factor(sex)
          )]

str(big5)
Classes 'data.table' and 'data.frame':  307313 obs. of  9 variables:
 $ case_id                : Factor w/ 307313 levels "1","3","4","5",..: 1 2 3 4 5 6 7 8 9 10 ...
 $ country                : Factor w/ 236 levels "","Afghanista",..: 190 216 220 216 216 220 220 61 220 185 ...
 $ age                    : int  24 24 36 19 17 17 28 28 18 17 ...
 $ sex                    : Factor w/ 2 levels "männlich","weiblich": 1 2 2 1 1 1 2 2 1 1 ...
 $ agreeable_score        : num  0.753 0.733 0.88 0.69 0.6 ...
 $ extraversion_score     : num  0.497 0.68 0.77 0.617 0.713 ...
 $ openness_score         : num  0.803 0.787 0.86 0.717 0.647 ...
 $ conscientiousness_score: num  0.887 0.747 0.897 0.637 0.633 ...
 $ neuroticism_score      : num  0.427 0.59 0.297 0.563 0.513 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

4.4 Lösung zur Aufgabe 3.4 Rolling Stone Magazine

a) Laden Sie die Datei rolling_stone.csv als data.table in Ihre R-Session und machen Sie sich mit dem Datensatz vertraut.
# falls schon gedownloadet
rs <- fread("data/rolling_stone.csv")

# per URL einlesen
rs <- fread("https://www.produnis.de/tabletrainer/data/rolling_stone.csv")
# anschauen
str(rs)
Classes 'data.table' and 'data.frame':  691 obs. of  21 variables:
 $ sort_name               : chr  "Sinatra, Frank" "Diddley, Bo" "Presley, Elvis" "Sinatra, Frank" ...
 $ clean_name              : chr  "Frank Sinatra" "Bo Diddley" "Elvis Presley" "Frank Sinatra" ...
 $ album                   : chr  "In the Wee Small Hours" "Bo Diddley / Go Bo Diddley" "Elvis Presley" "Songs for Swingin' Lovers!" ...
 $ rank_2003               : int  100 214 55 306 50 NA NA 421 NA 12 ...
 $ rank_2012               : int  101 216 56 308 50 NA 451 420 NA 12 ...
 $ rank_2020               : int  282 455 332 NA 227 32 33 NA 68 31 ...
 $ differential            : int  -182 -241 -277 -195 -177 469 468 -80 433 -19 ...
 $ release_year            : int  1955 1955 1956 1956 1957 2016 2006 1957 1985 1959 ...
 $ genre                   : chr  "Big Band/Jazz" "Rock n' Roll/Rhythm & Blues" "Rock n' Roll/Rhythm & Blues" "Big Band/Jazz" ...
 $ type                    : chr  "Studio" "Studio" "Studio" "Studio" ...
 $ weeks_on_billboard      : int  14 NA 100 NA 5 87 173 NA 27 NA ...
 $ peak_billboard_position : int  2 201 1 2 13 1 2 201 30 201 ...
 $ spotify_popularity      : int  48 50 58 62 64 73 67 47 75 52 ...
 $ spotify_url             : chr  "spotify:album:3GmwKB1tgPZgXeRJZSm9WX" "spotify:album:1cbtDEwxCjMhglb49OgNBR" "spotify:album:7GXP5OhYyPVLmcVfO9Iqin" "spotify:album:4kca7vXd1Wo5GE2DMafvMc" ...
 $ artist_member_count     : int  1 1 1 1 1 1 1 4 1 1 ...
 $ artist_gender           : chr  "Male" "Male" "Male" "Male" ...
 $ artist_birth_year_sum   : int  1915 1928 1935 1915 1932 1981 1983 7752 1958 1926 ...
 $ debut_album_release_year: int  1946 1955 1956 1946 1957 2003 2003 1957 1978 1951 ...
 $ ave_age_at_top_500      : num  40 27 21 41 25 35 23 19 27 33 ...
 $ years_between           : int  9 0 0 10 0 13 3 0 7 8 ...
 $ album_id                : chr  "3GmwKB1tgPZgXeRJZSm9WX" "1cbtDEwxCjMhglb49OgNBR" "7GXP5OhYyPVLmcVfO9Iqin" "4kca7vXd1Wo5GE2DMafvMc" ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Passen Sie das Skalenniveau der Variablen an.

Es gibt einige kategoriale Variablen im Datensatz.

rs[, let(sort_name = factor(sort_name),
         clean_name = factor(clean_name),
         album = factor(album),
         genre = factor(genre),
         type  = factor(type),
         artist_gender  = factor(artist_gender),
         album_id  = factor(album_id),
         spotify_url  = factor(spotify_url)
        )]

# anschauen
str(rs)
Classes 'data.table' and 'data.frame':  691 obs. of  21 variables:
 $ sort_name               : Factor w/ 391 levels "2Pac","50 Cent",..: 315 92 268 315 189 25 377 75 46 83 ...
 $ clean_name              : Factor w/ 386 levels "2Pac","50 Cent",..: 114 40 100 114 185 27 15 53 168 212 ...
 $ album                   : Factor w/ 685 levels "\"\"Love and Theft\"\"",..: 293 101 197 503 263 322 72 544 271 308 ...
 $ rank_2003               : int  100 214 55 306 50 NA NA 421 NA 12 ...
 $ rank_2012               : int  101 216 56 308 50 NA 451 420 NA 12 ...
 $ rank_2020               : int  282 455 332 NA 227 32 33 NA 68 31 ...
 $ differential            : int  -182 -241 -277 -195 -177 469 468 -80 433 -19 ...
 $ release_year            : int  1955 1955 1956 1956 1957 2016 2006 1957 1985 1959 ...
 $ genre                   : Factor w/ 17 levels "","Afrobeat",..: 3 15 15 3 1 1 17 15 1 3 ...
 $ type                    : Factor w/ 5 levels "Compilation",..: 5 5 5 5 5 5 5 5 5 5 ...
 $ weeks_on_billboard      : int  14 NA 100 NA 5 87 173 NA 27 NA ...
 $ peak_billboard_position : int  2 201 1 2 13 1 2 201 30 201 ...
 $ spotify_popularity      : int  48 50 58 62 64 73 67 47 75 52 ...
 $ spotify_url             : Factor w/ 656 levels "","6MjOv3BeIjmht2ymtRih3s",..: 280 105 623 367 93 614 11 132 458 157 ...
 $ artist_member_count     : int  1 1 1 1 1 1 1 4 1 1 ...
 $ artist_gender           : Factor w/ 4 levels "","Female","Male",..: 3 3 3 3 3 2 2 3 2 3 ...
 $ artist_birth_year_sum   : int  1915 1928 1935 1915 1932 1981 1983 7752 1958 1926 ...
 $ debut_album_release_year: int  1946 1955 1956 1946 1957 2003 2003 1957 1978 1951 ...
 $ ave_age_at_top_500      : num  40 27 21 41 25 35 23 19 27 33 ...
 $ years_between           : int  9 0 0 10 0 13 3 0 7 8 ...
 $ album_id                : Factor w/ 691 levels "01TG7VOg4F90jXv3a1yCgA",..: 278 103 621 364 91 612 9 130 455 155 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

c) Welche sind die Nummer 1 Alben der Jahre 2003, 2012 und 2020?
rs[rank_2003 == 1 | rank_2012 == 1 | rank_2020 == 1,
  .(clean_name, album, rank_2003, rank_2012, rank_2020)
]
    clean_name                                 album rank_2003 rank_2012
        <fctr>                                <fctr>     <int>     <int>
1: The Beatles Sgt. Pepper's Lonely Hearts Club Band         1         1
2: Marvin Gaye                       What's Going On         6         6
   rank_2020
       <int>
1:        24
2:         1

 

d) Ist Ihre Lieblingsband in der Liste?

Angenommen, meine Lieblingsband sei Faith No More.

rs[clean_name == "Faith No More"]
Empty data.table (0 rows and 21 cols): sort_name,clean_name,album,rank_2003,rank_2012,rank_2020...

Die ist leider nicht enthalten. Versuchen wir es mit Eminem.

rs[clean_name == "Eminem", .(clean_name, album)]
   clean_name                   album
       <fctr>                  <fctr>
1:     Eminem       The Slim Shady LP
2:     Eminem The Marshall Mathers LP
3:     Eminem         The Eminem Show

 

e) Welche weiblichen Bands haben mehr als 3 Mitglieder?
rs[artist_gender == "Female" & artist_member_count > 3, .(sort_name, clean_name)]
                    sort_name      clean_name
                       <fctr>          <fctr>
1:            Destiny's Child Destiny's Child
2:                  Raincoats   The Raincoats
3:                     Go Gos     The Go-Go's
4: Ross, Diana & the Supremes    The Supremes

 

f) Welche Band hat die meisten Alben im Datensatz?
# zähle die Bands und sortiere absteigend
# und zeige nur die ersten 5 Reihen an
rs[, .N, by = clean_name] |> 
  _[order(-N)][1:5]
          clean_name     N
              <fctr> <int>
1:         Bob Dylan    11
2:       The Beatles    11
3:    Rolling Stones    10
4: Bruce Springsteen     9
5:           The Who     7

Bob Dylan und The Beatles haben jeweils 11 Alben in den Listen

 

g) Prüfen Sie per Korrelationsverfahren, ob die Beliebtheit bei Spotify (spotify_popularity) mit der Liste von 2020 übereinstimmt.
# Achtung, es sind NAs enthalten
rs[, cor(spotify_popularity, rank_2020, use="complete.obs")]
[1] -0.2215204

Es gibt einen geringen negativen Zusammenhang. Da beim Ranking ein geringer Wert für ein gutes Ranking steht, ist es auch nicht verwunderlich, dass der Zusammenhang negativ ist. Bei Spotify bedeutet ein hoher Wert ein gutes Ranking. Dennoch ist der Zusammenhang eher schwach.

 

h) Welchen durchschnittlichen Rang erzielen Alben des Genres “Electronic” in den Jahren 2003, 2012 und 2020?
# Achtung, es sind NAs enthalten
rs[genre == "Electronic", .(d2003 = mean(rank_2003, na.rm=TRUE),
                            d2012 = mean(rank_2012, na.rm=TRUE),
                            d2020 = mean(rank_2020, na.rm=TRUE)
                           )]
      d2003    d2012    d2020
      <num>    <num>    <num>
1: 376.4286 362.1667 298.3636

 

i) Berechnen Sie das arithmetische Mittel und den Median des Albenrankings für jedes Genre im Jahr 2020. Wieviele Alben sind pro Genre enthalten?
# Achtung, es sind NAs enthalten
rs[, .(mean = mean(rank_2020, na.rm=TRUE),
       median = as.numeric(median(rank_2020, na.rm=TRUE)),
       N = sum(!is.na(rank_2020))), by = genre] 
                                  genre     mean median     N
                                 <fctr>    <num>  <num> <int>
 1:                       Big Band/Jazz 251.2000  268.0    10
 2:         Rock n' Roll/Rhythm & Blues 243.2222  263.0     9
 3:                                     254.6273  265.0   110
 4:                     Soul/Gospel/R&B 264.7846  275.0    65
 5:                         Hip-Hop/Rap 204.7544  192.0    57
 6:                    Blues/Blues Rock 267.6786  313.0    28
 7: Country/Folk/Country Rock/Folk Rock 223.3750  211.0    40
 8:              Indie/Alternative Rock 259.8085  276.0    47
 9:   Punk/Post-Punk/New Wave/Power Pop 253.8246  260.0    57
10:                          Electronic 298.3636  241.0    11
11:                          Funk/Disco 280.3158  360.0    19
12:                               Latin 446.5000  471.0     6
13:                     Hard Rock/Metal 215.6111  227.5    18
14:    Singer-Songwriter/Heartland Rock 231.8667  251.0    15
15:                    Blues/Blues ROck 259.0000  259.0     1
16:                              Reggae 155.4000  140.0     5
17:                            Afrobeat 433.5000  433.5     2

Haben Sie den 15. Eintrag Blues/Blues ROck bemerkt? Es ist ein Tippfehler im Datensatz enthalten.

# korrigiere den Tippfehler
rs[genre == "Blues/Blues ROck", genre := "Blues/Blues Rock"]

Jetzt sortieren wir wie gewünscht einmal absteigend nach dem Median, und einmal aufsteigend nach genre.

# sortiert nach Median
rs[, .(mean = mean(rank_2020, na.rm=TRUE),
       median = as.numeric(median(rank_2020, na.rm=TRUE)),
       N = sum(!is.na(rank_2020))), by = genre] |> 
  _[order(median, decreasing = TRUE)]
                                  genre     mean median     N
                                 <fctr>    <num>  <num> <int>
 1:                               Latin 446.5000  471.0     6
 2:                            Afrobeat 433.5000  433.5     2
 3:                          Funk/Disco 280.3158  360.0    19
 4:                    Blues/Blues Rock 267.3793  299.0    29
 5:              Indie/Alternative Rock 259.8085  276.0    47
 6:                     Soul/Gospel/R&B 264.7846  275.0    65
 7:                       Big Band/Jazz 251.2000  268.0    10
 8:                                     254.6273  265.0   110
 9:         Rock n' Roll/Rhythm & Blues 243.2222  263.0     9
10:   Punk/Post-Punk/New Wave/Power Pop 253.8246  260.0    57
11:    Singer-Songwriter/Heartland Rock 231.8667  251.0    15
12:                          Electronic 298.3636  241.0    11
13:                     Hard Rock/Metal 215.6111  227.5    18
14: Country/Folk/Country Rock/Folk Rock 223.3750  211.0    40
15:                         Hip-Hop/Rap 204.7544  192.0    57
16:                              Reggae 155.4000  140.0     5
# sortiert nach Genre
rs[, .(mean = mean(rank_2020, na.rm=TRUE),
       median = as.numeric(median(rank_2020, na.rm=TRUE)),
       N = sum(!is.na(rank_2020))), by = genre] |> 
  _[order(genre)]
                                  genre     mean median     N
                                 <fctr>    <num>  <num> <int>
 1:                                     254.6273  265.0   110
 2:                            Afrobeat 433.5000  433.5     2
 3:                       Big Band/Jazz 251.2000  268.0    10
 4:                    Blues/Blues Rock 267.3793  299.0    29
 5: Country/Folk/Country Rock/Folk Rock 223.3750  211.0    40
 6:                          Electronic 298.3636  241.0    11
 7:                          Funk/Disco 280.3158  360.0    19
 8:                     Hard Rock/Metal 215.6111  227.5    18
 9:                         Hip-Hop/Rap 204.7544  192.0    57
10:              Indie/Alternative Rock 259.8085  276.0    47
11:                               Latin 446.5000  471.0     6
12:   Punk/Post-Punk/New Wave/Power Pop 253.8246  260.0    57
13:                              Reggae 155.4000  140.0     5
14:         Rock n' Roll/Rhythm & Blues 243.2222  263.0     9
15:    Singer-Songwriter/Heartland Rock 231.8667  251.0    15
16:                     Soul/Gospel/R&B 264.7846  275.0    65

 

j) Manche Künstler haben es in jede der 3 Listen geschafft. Wie groß ist die Anzahl an Bands, die in jeder der 3 Listen vertreten sind, wieviele Alben haben in jeder der 3 Listen eine Platzierung, welche Alben sind in jeder der 3 Listen auf dem selben Platz, welche haben sich kontinuierlich verbessert, welche kontinuierlich verschlechtert?
# Anzahl der Bands, die in jeder der 3 Listen sind
rs[!is.na(rank_2003) & !is.na(rank_2012) & !is.na(rank_2020), 
   uniqueN(clean_name)]
[1] 205
# Anzahl der Alben, die in jeder der 3 Listen sind
rs[!is.na(rank_2003) & !is.na(rank_2012) & !is.na(rank_2020), 
   uniqueN(album)]
[1] 317
# Alben mit dem selben Ranking
rs[rank_2003 == rank_2012 & rank_2012 == rank_2020, 
   .(clean_name, album, rank_2003, rank_2012, rank_2020)]  
       clean_name      album rank_2003 rank_2012 rank_2020
           <fctr>     <fctr>     <int>     <int>     <int>
1: The Beach Boys Pet Sounds         2         2         2
# Alben, die sich kontinuierlich verbessert haben
# (verbessert heisst, dass das Ranking kleiner wird)
rs[rank_2003 > rank_2012 & rank_2012 > rank_2020, 
   .(clean_name, album, rank_2003, rank_2012, rank_2020)] |>
  _[order(clean_name)] |>
  # zeige nur die ersten 10, um hier Platz zu sparen
  head(10)
                      clean_name                              album rank_2003
                          <fctr>                             <fctr>     <int>
 1:         A Tribe Called Quest                 The Low End Theory       154
 2:                     Big Star                Third/Sister Lovers       456
 3:                    Brian Eno            Here Come the Warm Jets       436
 4:                    Brian Eno                Another Green World       433
 5:            Bruce Springsteen       Darkness on the Edge of Town       151
 6:                     Coldplay        A Rush of Blood to the Head       473
 7: Creedence Clearwater Revival            Willy and the Poor Boys       392
 8:                 Cyndi Lauper                   She's So Unusual       494
 9:                     D'Angelo                             Voodoo       488
10:                         DEVO Q: Are We Not Men? A: We Are Devo!       447
    rank_2012 rank_2020
        <int>     <int>
 1:       153        43
 2:       449       285
 3:       432       308
 4:       429       338
 5:       150        91
 6:       466       324
 7:       309       193
 8:       487       184
 9:       481        28
10:       442       252
# Alben, die sich kontinuierlich verschlechtert haben
# (verschlechtert heisst, dass das Ranking größer wird)
rs[rank_2003 < rank_2012 & rank_2012 < rank_2020, 
   .(clean_name, album, rank_2003, rank_2012, rank_2020)] |>
  _[order(clean_name)] |>
  # zeige nur die ersten 10, um hier Platz zu sparen
  head(10)
       clean_name                                                album
           <fctr>                                               <fctr>
 1:         AC/DC                                        Back in Black
 2:      Al Green                           I'm Still in Love With You
 3:      Al Green                                              Call Me
 4:          Beck                                               Odelay
 5:      Bee Gees Saturday Night Fever: The Original Movie Sound Track
 6:    Billy Joel                                         The Stranger
 7: Black Sabbath                                             Paranoid
 8: Black Sabbath                                        Black Sabbath
 9:    Bo Diddley                           Bo Diddley / Go Bo Diddley
10:     Bob Dylan                                  John Wesley Harding
    rank_2003 rank_2012 rank_2020
        <int>     <int>     <int>
 1:        73        77        84
 2:       285       286       306
 3:       289       290       427
 4:       305       306       424
 5:       131       132       163
 6:        67        70       169
 7:       130       131       139
 8:       241       243       355
 9:       214       216       455
10:       301       303       337

 

k) Erzeugen Sie eine neue Variable soloband, in welcher festeghalten wird, ob es sich um eine(n) Solokünstler(in) handelt (solo), oder um eine Band (band). Sind Solokünstlerinnen besser platziert als Solokünstler? Sind Bands besser platziert als Solokünstler(innen)?
# Solo oder Band?
rs[, soloband := fifelse(artist_member_count > 1, "band", "solo")]

# Künstlerinnen besser als Künstler?
rs[soloband=="solo", .(mean03 = mean(rank_2003, na.rm=TRUE),
                       mean12 = mean(rank_2012, na.rm=TRUE),
                       mean20 = mean(rank_2020, na.rm=TRUE)
                       ), by = artist_gender]
   artist_gender   mean03   mean12   mean20
          <fctr>    <num>    <num>    <num>
1:          Male 234.3276 234.3314 245.3488
2:        Female 257.2424 262.2121 260.1176

Männliche Solokünstler sind in allen 3 Listen durchschnittlich besser gerankt als weibliche.

# Solo besser als Band?
rs[, .(mean03 = mean(rank_2003, na.rm=TRUE),
       mean12 = mean(rank_2012, na.rm=TRUE),
       mean20 = mean(rank_2020, na.rm=TRUE)
       ), by = soloband]
   soloband   mean03   mean12   mean20
     <char>    <num>    <num>    <num>
1:     solo 237.9807 238.7548 250.2335
2:     band 258.7820 257.8223 249.1203
3:     <NA> 300.5000 318.8000 451.0000

In den Jahren 2003 und 2012 waren Solokünstler besser gerankt als Bands, in 2020 waren Bands leicht besser.

 

l) Der Datensatz liegt als wide.table vor, da die Rankings für 2003, 2012 und 2020 als Variablen nebeneinander stehen. Wandeln Sie den Datensatz in eine long.table (Tidy Data) um, so dass die Rankingangaben in den Variablen Rang und Rangjahr angegeben sind.
# long table mit melt()
long_rs <- melt(rs, 
                measure.vars = c("rank_2003", "rank_2012", "rank_2020"),
                variable.name = "Rangjahr",
                value.name = "Rang")
# anzeigen
head(long_rs)
        sort_name     clean_name                      album differential
           <fctr>         <fctr>                     <fctr>        <int>
1: Sinatra, Frank  Frank Sinatra     In the Wee Small Hours         -182
2:    Diddley, Bo     Bo Diddley Bo Diddley / Go Bo Diddley         -241
3: Presley, Elvis  Elvis Presley              Elvis Presley         -277
4: Sinatra, Frank  Frank Sinatra Songs for Swingin' Lovers!         -195
5: Little Richard Little Richard      Here's Little Richard         -177
6:        Beyonce        Beyonce                   Lemonade          469
   release_year                       genre   type weeks_on_billboard
          <int>                      <fctr> <fctr>              <int>
1:         1955               Big Band/Jazz Studio                 14
2:         1955 Rock n' Roll/Rhythm & Blues Studio                 NA
3:         1956 Rock n' Roll/Rhythm & Blues Studio                100
4:         1956               Big Band/Jazz Studio                 NA
5:         1957                             Studio                  5
6:         2016                             Studio                 87
   peak_billboard_position spotify_popularity
                     <int>              <int>
1:                       2                 48
2:                     201                 50
3:                       1                 58
4:                       2                 62
5:                      13                 64
6:                       1                 73
                            spotify_url artist_member_count artist_gender
                                 <fctr>               <int>        <fctr>
1: spotify:album:3GmwKB1tgPZgXeRJZSm9WX                   1          Male
2: spotify:album:1cbtDEwxCjMhglb49OgNBR                   1          Male
3: spotify:album:7GXP5OhYyPVLmcVfO9Iqin                   1          Male
4: spotify:album:4kca7vXd1Wo5GE2DMafvMc                   1          Male
5: spotify:album:18tV6PLXYvVjsdOVk0S7M8                   1          Male
6: spotify:album:7dK54iZuOxXFarGhXwEXfF                   1        Female
   artist_birth_year_sum debut_album_release_year ave_age_at_top_500
                   <int>                    <int>              <num>
1:                  1915                     1946                 40
2:                  1928                     1955                 27
3:                  1935                     1956                 21
4:                  1915                     1946                 41
5:                  1932                     1957                 25
6:                  1981                     2003                 35
   years_between               album_id soloband  Rangjahr  Rang
           <int>                 <fctr>   <char>    <fctr> <int>
1:             9 3GmwKB1tgPZgXeRJZSm9WX     solo rank_2003   100
2:             0 1cbtDEwxCjMhglb49OgNBR     solo rank_2003   214
3:             0 7GXP5OhYyPVLmcVfO9Iqin     solo rank_2003    55
4:            10 4kca7vXd1Wo5GE2DMafvMc     solo rank_2003   306
5:             0 18tV6PLXYvVjsdOVk0S7M8     solo rank_2003    50
6:            13 7dK54iZuOxXFarGhXwEXfF     solo rank_2003    NA

 

m) Plotten Sie mittels ggplot() die Rangveränderungen von 2003 bis 2020 für solche Alben, die sich kontinuierlich verschlechter haben. Was fällt Ihnen auf?
# ggplot() aktivieren
library(ggplot2)

# Daten vorsortieren
rs[rank_2003 < rank_2012 & rank_2012 < rank_2020, 
   .(album, rank_2003, rank_2012, rank_2020)] |>
  # in long-table überführen
  melt( , measure.vars = c("rank_2003", "rank_2012", "rank_2020"),
          variable.name = "Rangjahr",
          value.name = "Rang") |>
  # ggplot
  ggplot(aes(x=Rangjahr, y=Rang, color=album, group=album)) +
    geom_point() +
    geom_line() +
    ggtitle("Rolling Stone Album-Rankings über verschiedene Jahre") +
    theme(legend.position = "none")

Es fällt auf, dass sich die Rankings vor allem von 2012 nach 2020 deutlich verschlechtert haben.

 

4.5 Lösung zur Aufgabe 3.5 Taylor Swift

a) Laden Sie den Datensatz taylor_swift_spotify2024.csv als data.table in Ihre R-Session. Nennen Sie Ihr Objekt dabei ts und verschaffen Sie sich mittels str() einen Überblick über die enthaltenen Daten.
# falls schon gedownloadet
ts <- fread("data/taylor_swift_spotify2024.csv")

# per URL einlesen
ts <- fread("https://www.produnis.de/tabletrainer/data/taylor_swift_spotify2024.csv")
# anschauen
str(ts)
Classes 'data.table' and 'data.frame':  582 obs. of  18 variables:
 $ V1              : int  0 1 2 3 4 5 6 7 8 9 ...
 $ name            : chr  "Fortnight (feat. Post Malone)" "The Tortured Poets Department" "My Boy Only Breaks His Favorite Toys" "Down Bad" ...
 $ album           : chr  "THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY" "THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY" "THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY" "THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY" ...
 $ release_date    : IDate, format: "2024-04-19" "2024-04-19" ...
 $ track_number    : int  1 2 3 4 5 6 7 8 9 10 ...
 $ id              : chr  "6dODwocEuGzHAavXqTbwHv" "4PdLaGZubp4lghChqp8erB" "7uGYWMwRy24dm7RUDDhUlD" "1kbEbBdEgQdQeLXCJh28pJ" ...
 $ uri             : chr  "spotify:track:6dODwocEuGzHAavXqTbwHv" "spotify:track:4PdLaGZubp4lghChqp8erB" "spotify:track:7uGYWMwRy24dm7RUDDhUlD" "spotify:track:1kbEbBdEgQdQeLXCJh28pJ" ...
 $ acousticness    : num  0.502 0.0483 0.137 0.56 0.73 0.384 0.624 0.178 0.607 0.315 ...
 $ danceability    : num  0.504 0.604 0.596 0.541 0.423 0.521 0.33 0.533 0.626 0.606 ...
 $ energy          : num  0.386 0.428 0.563 0.366 0.533 0.72 0.483 0.573 0.428 0.338 ...
 $ instrumentalness: num  1.53e-05 0.00 0.00 1.00e-06 2.64e-03 0.00 0.00 0.00 0.00 0.00 ...
 $ liveness        : num  0.0961 0.126 0.302 0.0946 0.0816 0.135 0.111 0.309 0.0921 0.106 ...
 $ loudness        : num  -10.98 -8.44 -7.36 -10.41 -11.39 ...
 $ speechiness     : num  0.0308 0.0255 0.0269 0.0748 0.322 0.104 0.0399 0.138 0.0261 0.048 ...
 $ tempo           : num  192 110.3 97.1 159.7 160.2 ...
 $ valence         : num  0.281 0.292 0.481 0.168 0.248 0.438 0.34 0.398 0.487 0.238 ...
 $ popularity      : int  82 79 80 82 80 81 78 79 82 81 ...
 $ duration_ms     : int  228965 293048 203801 261228 262974 340428 210789 215463 254365 334084 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Wenn nötig, korrigiern Sie das Skalenniveau (nominal, ordinal, metrisch) der Variablen innerhalb des Datensatzes.
ts[, let(name  = factor(name),
         album = factor(album),
         id    = factor(id),
         uri   = factor(uri)
        )]

# anzeigen
str(ts)
Classes 'data.table' and 'data.frame':  582 obs. of  18 variables:
 $ V1              : int  0 1 2 3 4 5 6 7 8 9 ...
 $ name            : Factor w/ 363 levels "...Ready For It?",..: 108 319 209 80 256 44 109 101 116 348 ...
 $ album           : Factor w/ 29 levels "1989","1989 (Deluxe)",..: 29 29 29 29 29 29 29 29 29 29 ...
 $ release_date    : IDate, format: "2024-04-19" "2024-04-19" ...
 $ track_number    : int  1 2 3 4 5 6 7 8 9 10 ...
 $ id              : Factor w/ 582 levels "00vJzaoxM3Eja1doBUhX0P",..: 463 343 578 116 580 349 557 394 528 169 ...
 $ uri             : Factor w/ 582 levels "spotify:track:00vJzaoxM3Eja1doBUhX0P",..: 463 343 578 116 580 349 557 394 528 169 ...
 $ acousticness    : num  0.502 0.0483 0.137 0.56 0.73 0.384 0.624 0.178 0.607 0.315 ...
 $ danceability    : num  0.504 0.604 0.596 0.541 0.423 0.521 0.33 0.533 0.626 0.606 ...
 $ energy          : num  0.386 0.428 0.563 0.366 0.533 0.72 0.483 0.573 0.428 0.338 ...
 $ instrumentalness: num  1.53e-05 0.00 0.00 1.00e-06 2.64e-03 0.00 0.00 0.00 0.00 0.00 ...
 $ liveness        : num  0.0961 0.126 0.302 0.0946 0.0816 0.135 0.111 0.309 0.0921 0.106 ...
 $ loudness        : num  -10.98 -8.44 -7.36 -10.41 -11.39 ...
 $ speechiness     : num  0.0308 0.0255 0.0269 0.0748 0.322 0.104 0.0399 0.138 0.0261 0.048 ...
 $ tempo           : num  192 110.3 97.1 159.7 160.2 ...
 $ valence         : num  0.281 0.292 0.481 0.168 0.248 0.438 0.34 0.398 0.487 0.238 ...
 $ popularity      : int  82 79 80 82 80 81 78 79 82 81 ...
 $ duration_ms     : int  228965 293048 203801 261228 262974 340428 210789 215463 254365 334084 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

c) Erstellen Sie eine neue Variable sekunden, welche die Songlängen in Sekunden enthält
ts[, sekunden := duration_ms/1000]

 

d) Wie lang dauern die Songs im Durchschnitt? Bei welcher Songlänge liegt der Median?
ts[, .(Durchschnitt = mean(sekunden),
       Median = median(sekunden)
       )]
   Durchschnitt  Median
          <num>   <num>
1:     240.0112 235.433

 

e) Welcher Song ist laut Datensatz der populärste, welcher der längste, und welcher der langsamste? Stellen Sie anschließend die Werte pro Album dar.
# populärster Song insgesamt
ts[popularity == max(popularity), name]
[1] Cruel Summer
363 Levels: ...Ready For It? ... You're On Your Own, Kid
# populärster Song pro Album
ts[ , .SD[which.max(popularity)], by=album, .SDcols=c("name", "popularity")] |> 
  _[order(popularity, decreasing=TRUE)]
                                                                                  album
                                                                                 <fctr>
 1:                                                                               Lover
 2:                                                       THE TORTURED POETS DEPARTMENT
 3:                                                                           Midnights
 4:                                                                          reputation
 5:                                                                            folklore
 6:                                        THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY
 7:                                                         Fearless (Taylor's Version)
 8:                                                                       1989 (Deluxe)
 9:                                                             1989 (Taylor's Version)
10:                                                        Speak Now (Taylor's Version)
11:                                                              Red (Taylor's Version)
12:                                      reputation Stadium Tour Surprise Song Playlist
13:                                                                            evermore
14:                                                                                1989
15:                                                    1989 (Taylor's Version) [Deluxe]
16:                                                           evermore (deluxe version)
17:                                                    Midnights (The Til Dawn Edition)
18:                                                                           Speak Now
19:                                                          Speak Now (Deluxe Package)
20:                                                             Midnights (3am Edition)
21:                                                           folklore (deluxe version)
22:                                                       Taylor Swift (Deluxe Edition)
23:                                                                                 Red
24:                                                                Red (Deluxe Edition)
25:                                                         Fearless (Platinum Edition)
26: folklore: the long pond studio sessions (from the Disney+ special) [deluxe edition]
27:                                                           Speak Now World Tour Live
28:                                                    Fearless (International Version)
29:                                               Live From Clear Channel Stripped 2008
                                                                                  album
                                                                    name
                                                                  <fctr>
 1:                                                         Cruel Summer
 2:                                        Fortnight (feat. Post Malone)
 3:                                                            Anti-Hero
 4:                                                       Don’t Blame Me
 5:                                                             cardigan
 6:                                        Fortnight (feat. Post Malone)
 7:                                You Belong With Me (Taylor’s Version)
 8:                                                          Blank Space
 9:                                       Blank Space (Taylor's Version)
10:                                         Enchanted (Taylor's Version)
11: All Too Well (10 Minute Version) (Taylor's Version) (From The Vault)
12:                     I Don’t Wanna Live Forever (Fifty Shades Darker)
13:                                                               willow
14:                                                       Wildest Dreams
15:                  Bad Blood (feat. Kendrick Lamar) (Taylor's Version)
16:                                right where you left me - bonus track
17:                          Snow On The Beach (feat. More Lana Del Rey)
18:                                                            Enchanted
19:                                                            Enchanted
20:                                                        The Great War
21:                                                                the 1
22:                                                             Our Song
23:                                             I Knew You Were Trouble.
24:                                             I Knew You Were Trouble.
25:                                                   You Belong With Me
26:                    my tears ricochet - the long pond studio sessions
27:       Back To December/Apologize/You're Not Sorry - Live/2011/Medley
28:                                                           Love Story
29:               Beautiful Eyes - Live From Clear Channel Stripped 2008
                                                                    name
    popularity
         <int>
 1:         93
 2:         91
 3:         85
 4:         85
 5:         84
 6:         82
 7:         81
 8:         81
 9:         80
10:         80
11:         80
12:         79
13:         77
14:         75
15:         74
16:         74
17:         73
18:         71
19:         71
20:         69
21:         68
22:         64
23:         61
24:         59
25:         57
26:         55
27:         47
28:         46
29:         38
    popularity
# längster Song insgesamt
ts[sekunden == max(sekunden), name]
[1] All Too Well (10 Minute Version) (Taylor's Version) (From The Vault)
363 Levels: ...Ready For It? ... You're On Your Own, Kid
# längster Song pro Album
ts[ , .SD[which.max(sekunden)], by=album, .SDcols=c("name", "sekunden")] |> 
  _[order(sekunden, decreasing=TRUE)]
                                                                                  album
                                                                                 <fctr>
 1:                                                              Red (Taylor's Version)
 2:                                                        Speak Now (Taylor's Version)
 3:                                                           Speak Now World Tour Live
 4:                                                                           Speak Now
 5:                                                          Speak Now (Deluxe Package)
 6:                                      reputation Stadium Tour Surprise Song Playlist
 7:                                        THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY
 8:                                                       THE TORTURED POETS DEPARTMENT
 9:                                                                Red (Deluxe Edition)
10:                                                                                 Red
11:                                                           evermore (deluxe version)
12:                                                                            evermore
13:                                                         Fearless (Taylor's Version)
14:                                                         Fearless (Platinum Edition)
15: folklore: the long pond studio sessions (from the Disney+ special) [deluxe edition]
16:                                                                            folklore
17:                                                           folklore (deluxe version)
18:                                                    Fearless (International Version)
19:                                                                               Lover
20:                                                    1989 (Taylor's Version) [Deluxe]
21:                                                             1989 (Taylor's Version)
22:                                                                       1989 (Deluxe)
23:                                                                                1989
24:                                                    Midnights (The Til Dawn Edition)
25:                                                             Midnights (3am Edition)
26:                                               Live From Clear Channel Stripped 2008
27:                                                                           Midnights
28:                                                       Taylor Swift (Deluxe Edition)
29:                                                                          reputation
                                                                                  album
                                                                    name
                                                                  <fctr>
 1: All Too Well (10 Minute Version) (Taylor's Version) (From The Vault)
 2:                                         Dear John (Taylor's Version)
 3:                                                Dear John - Live/2011
 4:                                                            Dear John
 5:                                                            Dear John
 6:                                                            Enchanted
 7:                                                 But Daddy I Love Him
 8:                                                 But Daddy I Love Him
 9:                                                         All Too Well
10:                                                         All Too Well
11:                                                            happiness
12:                                                            happiness
13:                                       Untouchable (Taylor’s Version)
14:                                                          Untouchable
15:                    my tears ricochet - the long pond studio sessions
16:                                                                betty
17:                                                                betty
18:                                                              Fifteen
19:                                                             Daylight
20:                     Say Don't Go (Taylor's Version) (From The Vault)
21:                     Say Don't Go (Taylor's Version) (From The Vault)
22:                                                                Clean
23:                                                                Clean
24:                                        Would've, Could've, Should've
25:                                        Would've, Could've, Should've
26:                       Change - Live From Clear Channel Stripped 2008
27:                               Snow On The Beach (feat. Lana Del Rey)
28:                                           Tied Together with a Smile
29:                                                             End Game
                                                                    name
    sekunden
       <num>
 1:  613.026
 2:  405.906
 3:  404.680
 4:  403.933
 5:  403.887
 6:  353.253
 7:  340.428
 8:  340.428
 9:  329.160
10:  327.893
11:  315.146
12:  315.146
13:  312.107
14:  311.040
15:  295.173
16:  294.521
17:  294.520
18:  294.306
19:  293.453
20:  279.833
21:  279.833
22:  271.000
23:  271.000
24:  260.361
25:  260.361
26:  258.487
27:  256.124
28:  248.106
29:  244.826
    sekunden
# langsamster Song insgesamt
ts[tempo == min(tempo), name]
[1] this is me trying - the long pond studio sessions
363 Levels: ...Ready For It? ... You're On Your Own, Kid
# langsamster Song pro Album
ts[ , .SD[which.min(tempo)], by=album, .SDcols=c("name", "tempo")] |> 
  _[order(tempo)]
                                                                                  album
                                                                                 <fctr>
 1: folklore: the long pond studio sessions (from the Disney+ special) [deluxe edition]
 2:                                                                               Lover
 3:                                        THE TORTURED POETS DEPARTMENT: THE ANTHOLOGY
 4:                                                                                1989
 5:                                      reputation Stadium Tour Surprise Song Playlist
 6:                                                              Red (Taylor's Version)
 7:                                                       Taylor Swift (Deluxe Edition)
 8:                                                           evermore (deluxe version)
 9:                                                                            evermore
10:                                                                          reputation
11:                                                                            folklore
12:                                                           folklore (deluxe version)
13:                                                                Red (Deluxe Edition)
14:                                                                                 Red
15:                                                           Speak Now World Tour Live
16:                                                        Speak Now (Taylor's Version)
17:                                                    1989 (Taylor's Version) [Deluxe]
18:                                                             1989 (Taylor's Version)
19:                                                       THE TORTURED POETS DEPARTMENT
20:                                                                       1989 (Deluxe)
21:                                                    Midnights (The Til Dawn Edition)
22:                                                             Midnights (3am Edition)
23:                                                                           Midnights
24:                                                         Fearless (Platinum Edition)
25:                                                         Fearless (Taylor's Version)
26:                                                          Speak Now (Deluxe Package)
27:                                                                           Speak Now
28:                                                    Fearless (International Version)
29:                                               Live From Clear Channel Stripped 2008
                                                                                  album
                                                           name  tempo
                                                         <fctr>  <num>
 1:           this is me trying - the long pond studio sessions 68.097
 2:                                                       Lover 68.534
 3:                            Chloe or Sam or Sophia or Marcus 70.266
 4:                                                   This Love 71.981
 5:                                                     Breathe 73.849
 6:              Better Man (Taylor's Version) (From The Vault) 73.942
 7:                                   Mary's Song (Oh My My My) 74.900
 8:                                                 tolerate it 74.952
 9:                                                 tolerate it 74.952
10:                                               So It Goes... 74.957
11:                                      exile (feat. Bon Iver) 75.602
12:                                      exile (feat. Bon Iver) 75.938
13:                                    I Knew You Were Trouble. 77.019
14:                                    I Knew You Were Trouble. 77.019
15:                                            Ours - Live/2011 77.769
16: When Emma Falls in Love (Taylor’s Version) (From The Vault) 77.879
17:               ""Slut!"" (Taylor's Version) (From The Vault) 77.978
18:               ""Slut!"" (Taylor's Version) (From The Vault) 77.978
19:                                                        loml 78.539
20:                                  I Know Places - Voice Memo 78.828
21:                                              Vigilante Shit 79.964
22:                                              Vigilante Shit 79.964
23:                                              Vigilante Shit 79.964
24:                                              Jump Then Fall 79.991
25:            Bye Bye Baby (Taylor’s Version) (From The Vault) 80.132
26:                                  Haunted - Acoustic Version 80.858
27:                                                   Enchanted 81.975
28:                                                 White Horse 92.710
29:            Fearless - Live From Clear Channel Stripped 2008 96.601
                                                           name  tempo

 

f) Welches Album hat die meisten Songs, und welches hat die wenigsten Songs?
# die meisten Songs
ts[ , .N, by=album][order(-N)][1]
                                            album     N
                                           <fctr> <int>
1: reputation Stadium Tour Surprise Song Playlist    46
# die wenigsten Songs
ts[ , .N, by=album][order(N)][1]
                                   album     N
                                  <fctr> <int>
1: Live From Clear Channel Stripped 2008     8

 

g) Plotten Sie die Anzahl der Tracks pro Album als Punkt-Liniendiagramm, wobei das Datum auf der X-Achse, und die Trackanzahl auf der Y-Achse dargestellt werden.
# Zähle Tracks pro Album
ts[ , .N, by=release_date] |> 
  # ggplot
  ggplot(aes(x = release_date, y = N)) +
    geom_line(color = "purple") +
    geom_point(color = "purple") +
    labs(x = "Datum", 
         y = "Anzahl Tracks", 
         title = "Taylor Swift Alben")

 

4.6 Lösung zur Aufgabe 3.6 Anscombe-Quartett

a) Laden Sie den Datensatz anscombe in Ihre R-Session und überführen Sie ihn in ein data.table Objekt mit dem Namen ac.
# aktiviere Datensatz
data("anscombe")

# überführe in data.table "ac"
ac <- as.data.table(anscombe)

 

b) Die Daten liegen als breite Tabelle (wide tabel) vor. Überführen Sie sie ins long table (tidy) Format, so dass Ihre data.table aus den Spalten x, y, und Gruppe besteht.

Hierfür benutzen wir patterns(), um mittels regular expression alle Spalten auszuwählen, deren Namen mit x oder y anfangen.

# tidy data Format
lac <- melt(ac,
  measure.vars = patterns("^x", "^y"),
  value.name = c("x", "y"),           
  variable.name = "Gruppe"            
)

 

c) Berechnen Sie für jede Gruppe die Mittelwerte, Standardabweichungen, Korrelations- und Regressionskoeffizienten von x und y, wobei Sie Ihre Ergebnisse auf 2 Stellen runden sollen.
# berechne Anscombe Werte
lac[, .(MittelX = round(mean(x), 2),
        StdabwX = round(sd(x), 2),
        MittelY = round(mean(y), 2),
        StdabwY = round(sd(y), 2),
        Korrela = round(cor(x, y), 2),
        Regress = round(lm(y~x)$coefficients[2], 2)
        ), by = Gruppe]
   Gruppe MittelX StdabwX MittelY StdabwY Korrela Regress
   <fctr>   <num>   <num>   <num>   <num>   <num>   <num>
1:      1       9    3.32     7.5    2.03    0.82     0.5
2:      2       9    3.32     7.5    2.03    0.82     0.5
3:      3       9    3.32     7.5    2.03    0.82     0.5
4:      4       9    3.32     7.5    2.03    0.82     0.5

Jede Gruppe liefert die selben Werte!

 

d) Erzeugen Sie mittels ggplot() eine Punktwolke mit Regressionsgeraden für jede Gruppe, wobei alle 4 Diagramme mit einem Plotaufruf erzeugt werden sollen.
# plotten
ggplot(lac, aes(x=x, y=y)) +
  geom_point(color="darkblue")+
  geom_smooth(method="lm", color="red", se=FALSE) +
  facet_wrap(~Gruppe) +
  ggtitle("Anscombe Quartett")

Jede Gruppe liefert zwar die selben Kennwert, aber die Diagramme sehen nicht nur vollständig unterschiedlich aus, sie legen auch nahe, dass Ausreißer oder Messfehler die Ergebnisse verzerrt haben, und dass andere Korrelations- und Regressionsmethoden zu wählen sind.

heutzutage

Es ist nicht bekannt, wie Anscombe den Datensatz in den 1970er Jahren erstellt hat. Heutzutage ist es mit Hilfe von evolutionären Algorithmen möglich, weit komplexere Datensätze zu erzeugen, die in ihren Kennwerten übereinstimmen, deren Streudiagramme aber beliebige Formen annehmen können.

Mein Favorit ist der Datasaurus von Matejka & Fitzmaurice (2017).

# Daten einlesen 
load(url("https://www.produnis.de/tabletrainer/data/datasaurus.RData"))
# plotten
ggplot(datasaurus, aes(x=x, y=y)) +
  geom_point() +
  facet_wrap(~dataset)

 

4.7 Lösung zur Aufgabe 3.7 Neugeborene: Rauchen

a) Überführen Sie die Daten in ein data.table-Objekt mit dem Namen ng.
# Lade Daten
load("https://www.produnis.de/tabletrainer/data/neonates.RData")

# überführe in data.table
ng <- as.data.table(neonates)
# anschauen
summary(ng)
     weight         gender                 age      smoke       cigarettes    
 Min.   :2.021   male  :157   greater than 20:218   No :220   Min.   : 0.000  
 1st Qu.:2.794   female:163   less than 20   :102   Yes:100   1st Qu.: 0.000  
 Median :3.030                                                Median : 0.000  
 Mean   :3.026                                                Mean   : 3.891  
 3rd Qu.:3.267                                                3rd Qu.: 8.250  
 Max.   :4.182                                                Max.   :22.000  
 smoke.before     apgar1          apgar5      
 No :185      Min.   :2.000   Min.   : 2.000  
 Yes:135      1st Qu.:5.000   1st Qu.: 5.000  
              Median :6.000   Median : 6.000  
              Mean   :5.628   Mean   : 6.213  
              3rd Qu.:6.000   3rd Qu.: 7.000  
              Max.   :9.000   Max.   :10.000  

 

b) Die Variabel apgar1 enthält die APGAR-Scores nach 1 Minute. Wenn ein Score von 3 oder weniger anzeigt, dass das Neugeborene in einem kritischen Zusatand ist, wie viel Prozent der Neugeborenen in der Stichprobe sind dann in einem kritischen Zustand?
ng[ , .(Prozent = 100 * mean(apgar1 <= 3))]
   Prozent
     <num>
1:  7.8125

7,8125% der Neugeborenen sind in einem kritischen Zustand.

 

c) Erstellen Sie die Häufigkeitstabelle des Geburtsgewichts der Neugeborenen, indem Sie die Daten in Klassen mit einer Breite von 0,5 kg von 2 bis 4,5 kg einteilen. Welches Intervall enthält die meisten Neugeborenen?
ng[, gewichtK := cut(weight, 
                     breaks=seq(2, 4.5, by=0.5), 
                     right=FALSE)] |> 
  _[, jgsbook::freqTable(gewichtK)]
     Wert Haeufig Hkum Relativ   Rkum
1 [2,2.5)      22   22    6.88   6.88
2 [2.5,3)     127  149   39.69  46.57
3 [3,3.5)     146  295   45.62  92.19
4 [3.5,4)      24  319    7.50  99.69
5 [4,4.5)       1  320    0.31 100.00

 

d) Vergleichen Sie die Häufigkeitsverteilung des APGAR-Scores nach 1 Minute für Mütter unter 20 Jahren und für Mütter über 20 Jahren. Welche Gruppe hat mehr Neugeborene in kritischem Zustand?
# Jünger als 20
ng[age=="less than 20",  jgsbook::freqTable(apgar1)]
  Wert Haeufig Hkum Relativ  Rkum
1    2       2    2    1.96  1.96
2    3      11   13   10.78 12.74
3    4      16   29   15.69 28.43
4    5      28   57   27.45 55.88
5    6      28   85   27.45 83.33
6    7      12   97   11.76 95.09
7    8       4  101    3.92 99.01
8    9       1  102    0.98 99.99
# Älter als 20
ng[age=="greater than 20",  jgsbook::freqTable(apgar1)]
  Wert Haeufig Hkum Relativ   Rkum
1    2       2    2    0.92   0.92
2    3      10   12    4.59   5.51
3    4      22   34   10.09  15.60
4    5      53   87   24.31  39.91
5    6      69  156   31.65  71.56
6    7      34  190   15.60  87.16
7    8      24  214   11.01  98.17
8    9       4  218    1.83 100.00

In der Gruppe der unter-20-jährigen liegt der Prozentsatz an Neugeborenen mit APGAR-Werten kleiner-gleich 3 bei 12,74%. In der Gruppe der über-20-jährigen liegt der Prozentwert bei 5,51%. Es tritt also in der Gruppe der jüngeren Mütter häufiger auf.

 

e) Vergleichen Sie die relative Häufigkeitsverteilung des Geburtsgewichts der Neugeborenen, je nachdem, ob die Mutter während der Schwangerschaft geraucht hat (smoke) oder nicht. Wenn ein Gewicht unter 2,5 kg als niedriges Gewicht gilt, welche Gruppe hat einen höheren Prozentsatz an Neugeborenen mit niedrigem Gewicht?
# Prozenzsatz Geburtsgewicht kleiner 2,5kg
ng[, .(Prozent = 100 * mean(weight<2.5)), by=smoke]
    smoke   Prozent
   <fctr>     <num>
1:     No  2.272727
2:    Yes 17.000000

In der Gruppe der Nichtraucherinnen trat ein Geburtsgewicht kleiner 2,5kg in 2,27% der Fälle auf. Bei den Raucherinnen waren es 17%.

 

f) Berechnen Sie die Prävalenz von Neugeborenen mit niedrigem Gewicht für Mütter, die vor der Schwangerschaft geraucht haben (smoke.before), und den Nichtraucherinnen.
# Prozenzsatz Geburtsgewicht kleiner 2,5kg
ng[, .(Prozent = 100 * mean(weight<2.5)), by=smoke.before]
   smoke.before   Prozent
         <fctr>     <num>
1:           No  1.081081
2:          Yes 14.814815

Die Prävalenz beträgt unter den Nichtraucherinnen 1,08% und unter den Raucherinnen 14,81%.

 

g) Berechnen Sie die Odds Ratio eines niedrigen Geburtsgewichts des Neugeborenen, wenn die Mutter während der Schwangerschaft raucht, im Vergleich dazu, wenn die Mutter nicht raucht.
# Kreuztabelle erzeugen
t <- dcast(ng, smoke ~ (weight < 2.5), fun=length, value.var="weight")
# in Matrix überführen
t <- as.matrix(t, rownames=TRUE)
# Odds Ratio
epitools::oddsratio(t)$measure
                        NA
odds ratio with 95% C.I. estimate    lower    upper
                     No  1.000000       NA       NA
                     Yes 8.558258 3.236616 27.28525

Raucherinnen haben ein 8-fach höheres Risiko ein Kind mit niedrigem Gewicht zugebären als Nichtraucherinnen.

 

h) Erstellen Sie das Balkendiagramm der kumulierten relativen Häufigkeit des APGAR-Scores nach 1 Minute. Unter welchem Wert liegen die Hälfte der Neugeborenen?
# relative Häufigkeitstabelle
ng[, .(prop.table(table(apgar1)))] |> 
  # kumulieren
  _[, Relkum := cumsum(N)][] |>
  # an ggplot() senden
  ggplot(aes(x=apgar1, y=Relkum)) +
    geom_bar(stat="identity", col="black", fill="khaki") +
    geom_hline(yintercept = 0.5, col="indianred3")

Die Hälfte der Werte liegen unter 6.

 

i) Vergleichen Sie die Balkendiagramme der relativen Häufigkeitsverteilungen des APGAR-Scores nach 1 Minute, je nachdem, ob die Mutter während der Schwangerschaft geraucht hat oder nicht. Welche Schlussfolgerungen können gezogen werden?
# relative Häufigkeitstabelle
ng[, apgar1, by=smoke] |>
  # an ggplot() senden
  ggplot(aes(x=apgar1, y=after_stat(prop)*100, fill=smoke)) +
    geom_bar(col="black", position = "dodge") +
    scale_x_continuous(breaks = c(1:9)) +
  ylab("relative Häufigkeiten")

Die Kinder der Raucherinnen haben geringere APGAR-Werte. Kein Kind von Raucherinnen erreicht Wert 9.

 

j) Berechnen Sie Median, Durchschnitt und Standardabweichung für die APGAR-Scores nach 1 und nach 5 Minuten jeweils für die Kinder von Müttern, die vor der Schwangerschaft geraucht haben, und den Nichtraucherinnen. Geben Sie auch die Anzahl an Fällen (N) an. Bewerten Sie die Ergebnisse.
# wähle benötigte Variablen aus
ng[, .(smoke.before, apgar1, apgar5)] |>
  # überführe in long table (tidy data)
  melt(id.vars= "smoke.before",
       measure.vars = c("apgar1", "apgar5"),
       variable.name = "Test",
       value.name = "APGAR_Score")|>
  # berechne die Kennwerte pro Gruppe
  _[, .(Median = median(APGAR_Score),
        Mittel = mean(APGAR_Score),
        StdAbw = sd(APGAR_Score),
        N = .N
       ), by = c("Test", "smoke.before")]
     Test smoke.before Median   Mittel   StdAbw     N
   <fctr>       <fctr>  <num>    <num>    <num> <int>
1: apgar1           No      6 6.054054 1.241185   185
2: apgar1          Yes      5 5.044444 1.449996   135
3: apgar5           No      7 6.616216 1.284843   185
4: apgar5          Yes      6 5.659259 1.546122   135

Kinder von Frauen, die vor der Schwangerschaft geraucht haben, haben zu beiden Messzeitpunkten niedrigere APGAR-Scores und eine höhere Streuung der Werte.

 

k) Ist der Unterschied der APGAR-Scores aus Aufgabe j) signifikant?

Testen wir zunächst auf Normalverteilung

# Teste apgar1 auf Normalverteilung
ng[, .(p = shapiro.test(apgar1)$p.value), by="smoke.before"]
   smoke.before            p
         <fctr>        <num>
1:           No 8.733447e-07
2:          Yes 5.514593e-05
# Teste apgar5 auf Normalverteilung
ng[, .(p = shapiro.test(apgar5)$p.value), by="smoke.before"]
   smoke.before            p
         <fctr>        <num>
1:           No 2.449301e-07
2:          Yes 3.197790e-04

Alle Tests sind signifikant, d.h. es liegt keine Normalverteilung vor. Wir dürfen also nicht den t-Test verwenden, sondern müssen den Mann-Whitney-U-Test anwenden.

# Signifikanztest für APGAR1
ng[, wilcox.test(apgar1 ~ smoke.before)$p.value]
[1] 3.02217e-10
# Signifikanztest für APGAR5
ng[, wilcox.test(apgar5 ~ smoke.before)$p.value]
[1] 1.759924e-08

Beide Ergebnisse sind signifikant. Das bedeutet, dass der Unterschied in den APGAR-Scores zwischen Nichtraucherinnen und Müttern, die vor der Schwangerschaft geraucht haben, signifikant ist.

 

4.8 Lösung zur Aufgabe 3.8 Verteidigung gegen die dunklen Künste

a) Laden Sie die Textdateien als data.table in Ihre R-Session, und führe Sie diese zu einem einzelnen data.table-Objekt mit dem Namen hp zusammen.
# Lade Daten
lupin <- fread("https://www.produnis.de/tabletrainer/data/VgddK_Lupin.txt")
moody <- fread("https://www.produnis.de/tabletrainer/data/VgddK_Moody.txt")
umbri <- fread("https://www.produnis.de/tabletrainer/data/VgddK_Umbridge.txt")
# führe zu einem Objekt "hp" zusammen
hp <- lupin[moody, on=.(Schüler=Schüler)][umbri, on=.(Schüler=Schüler)]

# anschauen
str(hp)
Classes 'data.table' and 'data.frame':  25 obs. of  4 variables:
 $ Schüler           : chr  "Harry Potter" "Hermine Granger" "Ron Weasley" "Neville Longbottom" ...
 $ Professor Lupin   : num  8.5 9.5 7.5 6 8 8.2 7.8 7 8.5 7.7 ...
 $ Professor Moody   : num  9 9.7 8 7 8.5 8.8 8.2 7.5 8.9 8.2 ...
 $ Professor Umbridge: num  2.5 5 2.2 3.5 4.8 4.7 4 3.8 4.6 4.2 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Erstellen Sie mit ggplot() ein Diagramm, welches die Leistungspunkte als Boxplots für jeden Professor darstellt. Hierfür bietet es sich an, die Daten ins long table Format zu überführen.
# Daten ins long-table-tidy-Format bringen
melt(hp, 
     id.vars = "Schüler",
     variable.name = "Professoren",
     value.name = "Leistungspunkte") |> 
  # mit ggplot() plotten
  ggplot(aes(x=Professoren, y=Leistungspunkte)) +
    geom_boxplot(fill=c("steelblue", "skyblue", "orchid")) +
    stat_boxplot(geom="errorbar") +
    ggtitle("Verteidigung gegen die dunklen Künste")

 

4.9 Lösung zur Aufgabe 3.9 Hogwarts Hauspunkte

a) Laden Sie den Datensatz in Ihre R-Session, und überführen Sie ihn in eine data.table mit dem Namen pp.
# Lade Daten
load("https://www.produnis.de/tabletrainer/data/PotterHauspunkte.RData")

# überführe in data.table
pp <- as.data.table(PotterPunkte)
# anschauen
str(pp)
Classes 'data.table' and 'data.frame':  3273 obs. of  4 variables:
 $ Haus : Factor w/ 4 levels "Gryffindor","Hufflepuff",..: 1 3 1 3 3 1 2 4 3 3 ...
 $ Jahr1: num  52 48 49 50 72 42 5 25 30 49 ...
 $ Jahr3: num  58 70 59 62 74 86 38 54 58 70 ...
 $ Jahr5: num  73 86 75 72 83 77 45 81 77 91 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Berechnen Sie Median, Mittelwert und Standardabweichung für die Hauspunkte insgesamt, und jeweils für jedes Haus und Jahr gesondert.
# Werte insgesamt
pp[, .(Median = median(c(Jahr1, Jahr3, Jahr5)),
       Mittel = mean(c(Jahr1, Jahr3, Jahr5)),
       Stdabw = sd(c(Jahr1, Jahr3, Jahr5))
      )]
   Median   Mittel   Stdabw
    <num>    <num>    <num>
1:     57 57.56788 20.75463
# Werte für Haus und Schuljahr
melt(pp, 
     id.vars = "Haus",
     measure.vars = c("Jahr1", "Jahr3", "Jahr5"),
     variable.name = "Schuljahr",
     value.name = "Hauspunkte") |> 
  _[, .(Median = median(Hauspunkte),
        Mittel = mean(Hauspunkte),
        Stdabw = sd(Hauspunkte)), by = c("Haus", "Schuljahr")]
          Haus Schuljahr Median   Mittel    Stdabw
        <fctr>    <fctr>  <num>    <num>     <num>
 1: Gryffindor     Jahr1     44 44.12576 11.609269
 2:  Ravenclaw     Jahr1     51 50.41860 13.008144
 3: Hufflepuff     Jahr1     33 35.60562 21.915475
 4:  Slytherin     Jahr1     41 40.22494 16.580231
 5: Gryffindor     Jahr3     57 57.84615 12.826595
 6:  Ravenclaw     Jahr3     65 65.20808 13.089933
 7: Hufflepuff     Jahr3     45 45.17582 14.781732
 8:  Slytherin     Jahr3     55 54.80562 13.750892
 9: Gryffindor     Jahr5     79 79.37729 11.757972
10:  Ravenclaw     Jahr5     85 85.23501  8.721373
11: Hufflepuff     Jahr5     56 55.47619 14.694455
12:  Slytherin     Jahr5     78 77.38386  8.102576

 

c) Plotten Sie die Punkte als Boxplots in Abhängigkeit zum Schuljahr, und dann in Abhängigkeit zum Haus. Verknüpfen Sie abschließend diese Bedingungen mittels facet.wrap().
# Daten ins long-table-tidy-Format bringen
long_pp <- melt(pp, 
     id.vars = "Haus",
     measure.vars = c("Jahr1", "Jahr3", "Jahr5"),
     variable.name = "Schuljahr",
     value.name = "Hauspunkte") 

# plotte Punkte pro Schuljahr
ggplot(long_pp, aes(x=Schuljahr, y=Hauspunkte)) +
  geom_boxplot(fill=c("steelblue", "skyblue", "orchid")) +
  stat_boxplot(geom="errorbar") +
  ggtitle("Punkte für den Hauspokal")

# plotte Punkte pro Haus
ggplot(long_pp, aes(x=Haus, y=Hauspunkte)) +
  geom_boxplot(fill=c("gold", "orchid", "skyblue", "seagreen3")) +
  stat_boxplot(geom="errorbar") +
  ggtitle("Punkte für den Hauspokal")

# Kombination von beiden Bedingungen
ggplot(long_pp, aes(y=Hauspunkte, fill=Haus)) +
  geom_boxplot() +
  theme(axis.text.x=element_blank(), 
        axis.ticks.x=element_blank(),
        legend.position = "none") +
  facet_grid(Schuljahr~Haus) +
  ggtitle("Punkte für den Hauspokal")

 

4.10 Lösung zur Aufgabe 3.10 Lungenkapazität

a) Laden Sie den Datensatz lungcap als data.table mit dem Namen lc in Ihre R-Session
# Lade Daten
library(GLMsData)
data("lungcap")

# überführe in data.table
lc <- as.data.table(lungcap)

# anschauen
str(lc)
Classes 'data.table' and 'data.frame':  654 obs. of  5 variables:
 $ Age   : int  3 4 4 4 4 4 4 5 5 5 ...
 $ FEV   : num  1.072 0.839 1.102 1.389 1.577 ...
 $ Ht    : num  46 48 48 48 49 49 50 46.5 49 49 ...
 $ Gender: Factor w/ 2 levels "F","M": 1 1 1 1 1 1 1 1 1 1 ...
 $ Smoke : int  0 0 0 0 0 0 0 0 0 0 ...
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Erzeugen Sie eine neue Variable Körpergröße, welche die Körpergröße in Zentimetern enthält (1 Zoll = 2,54cm)
lc[, Körpergröße := Ht*2.54 ]

 

c) Ändern Sie die Kodierung der Variable Smoke, so dass statt 0 “nein”, und statt 1 “ja” enthalten ist. Passen Sie dabei auch das Skalenniveau an.
# ändere Kodierung von Smoke
lc[, Smoke := ifelse(Smoke == 1, "ja", "nein")]

# passe Skalenniveau an
lc[, Smoke := factor(Smoke)]

Das geht auch in einer Zeile:

# ändere Kodierung und setze Factor in einem Rutsch
lc[, Smoke := factor(ifelse(Smoke == 1, "ja", "nein"))]

 

d) Plotten Sie nebeneinander die Boxplots der Lungenkapazität nichtrauchenden und rauchenden Kindern. Legt das Diagramm einen Zusammenhang nahe?
ggplot(lc, aes(x=Smoke, y=FEV)) +
  geom_boxplot(fill=c("darkgreen", "orchid"))

Es scheint, als ob rauchende Kinder eine größere Lungenkapazität hätten.

 

e) Führen Sie einen Signifikanztest durch, um zu überprüfen, ob sich die Lungenkapazitäten in Abhängigkeit zu Smoke unterscheidet.

Zunächst prüfen wir, ob die Daten in FEV normalverteilt sind.

lc[, .(p = shapiro.test(FEV)$p.value),
   by = Smoke]
    Smoke            p
   <fctr>        <num>
1:   nein 6.711569e-11
2:     ja 1.427488e-01

Der Test ist signifikant, d.h. FEV ist nicht normalverteilt. Wir müssen daher den Mann-Whitney-U-Test verwenden.

lc[, wilcox.test(FEV ~ Smoke, alternative = "greater")$p.value]
[1] 2.035427e-11

Der Test ist signifikant. Die Raucher haben eine größere Lungenkapazität als Nichtraucher.

Das sollte Sie erstmal verwundern!

Raucher haben die besseren Lungen?

 

f) Erzeugen Sie eine Punktwole des Lungenvolumens und des Alters, sowie des Lungenvolumens und der Körpergröße. Legen die Diagramme einen Zusammenhang nahe?
scatter.smooth(lc$Age, lc$FEV, col="skyblue2")
scatter.smooth(lc$Körpergröße, lc$FEV, col="thistle")

Es scheint einen linearen Zusammenhang zwischen dem Alter und der Lungenkapazität sowie zwischen der Körpergröße und der Lungenkapazität zu geben.

 

g) Welches Regressionsmodell ist am besten geeignet, um FEV erklärt durch Alter zu bestimmen, und welches ist am besten geeignet, um FEV erklärt durch Körpergröße zu bestimmen?
# Modelle für FEV~Age
lc[, jgsbook::compare.lm(FEV, Age)]
         Modell  R.square
7        potenz 0.6308534
4  exponentiell 0.5957878
3       kubisch 0.5925193
6     sigmoidal 0.5902058
2   quadratisch 0.5840171
1        linear 0.5722302
5 logarithmisch 0.5701891
# Modelle für FEV~Age
lc[, jgsbook::compare.lm(FEV, Körpergröße)]
         Modell  R.square
4  exponentiell 0.7956073
7        potenz 0.7944652
6     sigmoidal 0.7879391
3       kubisch 0.7741673
2   quadratisch 0.7740993
1        linear 0.7536584
5 logarithmisch 0.7370097

Für FEV erklärt durch Alter ist ein Potenzmodell am besten geeignet. Für FEV erklärt durch Körpergröße ist es ein exponentielles Modell. Dabei ist R2 mit 0,79 größer als beim Potenzmodell des Alters (0,63).

Die Lungenkapazität wird am besten durch die Körpergröße erklärt.

 

h) Berechnen Sie das Modell, welches FEV am besten erklärt.
# bestimme exponentielles Modell
summary(lc[, lm(log(FEV) ~ Körpergröße)])

Call:
lm(formula = log(FEV) ~ Körpergröße)

Residuals:
     Min       1Q   Median       3Q      Max 
-0.70208 -0.08986  0.01190  0.09337  0.43174 

Coefficients:
              Estimate Std. Error t value Pr(>|t|)    
(Intercept) -2.2713118  0.0635310  -35.75   <2e-16 ***
Körpergröße  0.0205193  0.0004073   50.38   <2e-16 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 0.1508 on 652 degrees of freedom
Multiple R-squared:  0.7956,    Adjusted R-squared:  0.7953 
F-statistic:  2538 on 1 and 652 DF,  p-value: < 2.2e-16

 

i) Plotten Sie eine Punktwolke, mit FEV auf der Y-Achse, und dem besten Prädiktor auf der X-Achse. Färben Sie die Daten mittels der Variable Smoke. Fügen Sie anschließend Ihre Modelllinie dem Plot hinzu.

Der beste Prädiktor ist Körpergröße.

# speichere Modellvorhersagen in helper Objekt
helper <- lc[, jgsbook::compare.lm(FEV, Körpergröße, predict=TRUE)]

# plotte
ggplot(lc, aes(x=Körpergröße, y=FEV)) +
  geom_point(aes(color=factor(Smoke))) +
  scale_color_manual(values=c("indianred2", "darkgreen")) +
  geom_line(data=helper, aes(x=pred.x, y=expo), color="blue")

 

j) Fügen Sie Smoke, Age und Gender als weitere Prädiktor dem Modell hinzu. Hat Rauchen einen Einfluss auf FEV?
# exponentielles Modell um "Smoke", "Age" und "Gender" erweitern
fit <- lc[, lm(log(FEV) ~ Körpergröße + Age + Gender + Smoke)]
summary(fit)

Call:
lm(formula = log(FEV) ~ Körpergröße + Age + Gender + Smoke)

Residuals:
     Min       1Q   Median       3Q      Max 
-0.63278 -0.08657  0.01146  0.09540  0.40701 

Coefficients:
             Estimate Std. Error t value Pr(>|t|)    
(Intercept) -1.990066   0.081888 -24.302  < 2e-16 ***
Körpergröße  0.016849   0.000661  25.489  < 2e-16 ***
Age          0.023387   0.003348   6.984  7.1e-12 ***
GenderM      0.029319   0.011719   2.502   0.0126 *  
Smokenein    0.046067   0.020910   2.203   0.0279 *  
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 0.1455 on 649 degrees of freedom
Multiple R-squared:  0.8106,    Adjusted R-squared:  0.8095 
F-statistic: 694.6 on 4 and 649 DF,  p-value: < 2.2e-16

Alle Prädiktoren sind signifikant. Der Beitrag von Smoke ist negativ. Dies spricht dafür, dass Rauchen die Lungenkapazität verschlechtert.

# Modelle vergleichen
fit0 <- lc[, lm(log(FEV) ~ Körpergröße)]
# R^2 vergleichen
summary(fit0)$r.squared - summary(fit)$r.squared 
[1] -0.01503201

Durch Hinzunahme der Prädiktoren verbessert sich R2, aber nur minimal.

zusammengefasst

Es scheint nur auf den ersten Blick so, als hätten rauchende Kinder ein besseres Lungevolumen als nicht-rauchende Kinder. Das liegt daran, dass

  1. das Lungenvolumen maßgeblich von der Körpergröße abhängt, und
  2. die jüngeren Kinder eher nicht rauchen, sonder die älteren. Diese haben dann aber auch einen größeren Körper, und somit auch ein größeres Lungenvolumen als die kleinen Nichtraucher.

 

4.11 Lösung zur Aufgabe 3.11 Charlson-Index

a) Importieren Sie den SAS-Datensatz Krankenhausfaelle.sas in Ihre R-Session und überführen Sie ihn in eine data.table mit dem Namen kh. Machen Sie sich mit dem Datensatz vertraut.
# Lade Daten
tmp <- haven::read_sas("https://www.produnis.de/tabletrainer/data/Krankenhausfaelle.sas")

# überführe in data.table
kh <- as.data.table(tmp)
# anschauen
str(kh)
Classes 'data.table' and 'data.frame':  26561 obs. of  17 variables:
 $ ID            : num  1 2 3 4 5 6 7 8 9 10 ...
 $ Geschlecht    : chr  "m" "m" "m" "m" ...
 $ Alter         : num  54 63 31 55 70 75 68 56 70 50 ...
 $ CHARLSON_SUM_G: num  0 2 2 0 0 0 0 0 2 0 ...
 $ DIED          : num  0 1 0 0 0 0 1 0 1 0 ...
 $ AIDS_HIV      : num  0 0 0 0 0 0 0 0 0 0 ...
 $ RHEUMA        : num  0 0 0 0 0 0 0 0 0 0 ...
 $ LUNG_CHRON    : num  0 0 0 0 0 0 0 0 0 0 ...
 $ Demenz        : num  0 0 0 0 0 0 0 0 0 0 ...
 $ DM_KOMP       : num  0 0 0 0 0 0 0 0 0 0 ...
 $ Herzdekomp    : num  0 1 0 0 0 0 0 0 0 0 ...
 $ Leber_L       : num  0 0 0 0 0 0 0 0 0 0 ...
 $ CARC_MET      : num  0 0 0 0 0 0 0 0 0 0 ...
 $ Leber_MS      : num  0 0 0 0 0 0 0 0 0 0 ...
 $ NEUBILD       : num  0 0 0 0 0 0 0 0 0 0 ...
 $ NIEREN        : num  0 0 0 0 0 0 0 0 0 0 ...
 $ PARA_HEMI     : num  0 0 1 0 0 0 0 0 1 0 ...
 - attr(*, "label")= chr "Written by SAS"
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) Ersetzen Sie die Kodierung der dichotomen Variablen von 0 auf nein und von 1 auf ja. Passen Sie wo nötig das Skalenniveau der Variablen an.
# speichere die Namen der dichotomen Spalten in Hilfsobjekt
spalten <- names(kh)[5:17]
# kodiere dichotome Variablen in "ja/nein" um
kh[, (spalten) := lapply(.SD, \(x) fifelse(x == 1, "ja", "nein")), 
                         .SDcols = spalten]

# Alle außer "Alter" und "CHARLSON_SUM_G" müssen factor sein
spalten <- names(kh)[-c(3:4)]
# wandle in factor um
kh[, (spalten) := lapply(.SD, factor), .SDcols = spalten]

# anzeigen
str(kh)
Classes 'data.table' and 'data.frame':  26561 obs. of  17 variables:
 $ ID            : Factor w/ 26561 levels "1","2","3","4",..: 1 2 3 4 5 6 7 8 9 10 ...
 $ Geschlecht    : Factor w/ 2 levels "m","w": 1 1 1 1 1 1 1 1 1 2 ...
 $ Alter         : num  54 63 31 55 70 75 68 56 70 50 ...
 $ CHARLSON_SUM_G: num  0 2 2 0 0 0 0 0 2 0 ...
 $ DIED          : Factor w/ 2 levels "ja","nein": 2 1 2 2 2 2 1 2 1 2 ...
 $ AIDS_HIV      : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ RHEUMA        : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ LUNG_CHRON    : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ Demenz        : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ DM_KOMP       : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ Herzdekomp    : Factor w/ 2 levels "ja","nein": 2 1 2 2 2 2 2 2 2 2 ...
 $ Leber_L       : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ CARC_MET      : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ Leber_MS      : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ NEUBILD       : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ NIEREN        : Factor w/ 2 levels "ja","nein": 2 2 2 2 2 2 2 2 2 2 ...
 $ PARA_HEMI     : Factor w/ 2 levels "ja","nein": 2 2 1 2 2 2 2 2 1 2 ...
 - attr(*, "label")= chr "Written by SAS"
 - attr(*, ".internal.selfref")=<externalptr> 

 

c) Klassieren Sie das Alter der Probanden und plotten Sie die relativen Häufigkeiten

Zunächst klassieren wir die Werte.

# klassieren
kh[, AlterK := cut(Alter, 
                   breaks=c(seq(0, 90, 10), Inf), 
                   ordered_result=TRUE,
                   right=FALSE)]

Jetzt können wir mittels geom_bar() oder geom_histogram() die Diagramme erzeugen.

# bereite Basisplot vor
p <- ggplot(kh) +
      xlab("Altersklassen") + 
      ylab("relative Häufigkeiten") +
      scale_y_continuous(labels = scales::percent)

# plotten mit geom_bar
p + geom_bar(aes(x=AlterK, 
                 y=..prop.., group=1),
             color="black", fill="tan3")
# plotten mit geom_histogram
# benötigt die unklassierten Daten (Alter statt AlterK)
p + geom_histogram(aes(x=Alter,
                       y=..count../sum(..count..)),
                   breaks=c(seq(0, 90, 10), max(kh$Alter, na.rm=TRUE)+1), 
                   closed="left",
                   color="white", fill="tan1")

 

d) Klassieren Sie den Charlson-Index
kh[, CharlsonK := cut(CHARLSON_SUM_G, 
                      breaks=c(0, 1, 3, Inf), 
                      ordered_result=TRUE,
                      right=FALSE)]

 

e) Welche Nebendiagnose kommt am häufigsten vor?

Hierzu überführen wir die data.table ins long table Format, mit der neuen Variable Nebendiagnose, welche die konkreten Diagnosen enthält. Dazu bietet es sich an, die Spaltennamen, welche die Nebendiagnosen beinhalten, zunächst als eigenes Objekt abzuspeichern, um dann mittels melt() darauf zuzugreifen.

# Die Spalten 6-17 enthalten Nebendiagnosen
spalten <- names(kh)[6:17]

# überführe ins tidy long table format
melt(kh,
     id.vars ="ID",
     measure.vars = spalten,
     variable.name = "Nebendiagnose",
     value.name = "Wert"
    ) |>
  # nimm nur solche, die "ja" haben
  _[Wert == "ja"] |>
  # zähle N der Nebendiagnosen
  _[, .N, by=Nebendiagnose] |>
  # sortiere absteigend
  _[order(N, decreasing = TRUE)]
    Nebendiagnose     N
           <fctr> <int>
 1:        NIEREN  2304
 2:    LUNG_CHRON  2096
 3:    Herzdekomp  1944
 4:      CARC_MET  1555
 5:     PARA_HEMI  1357
 6:        Demenz   598
 7:       NEUBILD   580
 8:       Leber_L   345
 9:       DM_KOMP    86
10:        RHEUMA    80
11:      Leber_MS    27
12:      AIDS_HIV    22

Nierenerkrankungen kommen am häufigsten vor.

 

f) Wieviele Patienten ohne Nebendiagnosen sind enthalten?

Es sind 12 Nebendiagnosen im Datensatz enthalten. Wenn der Datensatz wieder als long table vorliegt, können wir für jede ID zählen, wie oft Wert = "nein" ist. Bei 12 nein liegen demnach keine Nebendiagnosen vor.

# Welche Spalten enthalten Nebendiagnosen
spalten <- names(kh)[6:17]

# überführe ins tidy long table format
melt(kh,
     id.vars ="ID",
     measure.vars = spalten,
     variable.name = "Nebendiagnose",
     value.name = "Wert"
    ) |>
  # zähle für jede "ID" wie oft "nein" vorkommt
  _[, .(nein=sum(Wert=="nein")) , by=ID] |>
  # wer hat 12x nein?
  _[nein==12] |>
  # Anzahl anzeigen
  nrow()
[1] 17916

17916 Patienten haben keine Nebendiagnose.

 

g) Erzeugen Sie eine neue Spalte "KEINE" in der data.table, die in jeder Reihe den Wert "nein" hat. Überschreiben Sie diesen Wert für solche Patienten, die keine Nebendiagnosen haben, mit dem Wert "ja".
# schreibe neue Spalte "KEINE" mit Wert "nein"
kh[, KEINE := "nein"]

# Welche Spalten enthalten Nebendiagnosen
spalten <- names(kh)[6:17]

# Überführe in long table
help <- melt(kh,
             id.vars = "ID",
             measure.vars = spalten,
             variable.name = "Nebendiagnose",
             value.name = "Wert"
            ) |>
      # zähle für jede "ID" wie oft "nein" vorkommt
      _[, .(nein=sum(Wert=="nein")) , by=ID] |>
      # wer hat 12x nein?
      _[nein==12]

# überschreibe "KEINE" in passenden Zeilen mit "ja"
kh[ID %in% help$ID, KEINE := "ja"]

 

h) Erstellen Sie eine Kreuztabelle der Nebendiagnosen und der Variable DIED in Prozentzahlen.

Beginnen wir mit der Tabelle bezogen auf das Gesamt-N. Hierzu überführen wir wie oben unter e) die data.table ins long table Format, mit der neuen Variable Nebendiagnose, welche die konkreten Diagnosen enthält. Wie oben erzeugen wir dafür ein Objekt spalten, welches die Spaltennamen der Nebendiagnosen (inklusive "KEINE") enthält.

Da wir das long table Objekt mehrfach gebrauchen können, speichern wir es als helper ab.

# welche Spalten enthalten Nebendiagnosen?
spalten <- c(names(kh)[6:17], "KEINE")
# überführe ins tidy long table format
# und speichere als hilfsobjekt
helper <- melt(kh,
               id.vars = c("ID", "DIED"), 
               measure.vars = spalten,
               variable.name = "Nebendiagnose",
               value.name = "Wert"
               ) |>
  # nimm nur solche, die "ja" haben
  _[Wert == "ja"]

# erzeuge prop.table() in "echten" Prozent
helper[, round(prop.table(table(Nebendiagnose, DIED))*100, 2)]
             DIED
Nebendiagnose    ja  nein
   AIDS_HIV    0.00  0.07
   RHEUMA      0.01  0.27
   LUNG_CHRON  0.34  6.91
   Demenz      0.17  1.90
   DM_KOMP     0.01  0.29
   Herzdekomp  0.45  6.28
   Leber_L     0.08  1.11
   CARC_MET    0.53  4.85
   Leber_MS    0.02  0.07
   NEUBILD     0.15  1.85
   NIEREN      0.40  7.57
   PARA_HEMI   0.30  4.39
   KEINE       0.97 61.00

Soll die Tabelle zB nach “verstorben: ja” sortiert werden, müssen wir die Tabelle in ein data.table Objekt umwandeln und dann sortieren. Auf diese Weise kann auch das N der Nebendiagnosen an die Tabelle angefügt werden. Die Berechnung von N der Nebendiagnosen findet in einem gesonderten Objekt khN statt, welches dann eingebunden werden kann.

# berechne N für jede Nebendiagnose
khN <- helper[, .N, by = Nebendiagnose]

# erzeuge prop.table() in "echten" Prozent
helper[, round(prop.table(table(Nebendiagnose, DIED))*100, 2)] |>
  # table in data.table umwandeln
  as.data.table() |>
  # erzeuge breite Tabelle
  dcast(Nebendiagnose ~ DIED, value.var = "N") |>
  # füge N der Nebendiagnosen hinzu
  _[khN, on = .(Nebendiagnose)] [] |>
  # sortiere nach "verstorben: ja"
  _[order(ja, decreasing = TRUE)]
    Nebendiagnose    ja  nein     N
           <char> <num> <num> <int>
 1:         KEINE  0.97 61.00 17916
 2:      CARC_MET  0.53  4.85  1555
 3:    Herzdekomp  0.45  6.28  1944
 4:        NIEREN  0.40  7.57  2304
 5:    LUNG_CHRON  0.34  6.91  2096
 6:     PARA_HEMI  0.30  4.39  1357
 7:        Demenz  0.17  1.90   598
 8:       NEUBILD  0.15  1.85   580
 9:       Leber_L  0.08  1.11   345
10:      Leber_MS  0.02  0.07    27
11:        RHEUMA  0.01  0.27    80
12:       DM_KOMP  0.01  0.29    86
13:      AIDS_HIV  0.00  0.07    22

Für die zweite Tabelle gehen wir ähnlich vor. Mittels melt() erzeugen wir eine long list der Nebendiagnosen (diese liegt bereits als helper vor). Mit dieser können wir prop.table() pro Nebendiagsnose aufrufen. Das Ergebnis kann dann mittels dcast() zurück in eine breite Tabelle überführt werden. Damit wir nach “verstorben: ja” sortieren können, wandeln wir die Werte in numeric um. Auch hier können wir auf das Objekt khN zurückgreifen, um das N der Nebendiagnose einzufügen.

# erzeuge prop.table() in "echten" Prozent für Jede Nebendiagnose
helper[, round(prop.table(table(DIED))*100, 2), by = Nebendiagnose] |>
  # füge Hilfsvariable "verstorben" ein
  _[, verstorben := rep(c("ja", "nein"), length.out = .N)] |>
  # überführe zurück in "breite" Tabelle
  dcast(Nebendiagnose ~ verstorben, value.var = "V1") |>
  # wandle in numeric um, damit sortiert werden kann
  _[, let(ja = as.numeric(ja),
          nein = as.numeric(nein),
          # N der Nebendiagnosen einfügen
          N = khN$N)] |>
  # sortiere nach "verstorben: ja"
  _[order(ja, decreasing = TRUE)]
    Nebendiagnose    ja  nein     N
           <fctr> <num> <num> <int>
 1:      Leber_MS 25.93 74.07    27
 2:      CARC_MET  9.84 90.16  1555
 3:        Demenz  8.36 91.64   598
 4:       NEUBILD  7.59 92.41   580
 5:       Leber_L  6.67 93.33   345
 6:    Herzdekomp  6.64 93.36  1944
 7:     PARA_HEMI  6.48 93.52  1357
 8:        NIEREN  4.99 95.01  2304
 9:    LUNG_CHRON  4.72 95.28  2096
10:      AIDS_HIV  4.55 95.45    22
11:        RHEUMA  2.50 97.50    80
12:       DM_KOMP  2.33 97.67    86
13:         KEINE  1.57 98.43 17916

 

4.12 Lösung zur Aufgabe 3.12 Neugeborene: Gewicht

a) Laden Sie den SPSS-Datensatz Neugeborene.sav in Ihre R-Session und überführen Sie ihn in eine data.table mit dem Namen ng2.
# Lade Daten
tmp <- haven::read_sav("https://www.produnis.de/tabletrainer/data/Neugeborene.sav")

# überführe in data.table
ng2 <- as.data.table(tmp)
# anschauen
str(ng2)
Classes 'data.table' and 'data.frame':  120 obs. of  16 variables:
 $ ID     : num  1188 1253 1166 1236 1237 ...
  ..- attr(*, "label")= chr "ID"
  ..- attr(*, "format.spss")= chr "F4.0"
 $ SEX    : num  2 2 1 1 2 2 1 2 1 2 ...
  ..- attr(*, "label")= chr "Geschlecht des Kindes"
  ..- attr(*, "format.spss")= chr "F1.0"
 $ GEBGEWI: num  3985 3230 3000 99 4155 ...
  ..- attr(*, "label")= chr "Geburtsgewicht [g]"
  ..- attr(*, "format.spss")= chr "F4.0"
 $ GEBGROE: num  53 50 50 51 54 49 49 48 50 51 ...
  ..- attr(*, "label")= chr "Größe bei Geburt [cm]"
  ..- attr(*, "format.spss")= chr "F2.0"
 $ ALTVAT : num  42 38 28 25 32 34 26 22 20 20 ...
  ..- attr(*, "label")= chr "Alter des Vaters [Jahre]"
  ..- attr(*, "format.spss")= chr "F2.0"
 $ ALTMUTT: num  39 35 27 20 28 31 36 28 20 18 ...
  ..- attr(*, "label")= chr "Alter der Mutter [Jahre]"
  ..- attr(*, "format.spss")= chr "F2.0"
 $ NATMUT : chr  "D" "D" "HR" "TR" ...
  ..- attr(*, "label")= chr "Nationalität der Mutter [Nationalitätskennzeichen]"
  ..- attr(*, "format.spss")= chr "A9"
  ..- attr(*, "display_width")= int 7
 $ VATGROE: num  180 174 180 161 157 167 178 178 175 9 ...
  ..- attr(*, "label")= chr "Größe des Vaters [cm]"
  ..- attr(*, "format.spss")= chr "F3.0"
 $ VATGEW : num  95 70 100 65 65 70 65 106 55 9 ...
  ..- attr(*, "label")= chr "Gewicht des Vaters [kg]"
  ..- attr(*, "format.spss")= chr "F3.0"
 $ FUGEW  : num  4700 4530 4620 5000 5000 3800 4550 3200 5000 4100 ...
  ..- attr(*, "label")= chr "Gewicht im Alter von 6 Wochen [g]"
  ..- attr(*, "format.spss")= chr "F4.0"
 $ FUGROE : num  53 56 56 57 56 51 54 50 56 57 ...
  ..- attr(*, "label")= chr "Größe im Alter von 6 Wochen [cm]"
  ..- attr(*, "format.spss")= chr "F2.0"
 $ JSTILL : dbl+lbl [1:120]  1,  1,  1,  1,  2,  1,  2,  1,  1,  2,  1,  1,  1,  1...
   ..@ label      : chr "Jemals gestillt [Ja/Nein]"
   ..@ format.spss: chr "F1.0"
   ..@ labels     : Named num  1 2
   .. ..- attr(*, "names")= chr [1:2] "ja" "nein"
 $ MUTGEW : num  61 70 61 41 52 57 46 48 44 50 ...
  ..- attr(*, "label")= chr "Gewicht der Mutter vor Schwangerschaft [kg]"
  ..- attr(*, "format.spss")= chr "F6.2"
 $ SCHDAUW: num  39 40 38 39 40 38 36 39 38 40 ...
  ..- attr(*, "label")= chr "Schwangerschaftsdauer [ganze Wochen]"
  ..- attr(*, "format.spss")= chr "F2.0"
 $ SCHDAUT: num  NA 1 2 1 2 3 NA NA 3 1 ...
  ..- attr(*, "label")= chr "Schwangerschaftsdauer [zusätzliche Tage]"
  ..- attr(*, "format.spss")= chr "F1.0"
 $ MUTGROE: num  9 9 9 150 150 150 152 152 154 155 ...
  ..- attr(*, "label")= chr "Größe der Mutter [cm]"
  ..- attr(*, "format.spss")= chr "F3.0"
 - attr(*, ".internal.selfref")=<externalptr> 

 

b) In einigen Variablen finden Sie die Merkmalsausprägungen 9, 99 oder 999. Diese stehen für fehlende Werte und müssen in NA umgewandelt werden.
ng2[, (names(ng2)) := lapply(.SD, \(x) 
                             fifelse(x %in% c(9, 99, 999), NA, x))]

 

c) Wandeln Sie die Variable SEX in einen Factor mit den Levels “männlich” (statt 1) und “weiblich” (statt 2) um.
ng2[, SEX := fifelse(SEX == 1, "männlich", "weiblich")]

 

d) Bilden Sie aus der Variable Geburtsgewicht (GEBGEWI) eine neue Variable (GEWIKAT), welche das Geburtsgewicht den folgenden Kategorien zuordnet.
ng2[, GEWIKAT := cut(GEBGEWI, 
                     breaks=c(0, 2500, 3000, 3500, 4000, Inf),
                     right=TRUE,
                     ordered_result = TRUE)]

 

e) Berechnen Sie zur Variablen Geburtsgewicht die Stichprobenmerkmale getrennt für Jungen und Mädchen.
# alle Kennwerte liefert psych::describe()
ng2[, psych::describe(GEBGEWI, quant=c(0.05, 0.25, 0.75, 0.95), 
                      IQR=TRUE, check=F, skew=F) ,
    by = SEX]
        SEX  vars     n     mean       sd median   min   max range       se
     <char> <num> <num>    <num>    <num>  <num> <num> <num> <num>    <num>
1: weiblich     1    55 3359.855 437.5192   3340  2500  4195  1695 58.99507
2: männlich     1    57 3453.596 442.9999   3405  2500  4210  1710 58.67677
     IQR Q0.05 Q0.25 Q0.75 Q0.95
   <num> <num> <num> <num> <num>
1:   595  2652  3065  3660  4120
2:   670  2798  3140  3810  4158

 

f) Erstellen Sie Boxplots des Geburtsgewichts für alle Kinder, sowie separat für Jungen und Mädchen.
# Boxplot insgesamt
ggplot(ng2, aes(y=GEBGEWI)) +
  geom_boxplot(fill="thistle") +
  ylab("Geburtsgewicht")
# plotte nach Geschlecht getrennt
ggplot(ng2, aes(y=GEBGEWI, fill=SEX)) +
  geom_boxplot() +
  ylab("Geburtsgewicht")

 

g) Erstellen Sie zur Variable GEWIKAT je eine Häufigkeitstabelle und ein Säulendiagramm der relativen Häufigkeiten für a) die gesamte Stichprobe und b) unter Berücksichtigung des 2. Merkmals SEX
# Häufigkeitstabelle insgesamt
ng2[, jgsbook::freqTable(GEWIKAT)]
             Wert Haeufig Hkum Relativ  Rkum
1     (0,2.5e+03]       2    2    1.67  1.67
2 (2.5e+03,3e+03]      18   20   15.00 16.67
3 (3e+03,3.5e+03]      47   67   39.17 55.84
4 (3.5e+03,4e+03]      33  100   27.50 83.34
5     (4e+03,Inf]      12  112   10.00 93.34
# Säulendiagramm insgesamt
ng2[, jgsbook::freqTable(GEWIKAT)] |>
  ggplot(aes(x=Wert, y=Relativ)) +
  geom_bar(stat="identity", fill="maroon3") +
  ylab("relative Häufigkeit")

# Häufigkeitstabelle Mädchen
ng2[SEX=="weiblich", jgsbook::freqTable(GEWIKAT)]
             Wert Haeufig Hkum Relativ  Rkum
1     (0,2.5e+03]       1    1    1.67  1.67
2 (2.5e+03,3e+03]      11   12   18.33 20.00
3 (3e+03,3.5e+03]      23   35   38.33 58.33
4 (3.5e+03,4e+03]      16   51   26.67 85.00
5     (4e+03,Inf]       4   55    6.67 91.67
# Häufigkeitstabelle Jungen
ng2[SEX=="männlich", jgsbook::freqTable(GEWIKAT)]
             Wert Haeufig Hkum Relativ  Rkum
1     (0,2.5e+03]       1    1    1.67  1.67
2 (2.5e+03,3e+03]       7    8   11.67 13.34
3 (3e+03,3.5e+03]      24   32   40.00 53.34
4 (3.5e+03,4e+03]      17   49   28.33 81.67
5     (4e+03,Inf]       8   57   13.33 95.00
# ggplot nach Geschlecht
ggplot(ng2, aes(x=GEWIKAT, y=after_stat(prop), 
                group=SEX, fill=SEX)) +
  geom_bar(position="dodge")+
  ylab("relative Häufigkeiten") +
  scale_y_continuous(labels = scales::percent)

 

h) Analysieren Sie den (linearen) Zusammenhang zwischen dem Geburtsgewicht [GEBGEWI] und der Körpergröße bei Geburt [GEBGROE].
ng2[, cor(GEBGEWI, GEBGROE, use="complete.obs")]
[1] 0.788054

 

i) Einfluss des BMI
#  Vater und Mutter BMI
ng2[, let(VATBMI = VATGEW / (VATGROE/100)^2,
          MUTBMI = MUTGEW / (MUTGROE/100)^2
          )]

# Zusammenhang BMI prüfen
ng2[, cor(MUTBMI, VATBMI, use="complete.obs")]
[1] 0.2567427

Es gibt einen schwachen positiven Zusammenhang.

# MUTBMI auf GEBGEWI
ng2[, cor(MUTBMI, GEBGEWI, use="complete.obs")]
[1] 0.2672135

Der Zusammenhang ist ebenso gering.

 

j) Bilden Sie aus der Variable Gewicht im Alter von 6 Wochen [FUGEW] und Größe im Alter von 6 Wochen [FUGROE] die Variable Ponderal Index im Alter von 6 Wochen. Für Säuglinge lautet die Formel \(PI = 100 \cdot \frac{g}{cm^3}\).
ng2[, PI := 100* (FUGEW / FUGROE^3)]

 

k) Bilden Sie eine neue Variable: Gewichtszunahme des Kindes von Geburt bis zum Alter von 6 Wochen.
ng2[, GEWZUN6 := FUGEW-GEBGEWI]

 

l) Bilden Sie eine neue Variable: Gewichtszunahme von Geburt bis zum Alter von 6 Wochen in % vom Geburtsgewicht.
ng2[, GEWZUN6P := (100*FUGEW/GEBGEWI) - 100]

 

m) Wie viele Kinder wurden gestillt ([JSTILL], (1,2))? Kodieren Sie zuvor die Variable um, so dass 1=ja und 2=nein wird.
ng2[, JSTILL := fifelse(JSTILL==1, "ja", "nein")]
ng2[, table(JSTILL)]
JSTILL
  ja nein 
 108    8 

 

n) Vergleichen Sie die gestillten und die nicht gestillten Kinder

Vergleichen wir zunächst die Kennwerte.

ng2[!is.na(JSTILL),
    .(Gew6_mean = round(mean(FUGEW, na.rm = TRUE), 2),
      Gew6_sd = round(sd(FUGEW, na.rm = TRUE), 2),
      Gew6Zu_mean = round(mean(GEWZUN6, na.rm = TRUE), 2),
      Gew6Zu_sd = round(sd(GEWZUN6, na.rm = TRUE), 2),
      Gew6ZuP_mean = round(mean(GEWZUN6P, na.rm = TRUE), 2),
      Gew6ZuP_sd = round(sd(GEWZUN6P, na.rm = TRUE), 2),
      PI_mean = round(mean(PI, na.rm = TRUE), 2),
      PI_sd = round(sd(PI, na.rm = TRUE), 2)
     ), by = JSTILL]
   JSTILL Gew6_mean Gew6_sd Gew6Zu_mean Gew6Zu_sd Gew6ZuP_mean Gew6ZuP_sd
   <char>     <num>   <num>       <num>     <num>        <num>      <num>
1:     ja   4555.33  688.63     1144.22    509.12        33.85      14.77
2:   nein   4367.50  340.62      970.00    491.93        30.05      18.79
   PI_mean PI_sd
     <num> <num>
1:    2.67  0.38
2:    2.62  0.26

Prüfen wir auf Signifikanz.

# welche Variablen sollen getestet werden?
spalten <- c("FUGEW", "GEWZUN6", "GEWZUN6P", "PI")

# Signifikanztests
ng2[, lapply(.SD, function(x) wilcox.test(x ~ JSTILL)$p.value), 
             .SDcols = spalten]
       FUGEW   GEWZUN6  GEWZUN6P        PI
       <num>     <num>     <num>     <num>
1: 0.3256774 0.3432153 0.3400299 0.7913213

Alle Tests sind nicht signifikant. Es gibt keinen Unterschied zwischen gestillten und nicht-gestillten Kindern.

 

o) Bilden Sie eine neue Variable Schwangerschaftsdauer [SCHDAUG] in Gesamttagen, die Sie aus den Variablen Schwangerschaftsdauer in (ganzen) Wochen (SCHDAUW) und Schwangerschaftsrestdauer in Tagen (SCHDAUT) bilden. Hat die Schwangerschaftsdauer einen Einfluss auf das Geburtsgewicht?
ng2[, SCHDAUG := 7*SCHDAUW + SCHDAUT]

# Korrelation
ng2[, cor(SCHDAUG, GEBGEWI, use = "complete.obs")]
[1] 0.4188753

Es gibt einen moderaten Zusammenhang zwischen Schwangerschaftsdauer und Geburtsgewicht.

 

p) Bilden Sie aus der Variable Nationalität der Mutter [NATMUT] eine neue Variable, welche die Nationalität der Mutter in 3 Kategorien zusammenfasst: deutsch (NATMUT=D), türkisch (NATMUT=TR) und sonstige (alle anderen, auch die ohne Angabe).
ng2[, NATMUTK := factor(fifelse(NATMUT == "D", "deutsch",
                        fifelse(NATMUT == "TR", "türkisch",
                                         "sonstige")))]

 

q) Unterscheiden sich die Kinder von Müttern der verschiedenen Nationalitäten hinsichtlich ihres Geburtsgewichts und ihres Ponderal Index im Alter von 6 Wochen?
tuerk <- ng2[NATMUTK=="türkisch"]
deuts <- ng2[NATMUTK=="deutsch"]
sonst <- ng2[NATMUTK=="sonstige"]

wilcox.test(tuerk$GEBGEWI, deuts$GEBGEWI)$p.value
[1] 0.8142958
wilcox.test(tuerk$GEBGEWI, sonst$GEBGEWI)$p.value
[1] 0.7543701
wilcox.test(deuts$GEBGEWI, sonst$GEBGEWI)$p.value
[1] 0.4108474

 

r) Werden die Kinder von Müttern unterschiedlicher Nationalitäten gleich häufig gestillt?
ng2[, xtabs(~ NATMUTK+JSTILL)]
          JSTILL
NATMUTK    ja nein
  deutsch  88    5
  sonstige 12    1
  türkisch  8    2
# Chiquadrat-Test
ng2[, chisq.test(NATMUTK, JSTILL)]

    Pearson's Chi-squared test

data:  NATMUTK and JSTILL
X-squared = 3.0216, df = 2, p-value = 0.2207
# exakter Fisher-Test
ng2[, fisher.test(NATMUTK, JSTILL)]

    Fisher's Exact Test for Count Data

data:  NATMUTK and JSTILL
p-value = 0.1294
alternative hypothesis: two.sided

Kinder unterschiedlicher Nationalitäten werden gleich häufig gestillt.

 

s) Vergleichen Sie das mittlere Geburtsgewicht mit der Referenz 3500g (t-Test für eine Stichprobe).
# t-Test
ng2[, t.test(GEBGEWI, mu=3500)]

    One Sample t-test

data:  GEBGEWI
t = -2.219, df = 111, p-value = 0.02852
alternative hypothesis: true mean is not equal to 3500
95 percent confidence interval:
 3325.017 3490.108
sample estimates:
mean of x 
 3407.562 

Das Ergebnis ist signifikant. Das Geburtsgewicht in der Stichprobe weicht vom Referenzwert ab.

 

Vergleichen Sie das mittlere Geburtsgewicht von männlichen und weiblichen Neugeborenen (t-Test für zwei Stichprobe).
# t-Test
ng2[, t.test(GEBGEWI ~ SEX) ]

    Welch Two Sample t-test

data:  GEBGEWI by SEX
t = 1.1266, df = 109.94, p-value = 0.2624
alternative hypothesis: true difference in means between group männlich and group weiblich is not equal to 0
95 percent confidence interval:
 -71.15554 258.63943
sample estimates:
mean in group männlich mean in group weiblich 
              3453.596               3359.855 

Das Ergebnis ist nicht signifikant. Das Geburtsgewicht von Jungen und Mädchen unterscheidet sich nicht.