Right now I have a data set with 23 quiz questions, where respondents had to put named steps in the correct order. I used Qualtrics, so the data was output in a way where it tells me where respondents put each step in the list of 23. Here's a condensed version of the data
ResponseID | Step1| Step2 |Step3|.....|Step22|Step23
p1 | 1 | 2 | 3 |.....|22 |23
p2 | 2 | 3 | 4 |.....|23 |1
p3 | 2 | 23 | 7 |.....|12 |17
The correct order is numerical. So anyone who had a row of their answers going from 1 to 23, in order, would have gotten all the steps in the correct order.
Oringally, I graded it by assigning point values like so:
dissdata <- dissdata %>%
mutate(retention1score = ifelse(dissdata$Q9.2_1 == 1, 1, 0) +
ifelse(dissdata$Q9.2_2 == 2, 1, 0) +
ifelse(dissdata$Q9.2_3 == 3, 1, 0) +
ifelse(dissdata$Q9.2_4 == 4, 1, 0) +
ifelse(dissdata$Q9.2_5 == 5, 1, 0) +
ifelse(dissdata$Q9.2_6 == 6, 1, 0).................
ifelse(dissdata$Q9.2_23 == 23, 1, 0))
So based off of this, respondent p1 in the table above got a score of 100% or 23/23. Respondents p2 and p3 got 0 points. But as you can see, respondent 2 was slightly more correct than respondent 3. Respondent p2 was one-off for the whole quiz, whereas respondent3 was entirely wrong.
So, this if else method works for really strict, all or nothing grading. But it doesn't account for people who may have been 1 step off, like putting step number 1 as step number 2. I want to be able to assign partial credit for being 1 2 or 3 steps off. Or for anyone who may have had chunks of it correct.
How can I accomplish this in R? This link seems to be a great solution if anyone can guess at how they accomplished it: Programmatic Partial Credit Put In Order Grading
Thanks!
One might consider a distance-function, where "perfectly right" has a distance of zero, and anything else is less than 100%. There is a lot of wiggle room in interpreting this method, but any partial credit instead of "WRONG! 0%" can be considered a more consoling teaching method.
quux <- structure(list(ResponseID = c("p1", "p2", "p3"), Step1 = c(1L, 2L, 2L), Step2 = c(2L, 3L, 23L), Step3 = c(3L, 4L, 7L), Step22 = c(22L, 23L, 12L), Step23 = c(23L, 1L, 17L)), class = "data.frame", row.names = c(NA, -3L))
quux
# ResponseID Step1 Step2 Step3 Step22 Step23
# 1 p1 1 2 3 22 23
# 2 p2 2 3 4 23 1
# 3 p3 2 23 7 12 17
# you should probably use 1:23, but I only have a subset of data
correct <- c(1, 2, 3, 22, 23)
This first distance function heavily penalizes (for instance) Step23 for respondent 2, since the absolute difference is 23 - 1 = 22. The math is simply Pythagorean on n-dim data. I'll use quux[,-1] to exclude the ResponseID column.
do.call(mapply, c(list(FUN = function(...) sqrt(sum((unlist(list(...)) - correct)^2))), quux[,-1]))
# [1] 0.00000 22.09072 24.37212
Here, 0.000 is clearly 100%, and the others are various levels of "not right". The worst in this 5-question case is just above 45.7, where Step1=23, Step2=22, ..., Step23=1; If all 23 are perfectly backwards, then the penalty score here is
sqrt(sum((1:23 - 23:1)^2))
# [1] 63.62389
Over to you if you think 22.09072 is worth a linear partial, as in
100 * (63.62389 - do.call(mapply, c(list(FUN = function(...) sqrt(sum((unlist(list(...)) - correct)^2))), quux[,-1]))) / 63.62389
# [1] 100.00000 65.27920 61.69345
### percent
That is hasty and should really be thought-through before accepting carte blanche.
Another thought is that you take the presence of right/wrong, not the distance. That is, Step23=1 is valued 1, as is Step23=22 valued 1, but correct values are valued 0.
do.call(mapply, c(list(FUN = function(...) sqrt(sum(unlist(list(...)) != correct))), quux[,-1]))
# [1] 0.000000 2.236068 2.236068
Note that we don't need ^2 here, since it's always 0 or 1, so the square does nothing. (Feel free to keep it if it makes you feel better about the Pythagorean nature of this method ...)
We could just as easily do == instead of !=, and the values would be 2.236 for 100%, but I thought I'd be consistent with the inversion started in the first part.
The perfectly-wrong (all 23 are off by 1 or more) is merely
sqrt(sum(2:24 != 1:23))
# [1] 4.795832
The article you linked leans towards "longest correctly-ordered chain" from the numbers. If you look at https://www.r-bloggers.com/2014/09/compute-longest-increasingdecreasing-subsequence-using-rcpp/, that's a method that finds the longest chain in the sequence of numbers.
Using their function:
longest_subseq <- function(x) {
P = integer(length(x))
M = integer(length(x) + 1)
L = newL = 0
for (i in seq_along(x) - 1) {
lo = 1
hi = L
while (lo <= hi) {
mid = (lo + hi)%/%2
if (x[M[mid + 1] + 1] < x[i + 1]) {
lo = mid + 1
} else {
hi = mid - 1
}
}
newL = lo
P[i + 1] = M[newL]
if (newL > L) {
M[newL + 1] = i
L = newL
} else if (x[i + 1] < x[M[newL + 1] + 1]) {
M[newL + 1] = i
}
}
k = M[L + 1]
re = integer(L)
for (i in L:1) {
re[i] = k + 1
k = P[k + 1]
}
re
}
We can then find how many of the numbers (in each row) are in the correct order:
longest_subseq(c(1, 2, 3, 22, 23))
# [1] 1 2 3 4 5 ## length 5, perfect score!
longest_subseq(c(2, 3, 4, 23, 1))
# [1] 1 2 3 4 ## length 4
longest_subseq(c(2, 23, 7, 12, 17))
# [1] 1 3 4 5 ## length 4
and automate it as
do.call(mapply, c(list(FUN = function(...) length(longest_subseq(unlist(list(...))))), quux[,-1]))
# [1] 5 4 4
In this case, respondent 1 had all five (of these) in the correct order; respondents 2 and 3 only had one out of the preferred relative order.
This method provides a much clearer scoring: all 23 in order is 100%