Nothing
#' Evaluate OLAT Exams
#'
#' Evaluate OLAT exams produced with \code{\link[c403]{exams2olat}},
#' and carried out and exported in (Open)OLAT.
#'
#' @param file character. Base file name of RDS and XLS file with
#' exam generated by \code{\link[c403]{exams2olat}} and exported
#' OLAT results, respectively.
#' @param plot logical. Should barplots with the aggregated
#' results be displayed on the screen?
#' @param export logical. Should detailed questions along with
#' individual results be exported to HTML files in a ZIP archive
#' for convenient import into OLAT?
#'
#' @details \code{olat_eval} is a companion function for \code{\link[c403]{exams2olat}}.
#' It evaluates the exams carried out in OLAT for further processing outside
#' of OLAT (in CSV format) and optionally exports detailed individual HTML
#' reports (in a ZIP archive) for reimport into OLAT.
#'
#' @return A \code{data.frame} with the detailed exam results is returned invisibly.
#' It is also written to a CSV file in the current directory, along with a ZIP
#' file containing the HTML reports (for upload into OLAT).
#'
#' @importFrom graphics barplot par
#' @importFrom grDevices hcl
#' @importFrom stats median na.omit
#' @importFrom tools file_path_sans_ext
#' @import utils
#' @seealso \code{\link[c403]{exams2olat}}
#' @keywords utilities, OLAT
#' @export
olat_eval <- function(file, plot = TRUE, export = FALSE) {
## file basename
file <- file_path_sans_ext(file)
## read/parse data
exm <- readRDS(paste(file, "rds", sep = "."))
res <- paste(file, c("xls", "xlsx"), sep = ".")
res <- res[file.exists(res)]
res <- read_olat_results(res, exm)
n <- length(exm)
k <- length(exm[[1L]])
## omit duplicated students, keep only last result
## (assuming chronological ordering -> could also be enforced otherwise)
if("registrationnumber" %in% names(res)) {
res <- res[!duplicated(res$registrationnumber, fromLast = TRUE), ]
} else {
res <- res[!duplicated(res$username, fromLast = TRUE), ]
}
## write results to csv
write.table(res, paste(file, "csv", sep = "."), sep = ";",
row.names = FALSE, col.names = TRUE, quote = FALSE)
## visualize aggregate statistics
if(plot) {
## plots
par(mar = c(4, 6, 4, 1), mfrow = c(1, 2))
## exercise names (FIXME: somewhat uibkmath-specific!)
nam0 <- sapply(exm[[1L]], function(obj) obj$metainfo$file)
nam <- try(sapply(strsplit(nam0, "-", fixed = TRUE), "[[", 3L), silent = TRUE)
nam <- if(inherits(nam, "try-error")) {
nam0
} else {
sapply(strsplit(nam, "_", fixed = TRUE), "[[", 1L)
}
## error proportion
pts <- as.matrix(res[, paste("points", 1L:k, sep = ".")])
pts[is.na(pts)] <- 0
pmx <- sapply(exm[[1L]], function(obj) {
p <- obj$metainfo$points
if(is.null(p)) 1 else p
})
pts <- 1 - pts/pmx
pts <- colMeans(pts, na.rm = TRUE)
barplot(pts[k:1L], names = nam[k:1L], horiz = TRUE, las = 1, main = "Error proportion")
## median duration
drt <- as.matrix(res[, paste("duration", 1L:k, sep = ".")])
drt <- as.vector(apply(drt/3600, 2, median, na.rm = TRUE))
barplot(drt[k:1L], names = nam[k:1L], horiz = TRUE, las = 1, main = "Median duration")
}
## export HTML results for OLAT
if(export) olat_eval_export(results = res, xexam = exm,
file = paste0(file, "-eval.zip"), html = paste0(file, ".html"),
col = hcl(c(1, 0, 60, 120), 70, 90))
## return overall results invisibly
invisible(res)
}
#' Read OLAT Results from XLSX file
#'
#' Get OLAT test results (FIXME: eval support and cloze evaluation).
#' TODO: Write proper documentation.
#'
#' @param file name of the file ...
#' @param xexam ...
#' @return ...
#'
#' @importFrom tools file_ext
read_olat_results <- function(file, xexam = NULL) {
## checking
stopifnot(file.exists(file <- path.expand(file)))
## read xexam (if any)
if(!is.null(xexam)) {
if(is.character(xexam)) xexam <- readRDS(xexam)
}
## QTI 2.1 xlsx or QTI 1.2 xls?
xlsx <- file_ext(file) == "xlsx"
## -------------------------------------------------
## Import results (xml file).
## Identify "blocks of question-relted information"
## which includes the information which answer was
## marked by the participants, duration, time started ...
## -------------------------------------------------
if(xlsx) {
## Read first two rows. Used to identify columns with section scores.
x_head <- openxlsx::read.xlsx(file, colNames = FALSE, rows = 1:2)
## Find columns where the first row contains a string of the format
## defined below (regular expression;
## (typically "Sektion \"<user text>\"" or "Section \"<user text>\"").
## We will later on (see read.xlsx) ignore these columns and only take
## the ones where x_take_cols is TRUE.
x_take_cols <- !grepl("^[A-Z][a-z]+\\s\\\".*\\\"$", x_head[1, ])
## Read 'main' content of the file.
x <- openxlsx::read.xlsx(file, startRow = 2L, cols = which(x_take_cols))
rm(list = c("x_take_cols", "x_head"))
## modify names, translate everything.
x <- olat_eval_adjust_lang(x)
## columns pertaining to items
## Only test results (not user information).
## Creates a vector with the indizes of all columns
## containing a "_C0"
iid <- grep("_C0$", names(x))
## Repeat idd, creates a vector which (may) look as follows:
## c(16, 16, 16, 16, 16, 16, 22, 22, 22, 22, 22, ...) where
## each unique integer defines a block of columns for a specific
## question. Used later on to extract the quetions (block-wise,
## check object 'y').
iid <- rep(iid, c(diff(iid), 1 + ncol(x) - max(iid)))
} else {
## The old OLAT 1.2 exported a CSV file with the file extension xls. This
## is the way results have been imported before olat 2.1.
## read data
x <- readLines(file, warn = FALSE)
x <- read.table(file, header = TRUE, sep = "\t",
colClasses = "character", skip = 1, fill = TRUE,
nrows = min(which(x == "")) - 3, quote = "\"", na.strings = "\"\"")
# Step 1: find all columns starting with X[0-9]+ as they
# contain the information about the individual questions.
col_idx <- grep("^X[0-9]+_", names(x))
# Step 2: rest is meta information
meta_idx <- (1:ncol(x))[-col_idx]
# Step 3: extract question ID and rename
# the columns (e.g., "X111_Pkt" to "Pkt.111")
iid <- question_id <- as.integer(regmatches(names(x)[col_idx], regexpr("(?<=(^X))[0-9]+", names(x)[col_idx], perl = TRUE)))
stopifnot(all(!is.na(question_id)))
# Create new variable names
new_name <- regmatches(names(x)[col_idx], regexpr("(?<=(\\_)).*$", names(x)[col_idx], perl = TRUE))
new_name <- paste(gsub("\\.+s\\.$", "", new_name), question_id, sep = ".")
names(x)[col_idx] <- new_name
## modify names, translate everything.
x <- olat_eval_adjust_lang(x)
stop("old olat csv/xls mode: fails later when trying to crate the ipmat as \"Start\" column missing.")
}
## -------------------------------------------------
## Extracting user information
## -------------------------------------------------
## The data.frame 'x' contains the user meta information and the
## details about all the questions in the test (column-by-column).
## The following few lines extract the user meta info, will be added
## to the result further down in this function again.
take <- c("registrationnumber", "firstname", "lastname", "username", "date",
"time", "element_score", "element_passed")
idx <- grep(sprintf("^(%s)$", paste(take, collapse = "|")), names(x), perl = TRUE)
user_info <- x[, idx]
## Check if we have all expected columns. If not, proceed,
## but throw a warning!
if (!all(take %in% names(user_info))) {
warning(sprintf("not all columns found as expected! Missing variable(s): %s\n",
paste(take[!take %in% names(user_info)], collapse = ", ")))
}
## -------------------------------------------------
## Element-wise evaluation.
## -------------------------------------------------
## Extracts/prepares the information of the individual questions.
## iid is an integer sequence which contains unique ID's
## where (in which columns) the individual questions/answers can
## be found. The following line evaluates question-by-question
## and stores it on y (list).
y <- lapply(split(x = seq(min(iid), ncol(x)), f = iid), function(ind) x[, ind, drop = FALSE])
## Convert list 'y' into a matrix
ipmat_fun <- function(d) {
col <- grep("^Start$", names(d))
stopifnot(length(col) == 1L)
return(nchar(as.character(d[, col])) > 10L)
}
ipmat <- t(sapply(y, ipmat_fun))
## assume xexams object
## number of sections and items
ix1 <- lapply(1:ncol(ipmat), function(i) which(ipmat[ , i, drop = TRUE]))
ni <- max(sapply(ix1, length)) # Number of questions in the quiz
ns <- length(unique(iid)) / ni # Number of different (random) quizzes
stopifnot(ns %% 1 == 0) # Must be divisible by 1.
ix2 <- lapply(ix1, function(i) {
ix <- rep(NA, ni)
ix[1L + (i - 1L) %/% ns] <- 1L + (i - 1L) %% ns
ix
})
## Convert datetime information to POSIXct
toPOSIXct <- if(xlsx) {
function(x) if(is.na(x) || x == "") NA else as.POSIXct(format(structure((x - 25567) * 24 * 3600, class = c("POSIXct", "POSIXt"))))
} else {
function(x) if(is.na(x) || x == "") NA else as.POSIXct(strptime(x, format = "%Y-%m-%dT%H:%M:%S"))
}
## -------------------------------------------------
## compute results
## -------------------------------------------------
process_item_result <- function(j)
{
rval <- lapply(1:length(ix2[[j]]), function(i) {
id <- ix2[[j]][i]
if(!is.na(id)) {
# Pick data.frame to process
ir <- y[[id + (i - 1) * ns]][j, ]
# Find indizes. Depending on the original language of the
# xlsx file from Olat the order might be different!
col_idx <- list(duration = grep("^Duration", names(ir)),
start = grep("^Start", names(ir)),
comment = grep("^Comment", names(ir)),
score = grep("^Score", names(ir)))
stopifnot(all(sapply(col_idx, length) == 1L))
col_idx$ssol <- (1:ncol(ir))[-unlist(col_idx)]
#stopifnot(!length(col_idx$ssol) == 2L)
# Extracting points
points <- as.numeric(ir[, col_idx$score])
points <- if(is.na(points)) 0 else points
# Extracting start and duration
start <- ir[, col_idx$start]
dur <- ir[, col_idx$duration]
# Answer/Solution
ssol <- ssol0 <- ir[, col_idx$ssol]
if(NCOL(ssol) > 1L) {
ssol <- ssol0 <- if(xlsx) {
try(gsub("NA", "0", gsub("x", "1", paste(ssol, collapse = ""), fixed = TRUE), fixed = TRUE), silent = TRUE)
} else {
try(gsub(".", "0", paste(ssol[-length(ssol)], collapse = ""), fixed = TRUE), silent = TRUE)
}
} else {
ssol <- ssol0 <- try(gsub(",", ".", ssol, fixed = TRUE), silent = TRUE)
}
if(inherits(ssol, "try-error")) ssol <- ssol0 <- NA
solx <- scheck <- NA
# Find solution/tolerance/type/points from
# question meta information
if(!is.null(xexam) & !is.na(id)) {
solx <- xexam[[id]][[i]]$metainfo$solution # exsolution e.g., 0010
tolx <- xexam[[id]][[i]]$metainfo$tolerance
typex <- xexam[[id]][[i]]$metainfo$type[1L]
ptsx <- xexam[[id]][[i]]$metainfo$points
if(is.null(ptsx)) ptsx <- 1
if(typex %in% c("mchoice", "schoice")) {
solx <- exams::mchoice2string(solx)
scheck <- as.numeric(points > 0) ## (ssol == solx) * ptsx
} else if(typex == "num") {
ssol <- as.numeric(gsub(",", ".", ssol, fixed = TRUE))
scheck <- as.numeric(points > 0) ## ((ssol >= solx - tolx) & (ssol <= solx + tolx)) * ptsx
} else if(typex == "cloze") {
stop("OLAT cloze reader not yet implemented")
}
}
# Check that $ssol has the same length as the
# solution string (solx; 0010 or similar).
stopifnot(length(col_idx$ssol) == nchar(solx))
if(is.na(scheck)) scheck <- 0
res <- data.frame(id + (i - 1) * ns,
round(as.numeric(points), digits = 8),
scheck, ssol0, solx,
toPOSIXct(start),
as.numeric(dur),
stringsAsFactors = FALSE)
} else {
res <- data.frame(t(rep(NA, 7L)))
}
if(!xlsx) res[res == ""] <- NA
names(res) <- paste(c("id", "points", "check", "answer", "solution", "start", "duration"), i, sep = ".")
return(res)
})
return(data.frame(rval, stringsAsFactors = FALSE))
}
res <- lapply(1L:length(ix2), process_item_result)
## -------------------------------------------------
## Combine results
## -------------------------------------------------
## Combines the user meta information (user_info)
## and the detailed information of the different
## questions (res) as returned from porcess_item_results.
res <- cbind(user_info, do.call(rbind, res))
## Some other stuff, convert datetime information,
## round scores, ...
if(xlsx) {
# Convert date into POSIXct
if(any(grepl("^date$", names(res))))
res[["date"]] <- toPOSIXct(res[["date"]])
# Round points to 8 digits
if(any(grepl("element_score", names(res))))
res[["element_score"]] <- round(res[["element_score"]], digits = 8)
} else {
true_false <- apply(res, 2, function(x) {
if(is.character(x)) {
x == "true" || x == "false"
} else FALSE
})
if(any(true_false)) {
for(i in which(true_false)) {
wh <- FALSE
if(!any(grepl("false", res[[i]]))) {
res[[i]] <- rep(TRUE, length(res[[i]]))
wh <- TRUE
}
if(!any(grepl("true", res[[i]]))) {
wh <- TRUE
res[[i]] <- rep(FALSE, length(res[[i]]))
}
if(!wh) res[[i]] <- res[[i]] == "true"
}
}
}
## Rename element_score and element_passed to "score" and "passed"
## for convenience. Why now? Before, the individual questions also
## have had a "Score" column, thus we do have to do it here.
names(res) <- gsub("^element_score$", "score", names(res))
names(res) <- gsub("^element_passed$", "passed", names(res))
## And that's it!
return(res)
}
#' Guess language of the OLAT results file
#'
#' Given a set of character vectors this function tries
#' to gess the language of the imported file. This allows to
#' evaluate exams from OpenOLAT in different languages.
#' Used by \code{\link[c403]{olat_eval}} to rename the columns
#' to make the evaluation independent from the language used when
#' exporting the results via OLAT.
#'
#' @param x character vector with column names
#' @return Returns the language name (\code{"en"}, \code{"de"}) if
#' the function is able to guess the language. Else the script will stop.
#'
#' @author Reto
olat_eval_guess_lang <- function(x) {
stopifnot(inherits(x, "character"))
# Check if language is English
check_lang <- function(find, x, fn)
return(fn(sapply(find, function(find, x) any(grepl(find, x)), x = x)))
if (check_lang(c("^Score$"), x, all)) {
lang <- "en"
} else if (check_lang(c("^Punkte$", "^Laufnummer$"), x, any)) {
lang <- "de"
} else {
print(x)
check_lang(c("^Punkte$", "^Laufnummer$"), x)
browser()
stop("Not able to guess the language of the file. Stop")
}
return(lang)
}
#' Adjust language of variables/columns
#'
#' Modifies the names of the variables in the \code{dat.frame}
#' as read from the xlsx file (OpenOLAT). Converts the variable
#' names to English such that we do no longer have to care about
#' language in all other methods/functions.
#'
#' @param x \code{data.frame} read from the xlsx file
#'
#' @details Input 'x' is the data.frame as read from the xlsx file
#' which contains user meta information and the detailed information
#' about the individual questions of the test.
#' Problem: depending on the user language settings of OLAT the names
#' and order of the columns differs. This function takes input 'x' and
#' manipulates the variable or column names in a way that the rest
#' of the code (\code{\link{olat_eval}}) is not language dependent anymore.
#'
#' \itemize{
#' \item{tries to guess the language by calling \code{\link{olat_eval_guess_lang}}}
#' \item{loads the search-replace-data.frame (internally)}
#' \item{search and replace variable names}
#' \item{return input object \code{x} with new varaible names}
#' }
#'
#' Note: Even English to English will rename some of the variables.
#'
#' The function uses the data set \code{olat_eval_lang} which is shipped
#' with the package (see \code{data("olat_eval_lang")}).
#'
#' @return Returns the same \code{data.frame} (same dimension and data)
#' with adjusted names.
#'
#' @author Reto
olat_eval_adjust_lang <- function(x) {
stopifnot(inherits(x, "data.frame"))
# Guess current language
lang <- olat_eval_guess_lang(names(x))
# Load and subset the language search and replace
# file, subset current language, replace names
load(file.path(system.file(package = "c403"), "data", "olat_eval_lang.rda"))
olat_eval_lang <- olat_eval_lang[olat_eval_lang$lang == lang, ]
# Search and replace
if (nrow(olat_eval_lang) > 0L) {
for (i in 1:nrow(olat_eval_lang)) {
names(x) <- gsub(olat_eval_lang$find[i],
olat_eval_lang$replace[i],
names(x), perl = TRUE)
}
}
names(x) <- gsub("..s.", "", names(x), fixed = TRUE)
names(x) <- gsub(".(s)", "", names(x), fixed = TRUE)
# Return renamed data.frame 'x'
return(x)
}
#' Olat eval export
#'
#' Takes the results from \code{\link[c403]{read_olat_results}} and the information
#' from the \code{rds} file with the individual questions/answers to generate a
#' zip archive file with individual test results (html file). This zip file
#' can be used to upload to OLAT.
#'
#' @param results data.frame, results from \code{\link[c403]{read_olat_results}}
#' @param xexam list the object loaded from the rds file which contains the
#' individual questions/answers. The length of the list corresponds to the
#' number of randomized tests, each list element contains N elements (N =
#' number of questions) with all the information required to generate the
#' output.
#' @param file character, name of the zip flie, the final archive file where to
#' store the exported html files
#' @param html character, name of the output files (html files)
#' @param col character vector of length \code{4L} with hex colors, default
#' is \code{hcl(c(0, 0, 60, 120), c(70, 0, 70, 70), 90)}
#'
#' @importFrom exams string2mchoice
#' @return Return of the \code{zip()} call.
olat_eval_export <- function(results, xexam, file = "olat_eval.zip", html = "Testergebnisse.html",
col = hcl(c(0, 0, 60, 120), c(70, 0, 70, 70), 90))
{
## Sanity check
stopifnot(inherits(results, "data.frame"))
stopifnot(inherits(xexam, "list"))
## Check if we have the required columns
## username: the c-number (unique student identifier)
## firstname/lastname: name of the participant
## registrationnumber: registration or matrikulation number
## score: points in the test (total)
vars_req <- c("username", "firstname", "lastname", "registrationnumber", "score")
stopifnot(all(vars_req %in% names(results)))
## results and exam
if(is.character(results)) results <- read.csv2(results, colClasses = "character")
if(is.character(xexam)) xexam <- readRDS(xexam)
## dimensions
k <- length(grep("answer.", colnames(results), fixed = TRUE))
n <- length(xexam)
## HTML template
name <- gsub("\\/", "-", html)
html <- paste(
'<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"',
'"http://www.w3.org/TR/html4/strict.dtd">',
sprintf('<meta http-equiv="content-type" content="text/html; charset=%s">', "UTF-8"),
'<html>',
'',
'<head>',
'<title>Testergebnisse</title>',
'<style type="text/css">',
'body{font-family:Arial;}',
'</style>',
'</head>',
'',
'<body>',
'<h3>Testergebnisse</h3>',
'<table>',
'<tr>',
' <td>Name:</td><td>%s</td>',
'</tr>',
'<tr>',
' <td>Matrikelnummer:</td><td>%s</td>',
'</tr>',
'<tr>',
' <td>Punkte:</td><td>%s</td>',
'</tr>',
'</table>',
'',
'<h3>Auswertung</h3>',
'<table border="1" bgcolor="#000000" cellspacing="1" cellpadding="5">',
'<tr valign="top" bgcolor="#FFFFFF"><td align="right">Frage</td><td align="right">Punkte</td><td>Gegebene Antwort</td><td>Richtige Antwort</td></tr>',
'%s',
'</table>',
'',
'<h3>Aufgaben</h3>',
'<ol>',
'%s',
'</ol>',
'',
'</body>',
'</html>', sep = "\n")
## convenience functions
format_mchoice1 <- function(mc) {
if(is.na(mc) | mc == "") return("n/a")
mc <- string2mchoice(mc)
paste(ifelse(mc, letters[seq_along(mc)], "_"), collapse = "")
}
format_num1 <- function(x) {
if(is.na(x) | x == "") return("n/a") else return(x)
}
## directories
odir <- getwd()
dir <- tempfile()
dir.create(dir)
setwd(dir)
on.exit(setwd(odir))
## process each participant
for(i in 1:nrow(results)) {
## directory
dir.create(file.path(dir, results$username[i]))
## collect results
id <- as.numeric(results[i, paste("id", 1L:k, sep = ".")])
id <- 1L + (id - 1L) %% n
typ <- sapply(1L:k, function(j) xexam[[id[[j]]]][[j]]$metainfo$type)
mch <- typ %in% c("schoice", "mchoice")
pts <- as.numeric(results[i, paste("points", 1L:k, sep = ".")])
chk <- as.numeric(results[i, paste("check", 1L:k, sep = ".")])
ans <- as.character(results[i, paste("answer", 1L:k, sep = ".")])
sol <- as.character(results[i, paste("solution", 1L:k, sep = ".")])
## format individual answers
if(any(mch)) {
ans[mch] <- sapply(ans[mch], format_mchoice1)
sol[mch] <- sapply(sol[mch], format_mchoice1)
}
if(any(typ == "num")) {
sol[typ == "num"] <- sapply(sol[typ == "num"], format_num1)
}
pts[is.na(pts)] <- 0
## collect question block
que <- sapply(1L:k, function(j) {
exj <- xexam[[id[[j]]]][[j]]
if(mch[j]) {
paste0(paste(exj$question, collapse = "\n"),
"<br/>\n<ol type=\"a\">\n",
paste("<li>", exj$questionlist, "</li>", sep = "", collapse = "\n"),
"</ol><br/>\n<b>Richtige Antwort:</b> ", sol[j], ".<br/> ")
} else {
paste0(paste(exj$question, collapse = "\n"),
"<br/>\n<b>Richtige Antwort:</b> ", sol[j], ".<br/> ")
}
})
que <- paste("<li><b>Frage:</b> ", que, "</li>", sep = "", collapse = "\n")
## collect results
res <- paste(sprintf(
'<tr valign="top" bgcolor="%s"><td align="right">%s</td><td align="right">%s</td><td>%s</td><td>%s</td></tr>',
as.character(cut(chk, breaks = c(-Inf, -0.00001, 0.00001, 0.99999, Inf), labels = col)),
1:k,
pts,
ans,
sol
), collapse = "\n")
html_i <- sprintf(html, paste(results$firstname[i], results$lastname[i]),
results$registrationnumber[i], as.numeric(results$score[i]),
res, que)
writeLines(html_i, file.path(dir, results$username[i], name))
}
setwd(dir)
invisible(zip(file.path(odir, file), results$username))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.