Homework Questions
Question 1
- Calculate a total score for each person as the sum of their responses (i.e., number of correctly identified songs for each person).
# Creating vector
totscores <- vector(length = 46)
# Populating vector w/ total scores
(totscores <- rowSums(d))
## [1] 5 2 7 2 3 4 8 0 2 7 2 11 6 2 1 9 7 1 12 10 8 13 10 9 4
## [26] 1 10 2 2 1 3 6 10 4 5 0 2 4 5 7 7 3 4 3 10 12
Question 2
- Calculate summary statistics of the total scores (minimum, maximum, mean, and standard deviation) and create a histogram showing the distribution of total scores. What can you conclude about the level of 80’s music fluency among this sample?
# summary stats
psych::describe(totscores, skew = F)
## vars n mean sd min max range se
## X1 1 46 5.35 3.64 0 13 13 0.54
# histogram
hist(totscores,
main = "Histogram of Total Scores",
xlab = "Total Scores",
breaks = seq(0,14,1))
| Answer: |
| In general, participants in this sample showed middling to low levels of 80’s music fluency. The average student was able to identify fewer than 6 of the songs, and no student was able to identify all 14 songs (i.e., the max was 13). The histogram also reveals a positive skew, with frequency tapering off as total score increases. |
Question 3
- Use Cronbach’s alpha to estimate the internal consistency reliability of the total scores. (Please show or explain how you calculated your estimate.) What is the estimated reliability of the total scores and how should it be interpreted? How would you interpret the estimate for the 80’s test?
psych::alpha(d)[1]
## Some items ( LL ) were negatively correlated with the total scale and
## probably should be reversed.
## To do this, run the function again with the 'check.keys=TRUE' option
## $total
## raw_alpha std.alpha G6(smc) average_r S/N ase mean
## 0.8286037 0.813684 0.8863933 0.2254957 4.367227 0.03451915 0.3565217
## sd median_r
## 0.2427079 0.2166631
# The alpha() command comes from the psych package; it reports both Cronbach's alpha and Guttman's lambda 6. The figure under "raw_alpha" gives the alpha based on covariances, while "std.alpha" gives the standardized alpha based on correlations.
| Answer: |
| The estimated reliability of the total scores is .83; this suggests that about 17% of the variance in the total scores is due to random error, with the remaining 83% attributable to true differences between respondents. The total score estimate for this 80’s music test meets acceptable reliability, based on this calculation. |
Question 4
- What is the standard error of measurement (SEM) for total scores on the 80’s music test? How should it be interpreted?
(sem.totscores <- sqrt(var(totscores) * (1 - 0.8286037)))
## [1] 1.507218
| Answer: |
| The standard error of measurement for total scores was 1.51; this suggests that, if a respondent were to take this test again, we should expect their score to differ by +/- 1.51 points about 68% of the time (given normally distributed measurement error). |
Question 5
- Create a table that shows the mean (sometimes called the “difficulty”) and the item-total correlation (sometimes called the “discrimination”) for each of the 15 test items. Which songs were the hardest for people to identify? Which songs were the easiest to identify? Which songs stood out as the most/least discriminating? How can you tell?
ctt.table <- as.data.frame(get_ctt_stats_func(d)[2])
ctt.table <- cbind(c(1:15), ctt.table)
ctt.table <- ctt.table[,-4]
ctt.table$song <- c(colnames(d[1:15]))
names(ctt.table) <- c("ItemNumber", "ItemMean","Corrected_ItemTotal","Artist Name")
kable(ctt.table)
| 1 |
0.1086957 |
-0.0811133 |
LL |
| 2 |
0.6086957 |
0.2360388 |
GNR |
| 3 |
0.1304348 |
0.2904197 |
GM_Flash |
| 4 |
0.3478261 |
0.6866643 |
Go_Gos |
| 5 |
0.3913043 |
0.6372413 |
Human_League |
| 6 |
0.6304348 |
0.5169772 |
The_Police |
| 7 |
0.1086957 |
0.1340250 |
New_Order |
| 8 |
0.5652174 |
0.3573056 |
Rob_Base |
| 9 |
0.4565217 |
0.7817399 |
INXS |
| 10 |
0.2391304 |
0.5445872 |
REO |
| 11 |
0.6521739 |
0.5081173 |
J_Cougar |
| 12 |
0.3478261 |
0.5803042 |
Flock |
| 13 |
0.2173913 |
0.5610563 |
TTD |
| 14 |
0.2608696 |
0.6277446 |
Wham |
| 15 |
0.2826087 |
0.1818621 |
Marley |
d$ID <- as.factor(c(1:46))
d$totscores <- rowSums(d[,c(1:15)])
dlong <- d %>%
pivot_longer(cols = -c("ID","totscores"), names_to = "song")
## Identification
# Most difficult songs
ctt.table[order(ctt.table$ItemMean),]
## ItemNumber ItemMean Corrected_ItemTotal Artist Name
## 1 1 0.1086957 -0.08111331 LL
## 7 7 0.1086957 0.13402499 New_Order
## 3 3 0.1304348 0.29041971 GM_Flash
## 13 13 0.2173913 0.56105628 TTD
## 10 10 0.2391304 0.54458721 REO
## 14 14 0.2608696 0.62774456 Wham
## 15 15 0.2826087 0.18186207 Marley
## 4 4 0.3478261 0.68666430 Go_Gos
## 12 12 0.3478261 0.58030422 Flock
## 5 5 0.3913043 0.63724130 Human_League
## 9 9 0.4565217 0.78173995 INXS
## 8 8 0.5652174 0.35730563 Rob_Base
## 2 2 0.6086957 0.23603876 GNR
## 6 6 0.6304348 0.51697724 The_Police
## 11 11 0.6521739 0.50811734 J_Cougar
# Easiest songs
ctt.table[order(-ctt.table$ItemMean),]
## ItemNumber ItemMean Corrected_ItemTotal Artist Name
## 11 11 0.6521739 0.50811734 J_Cougar
## 6 6 0.6304348 0.51697724 The_Police
## 2 2 0.6086957 0.23603876 GNR
## 8 8 0.5652174 0.35730563 Rob_Base
## 9 9 0.4565217 0.78173995 INXS
## 5 5 0.3913043 0.63724130 Human_League
## 4 4 0.3478261 0.68666430 Go_Gos
## 12 12 0.3478261 0.58030422 Flock
## 15 15 0.2826087 0.18186207 Marley
## 14 14 0.2608696 0.62774456 Wham
## 10 10 0.2391304 0.54458721 REO
## 13 13 0.2173913 0.56105628 TTD
## 3 3 0.1304348 0.29041971 GM_Flash
## 1 1 0.1086957 -0.08111331 LL
## 7 7 0.1086957 0.13402499 New_Order
## Discrimination
# Most discriminating
ctt.table[order(ctt.table$Corrected_ItemTotal),]
## ItemNumber ItemMean Corrected_ItemTotal Artist Name
## 1 1 0.1086957 -0.08111331 LL
## 7 7 0.1086957 0.13402499 New_Order
## 15 15 0.2826087 0.18186207 Marley
## 2 2 0.6086957 0.23603876 GNR
## 3 3 0.1304348 0.29041971 GM_Flash
## 8 8 0.5652174 0.35730563 Rob_Base
## 11 11 0.6521739 0.50811734 J_Cougar
## 6 6 0.6304348 0.51697724 The_Police
## 10 10 0.2391304 0.54458721 REO
## 13 13 0.2173913 0.56105628 TTD
## 12 12 0.3478261 0.58030422 Flock
## 14 14 0.2608696 0.62774456 Wham
## 5 5 0.3913043 0.63724130 Human_League
## 4 4 0.3478261 0.68666430 Go_Gos
## 9 9 0.4565217 0.78173995 INXS
# Least discriminating
ctt.table[order(-ctt.table$Corrected_ItemTotal),]
## ItemNumber ItemMean Corrected_ItemTotal Artist Name
## 9 9 0.4565217 0.78173995 INXS
## 4 4 0.3478261 0.68666430 Go_Gos
## 5 5 0.3913043 0.63724130 Human_League
## 14 14 0.2608696 0.62774456 Wham
## 12 12 0.3478261 0.58030422 Flock
## 13 13 0.2173913 0.56105628 TTD
## 10 10 0.2391304 0.54458721 REO
## 6 6 0.6304348 0.51697724 The_Police
## 11 11 0.6521739 0.50811734 J_Cougar
## 8 8 0.5652174 0.35730563 Rob_Base
## 3 3 0.1304348 0.29041971 GM_Flash
## 2 2 0.6086957 0.23603876 GNR
## 15 15 0.2826087 0.18186207 Marley
## 7 7 0.1086957 0.13402499 New_Order
## 1 1 0.1086957 -0.08111331 LL
| Answer: |
| Songs 2, 6, and 11 (Guns N’ Roses, The Police, and John Cougar) were the easiest songs for respondents to identify, with more than 60% (and up to 65%) of the sample able to identify them. Songs 1, 3, and 7 (LL Cool J, Grandmaster Flash, and New Order) were the hardest for respondents to identify, with less than 15% (and as little as 11%) able to identify them. The most discriminating items appear to be songs 9, 4, and 5 (INXS, the Go Gos, and the Human League), whereas items 1, 7, and 15 (LL Cool J, New Order, and Bob Marley) are the least discriminating. |
| Item 1 looks to have a (very slightly) negative discrimination score, meaning that there is a (very slight) negative correlation between this item and the other items in this dataset, in terms of respondents’ scores. |
Question 6
- OPTIONAL: Compute, for each test-taker, an estimate of their “true score” using Kelley’s equation. Compare the distribution of Kelley true score estimates to the distribution of observed total scores. What do you notice?
True Score = (reliability * observed score) + [(1 - reliability) * mean score]
kelleyTS <- function(r, x, m) {
term1 <- r*x
term2 <- (1-r) * m
TS <- term1 + term2
return(TS)
}
truescores <- vector(length = 46)
x <- vector(length = 46)
r <- 0.8286037
m <- (mean(totscores))
for (i in 1:length(truescores)){
x[i] <- totscores[i]
truescores[i] <- kelleyTS(r, x[i], m)}
cbind(truescores,totscores)
## truescores totscores
## [1,] 5.0596161 5
## [2,] 2.5738050 2
## [3,] 6.7168235 7
## [4,] 2.5738050 2
## [5,] 3.4024087 3
## [6,] 4.2310124 4
## [7,] 7.5454272 8
## [8,] 0.9165976 0
## [9,] 2.5738050 2
## [10,] 6.7168235 7
## [11,] 2.5738050 2
## [12,] 10.0312383 11
## [13,] 5.8882198 6
## [14,] 2.5738050 2
## [15,] 1.7452013 1
## [16,] 8.3740309 9
## [17,] 6.7168235 7
## [18,] 1.7452013 1
## [19,] 10.8598420 12
## [20,] 9.2026346 10
## [21,] 7.5454272 8
## [22,] 11.6884457 13
## [23,] 9.2026346 10
## [24,] 8.3740309 9
## [25,] 4.2310124 4
## [26,] 1.7452013 1
## [27,] 9.2026346 10
## [28,] 2.5738050 2
## [29,] 2.5738050 2
## [30,] 1.7452013 1
## [31,] 3.4024087 3
## [32,] 5.8882198 6
## [33,] 9.2026346 10
## [34,] 4.2310124 4
## [35,] 5.0596161 5
## [36,] 0.9165976 0
## [37,] 2.5738050 2
## [38,] 4.2310124 4
## [39,] 5.0596161 5
## [40,] 6.7168235 7
## [41,] 6.7168235 7
## [42,] 3.4024087 3
## [43,] 4.2310124 4
## [44,] 3.4024087 3
## [45,] 9.2026346 10
## [46,] 10.8598420 12
op <- par(mfrow=c(2,1))
hist(totscores,
main = "Histogram of Total Scores",
xlab = "Total Scores",
breaks = seq(0,14,1))
hist(truescores,
main = "Histogram of Kelley's True Scores",
xlab = "True Scores",
breaks = seq(0,14,1))
par(op)
| ANSWER: |
| All the true scores appear to be pulled toward the mean, adjusted up if lower and adjusted down if higher. This adjustment is proportional to how extreme the observation is (e.g., a score of 0, for person 8, got adjusted up by almost an entire point, whereas a score of 5, for person 1, was only adjusted up by about .06). |
| It also looks like the true scores are (a bit) more normally distributed! |