From a50468cac2f57d05f7c6a4066e34f82b02fa2693 Mon Sep 17 00:00:00 2001 From: Benjamin Mako Hill Date: Sat, 5 Mar 2022 22:48:40 -0800 Subject: [PATCH] fix an ordering bug with grade creation --- .../compute_final_case_grades.R | 50 ++++++++++--------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/assessment_and_tracking/compute_final_case_grades.R b/assessment_and_tracking/compute_final_case_grades.R index 22dae47..1c25538 100644 --- a/assessment_and_tracking/compute_final_case_grades.R +++ b/assessment_and_tracking/compute_final_case_grades.R @@ -10,21 +10,20 @@ rownames(d) <- d$unique.name call.list$timestamp <- as.Date(call.list$timestamp) ## class-level variables -question.grades <- c("PLUS"=100, "CHECK"=100-(50/3.3), "MINUS"=100-(50/(3.3)*2)) -missed.question.penalty <- (50/3.3) * 0.2 ## 1/5 of a full point on the GPA scale +gpa.point.value <- 50/(4 - 0.7) +question.grades <- c("PLUS"=100, "CHECK"=100-gpa.point.value, "MINUS"=100-(gpa.point.value*2)) +missed.question.penalty <- gpa.point.value * 0.2 ## 1/5 of a full point on the GPA scale ## inspect set the absence threashold ggplot(d) + aes(x=absences) + geom_histogram(binwidth=1, fill="white",color="black") -## absence.threshold <- median(d$absences) -absence.threshold <- 4 ## TODO talk about this +absence.threshold <- median(d$absences) + ## inspect and set the questions cutoff ## questions.cutoff <- median(d$num.calls) ## median(d$num.calls) ## questions.cutoff <- nrow(call.list) / nrow(d) ## TODO talk about this -## first these are the people were were not called simply because they got unlucky - - ## this is the 95% percentile based on simulation in simulation.R +## this is the 95% percentile based on simulation in simulation.R questions.cutoff <- 4 ## show the distribution of assessments @@ -36,8 +35,11 @@ prop.table(table(call.list.full$answered)) total.questions.asked <- nrow(call.list) -## find out how man questions folks have present/absent for -########################################################## +## find out how man questions folks have present/absent for. +## +## NOTE: this is currently only for informational purposes and is NOT +## being used to compute grants in any way. +######################################################################## calls.per.day <- data.frame(day=as.Date(names(table(call.list$timestamp))), questions.asked=as.numeric(table(call.list$timestamp))) @@ -67,7 +69,7 @@ d$prop.asked.quant <- cut(d$prop.asked, right=FALSE, breaks=c(prop.asks.quantile labels=names(prop.asks.quantiles)[1:(length(prop.asks.quantiles))]) ## generate grades -########################################################## +######################################################################## ## print the median number of questions for (a) everybody and (b) ## people that have been present 75% of the time @@ -92,45 +94,44 @@ gen.part.grade <- function (x.unique.name) { tmp <- do.call("rbind", lapply(d$unique.name, gen.part.grade)) d <- merge(d, tmp) rownames(d) <- d$unique.name - -## apply the penality for number of days we called on them and they were gone -d$part.grade <- d$base.grade - d$missing.in.class.days * missed.question.penalty -d$part.grade.orig <- d$part.grade +d$part.grade <- d$base.grade ## first we handle the zeros ## step 1: first double check the people who have zeros and ensure that they didn't "just" get unlucky" d[d$num.calls == 0,] ## set those people to 0 :( -d[d$num.calls == 0] d$part.grade[d$num.calls == 0] <- 0 -## step 2: identify the people who were were not asked "enough" questions but were unlucky/lucky -## penalized.unique.names <- d$unique.name[d$num.calls < median(d$num.calls) & d$absences > median(d$absences)] +## step 2: identify the people who were were not asked "enough" +## questions but were unlucky/lucky -## first these are the people were were not called simply because they got unlucky +## first this just prints out are the people were were not called +## simply because they got unlucky d[d$num.calls < questions.cutoff & d$absences < absence.threshold,] -## first these are the people were were not called simply because they got unlucky +## these are the people were were not called simply unlucky (i.e., +## they were not in class very often) penalized.unique.names <- d$unique.name[d$num.calls < questions.cutoff & d$absences > absence.threshold] d[d$unique.name %in% penalized.unique.names,] ## now add "zeros" for every questions that is below the normal -d[as.character(penalized.unique.names),"part.grade"] <- (( - (questions.cutoff - d[as.character(penalized.unique.names),"num.calls"] * 0) + - (d[as.character(penalized.unique.names),"num.calls"] * d[as.character(penalized.unique.names),"part.grade"]) ) +d[as.character(penalized.unique.names),"part.grade"] <- ( + (d[as.character(penalized.unique.names),"num.calls"] * d[as.character(penalized.unique.names),"part.grade"]) / questions.cutoff) d[as.character(penalized.unique.names),] +## apply the penality for number of days we called on them and they were gone +d$part.grade <- d$part.grade - d$missing.in.class.days * missed.question.penalty + ## TODO ensure this is right. i think it is ## map part grades back to 4.0 letter scale and points -d$part.4point <- round((d$part.grade / (50/3.3)) - 2.6, 2) +d$part.4point <- round((d$part.grade / gpa.point.value) - ((100 / gpa.point.value) - 4), 2) d[sort.list(d$part.4point, decreasing=TRUE), c("unique.name", "short.name", "num.calls", "absences", "part.4point")] - ## writing out data to CSV d.print <- merge(d, myuw[,c("StudentNo", "FirstName", "LastName", "UWNetID")], by.x="unique.name", by.y="StudentNo") @@ -145,3 +146,4 @@ for (id in d$unique.name) { d.print$unique.name[d.print$unique.name == id], sep="")) } +k -- 2.39.5