Nothing
exams2blackboard <- function(file, n = 1L, nsamp = NULL, dir = ".",
name = NULL, quiet = TRUE, edir = NULL, tdir = NULL, sdir = NULL, verbose = FALSE, rds = FALSE,
resolution = 100, width = 4, height = 4, encoding = "UTF-8", envir = NULL, engine = NULL,
num = NULL, mchoice = NULL, schoice = mchoice, string = NULL, cloze = NULL,
template = "blackboard",
pdescription = "This is an item from an item pool.", tdescription = "This is today's test.",
pinstruction = "Please answer the following question.", tinstruction = "Give an answer to each question.",
maxattempts = 1, zip = TRUE,
points = NULL, eval = list(partial = TRUE, rule = "false2", negative = FALSE), base64 = FALSE, converter = NULL,
seed = NULL, mathjax = NULL, fix_pre = TRUE, ...)
{
## handle matrix specification of file
if(is.matrix(file)) {
if(!missing(n) && !is.null(n) && n != nrow(file)) warning("'n' must not differ from number of rows of 'file'")
if(!missing(nsamp) && !is.null(nsamp) && nsamp != ncol(file)) warning("'nsamp' must not differ from number of columns of 'file'")
n <- nrow(file)
nsamp <- ncol(file)
}
## default converter is "ttm" if all exercises are Rnw, otherwise "pandoc"
if(is.null(converter)) {
converter <- if(any(tolower(tools::file_ext(unlist(file))) == "rmd")) "pandoc" else "ttm"
}
if(is.null(mathjax)) mathjax <- converter == "pandoc-mathjax"
## set up .html transformer
htmltransform <- make_exercise_transform_html(converter = converter, base64 = base64, ...)
## create a name
if(is.null(name)) name <- file_path_sans_ext(basename(template))
if(isTRUE(rds)) rds <- name
## generate the exam
exm <- xexams(file, n = n, nsamp = nsamp,
driver = list(
sweave = list(quiet = quiet, pdf = FALSE, png = TRUE,
resolution = resolution, width = width, height = height,
encoding = encoding, envir = envir, engine = engine),
read = NULL, transform = htmltransform, write = NULL),
dir = dir, edir = edir, tdir = tdir, sdir = sdir, verbose = verbose, seed = seed, rds = rds, points = points)
## start .xml assessement creation
## get the possible item body functions and options
itembody <- list(num = num, mchoice = mchoice, schoice = schoice, cloze = cloze, string = string)
for(i in c("num", "mchoice", "schoice", "cloze", "string")) {
if(is.null(itembody[[i]])) itembody[[i]] <- list()
if(is.list(itembody[[i]])) {
if(is.null(itembody[[i]]$eval)) itembody[[i]]$eval <- eval
## if(i == "cloze" && is.null(itembody[[i]]$eval$rule)) itembody[[i]]$eval$rule <- "none"
if(is.null(itembody[[i]]$mathjax)) itembody[[i]]$mathjax <- mathjax
itembody[[i]] <- do.call("make_itembody_blackboard", itembody[[i]])
}
if(!is.function(itembody[[i]])) stop(sprintf("wrong specification of %s", sQuote(i)))
}
## create a temporary directory
dir <- path.expand(dir)
if(is.null(tdir)) {
dir.create(tdir <- tempfile())
on.exit(unlink(tdir))
} else {
tdir <- path.expand(tdir)
}
if(!file.exists(tdir)) dir.create(tdir)
## the package directory
pkg_dir <- find.package("exams")
## get the .xml template
template <- path.expand(template)
template <- ifelse(
tolower(substr(template, nchar(template) - 3L, nchar(template))) != ".xml",
paste(template, ".xml", sep = ""), template)
template <- ifelse(file.exists(template),
template, file.path(pkg_dir, "xml", basename(template)))
if(!all(file.exists(template))) {
stop(paste("The following files cannot be found: ",
paste(basename(template)[!file.exists(template)], collapse = ", "), ".", sep = ""))
}
xml <- readLines(template[1L])
## check template for all necessary tags
## extract the template for the assessement, sections and items
if(length(start <- grep("<questestinterop", xml, fixed = TRUE)) != 1L ||
length(end <- grep("</questestinterop>", xml, fixed = TRUE)) != 1L) {
stop(paste("The XML template", template,
"must contain exactly one opening and closing <questestinterop> tag!"))
}
assessment_xml <- xml[start:end]
if(length(start <- grep("<section>", xml, fixed = TRUE)) != 1L ||
length(end <- grep("</section>", xml, fixed = TRUE)) != 1L) {
stop(paste("The XML template", template,
"must contain exactly one opening and closing <section> tag!"))
}
section_xml <- xml[start:end]
if(length(start <- grep("<item ", xml, fixed = TRUE)) != 1L ||
length(end <- grep("</item>", xml, fixed = TRUE)) != 1L) {
stop(paste("The XML template", template,
"must contain exactly one opening and closing <item> tag!"))
}
item_xml <- xml[start:end]
if(length(start <- grep("<selection_ordering>", xml, fixed = TRUE)) != 1L ||
length(end <- grep("</selection_ordering>", xml, fixed = TRUE)) != 1L) {
stop(paste("The XML template", template,
"must contain exactly one opening and closing <selection_ordering> tag!"))
}
ordering_xml <- xml[start:end]
## obtain the number of exams and questions
nx <- length(exm)
nq <- length(exm[[1L]])
## function for internal ids
make_test_ids <- function(n, type = c("test", "section", "item"))
{
switch(type,
"test" = paste(name, make_id(9), sep = "_"),
paste(type, formatC(1:n, flag = "0", width = nchar(n)), sep = "_")
)
}
## generate the test id
test_id <- make_test_ids(type = "test")
## create section ids
sec_ids <- paste(test_id, make_test_ids(2*nq + 1, type = "section"), sep = "_")
## create section/item titles and section description
if(is.null(pdescription)) pdescription <- ""
if(is.null(tdescription)) tdescription <- ""
if(is.null(pinstruction)) pinstruction <- ""
if(is.null(tinstruction)) tinstruction <- ""
## points setting
points <- sapply(1:nq, function(j) c(exm[[1L]][[j]]$metainfo$points, NA_real_)[1L])
points[is.na(points)] <- 1
## create the directory where the test is stored
dir.create(test_dir <- file.path(file_path_as_absolute(tdir), name))
## get correct question type spec for blackboard
## FIXME: cloze items are not yet available for blackboard
bb_questiontype <- function(x, y, item = FALSE) {
if(x == "string" && length(y) > 1L) {
warning(sprintf("multiple stringtypes specified (%s), only the first is used", paste(y, collapse = ", ")))
y <- y[1L]
}
type <- switch(if(!is.null(y)) y else x,
"mchoice" = "Multiple Answer",
"schoice" = "Multiple Choice",
"num" = "Numeric",
"cloze" = "Cloze",
"string" = "Fill in the Blank",
"essay" = "Short Response",
"file" = "File Upload"
)
type
}
##
## function to give right option for <bbmd_negative_points_ind>
set_negative_points <- function(eval = eval, type = type) {
if(!eval$partial){
x <- "N"
} else if(grepl("choice", type)){
x <- ifelse(eval$negative < 0, "Y", "N")
} else {
x <- "N"
}
x
}
## process maximal number of attempts
make_integer_tag <- function(x, type, default = 1) {
if(is.null(x)) x <- Inf
x <- round(as.numeric(x))
if(x < default) {
warning(paste("invalid ", type, " specification, ", type, "=", default, " used", sep = ""))
x <- default
}
if(is.finite(x)) sprintf("%s=\"%i\"", type, x) else ""
}
maxattempts <- make_integer_tag(maxattempts, type = "maxattempts", default = 1)
## write fixed part of test description file
test_xml <- assessment_xml
test_xml <- gsub('##TestTitle##', paste0(name, "-test"), test_xml, fixed = TRUE)
test_xml <- gsub('##TestIdent##', test_id, test_xml, fixed = TRUE)
test_xml <- gsub("##MaxTestScore##", sprintf("%.3f", sum(points)), test_xml, fixed = TRUE)
test_xml <- gsub('##AssessmentDescription##', tinstruction, test_xml, fixed = TRUE)
test_xml <- gsub('##AssessmentTitle##', tdescription, test_xml, fixed = TRUE)
test_xml <- gsub('##SectionContent##', paste(section_xml, collapse = "\n"), test_xml, fixed = TRUE)
test_xml <- gsub('##SectionId##', sec_ids[2*nq + 1], test_xml, fixed = TRUE)
test_xml <- gsub('##AssessmentType##', "Test", test_xml, fixed = TRUE)
test_xml <- gsub('##SectionType##', "Subsection", test_xml, fixed = TRUE)
test_xml <- gsub('##QuestionType##', "Multiple Choice", test_xml, fixed = TRUE)
test_xml <- gsub("##AbsoluteScoreMax##", sprintf("%.3f", sum(points)), test_xml, fixed = TRUE)
test_xml <- gsub('##Weighting##', "0.0", test_xml, fixed = TRUE)
## write heading of manifest_xml
manifest_xml <- c(
'<manifest identifier="man00001" xmlns:bb="http://www.blackboard.com/content-packaging/">',
'<organizations/>',
'<resources>')
bank_xml <- NULL
## cycle through all exams and questions
## similar questions are combined in a section,
## questions are then sampled from the sections
items <- sec_xml <- NULL; all_points <- rep(0, length = nq)
for(j in 1:nq) {
## create item ids
item_ids <- paste(sec_ids[j], make_test_ids(nx, type = "item"), sep = "_")
## create variable part of test description file
bank_xml <- c(bank_xml, section_xml)
bank_xml <- gsub('##SectionId##', sec_ids[nq + j], bank_xml, fixed = TRUE)
bank_xml <- gsub('##AssessmentType##', "Test", bank_xml, fixed = TRUE)
bank_xml <- gsub('##SectionType##', "Random Block", bank_xml, fixed = TRUE)
bank_xml <- gsub('##QuestionType##', "Multiple Choice", bank_xml, fixed = TRUE)
bank_xml <- gsub("##AbsoluteScoreMax##", sprintf("%.3f", points[j]), bank_xml, fixed = TRUE)
bank_xml <- gsub("##Weighting##", sprintf("%.3f", points[j]), bank_xml, fixed = TRUE)
bank_xml <- gsub('##SectionItems##', paste(ordering_xml, collapse = "\n"), bank_xml, fixed = TRUE)
bank_xml <- gsub('##QuestionType##', bb_questiontype(exm[[1]][[j]]$metainfo$type, exm[[1]][[j]]$metainfo$stringtype), bank_xml, fixed = TRUE)
bank_xml <- gsub('##SourceBankRef##', sprintf("res%05d", j), bank_xml, fixed = TRUE)
## create structure of pool j
pool_xml <- assessment_xml
pool_xml <- gsub('##TestTitle##', exm[[1]][[j]]$metainfo$name, pool_xml, fixed = TRUE)
pool_xml <- gsub('##TestIdent##', paste(test_id, j, sep="_"), pool_xml, fixed = TRUE)
pool_xml <- gsub('##MaxTestScore##', "0.0", pool_xml, fixed = TRUE)
pool_xml <- gsub('##AssessmentDescription##', pdescription, pool_xml, fixed = TRUE)
pool_xml <- gsub('##AssessmentTitle##', pinstruction, pool_xml, fixed = TRUE)
pool_xml <- gsub('##SectionContent##', paste(section_xml, collapse = "\n"), pool_xml, fixed = TRUE)
pool_xml <- gsub('##SectionId##', sec_ids[j], pool_xml, fixed = TRUE)
pool_xml <- gsub('##AssessmentType##', "Pool", pool_xml, fixed = TRUE)
pool_xml <- gsub('##SectionType##', "Subsection", pool_xml, fixed = TRUE)
pool_xml <- gsub('##QuestionType##', bb_questiontype(exm[[1]][[j]]$metainfo$type, exm[[1]][[j]]$metainfo$stringtype), pool_xml, fixed = TRUE)
pool_xml <- gsub('##AbsoluteScoreMax##', "0.0", pool_xml, fixed = TRUE)
pool_xml <- gsub('##Weighting##', "0.0", pool_xml, fixed = TRUE)
## include info of each pool j into manifest_xml
manifest_xml <- c(manifest_xml,sprintf('<resource bb:file="res%05d.dat" bb:title="%s" identifier="res%05d" type="assessment/x-bb-qti-pool" xml:base="res%05d"/>', j, exm[[1]][[j]]$metainfo$name, j, j))
ibody <- NULL
## now, insert the questions
for(i in 1:nx) {
if(i < 2)
all_points[j] <- if(is.null(exm[[i]][[j]]$metainfo$points)) 1 else exm[[i]][[j]]$metainfo$points
## get and insert the item body
type <- exm[[i]][[j]]$metainfo$type
## create an id
iname <- paste(item_ids[i], type, sep = "_")
## attach item id to metainfo
exm[[i]][[j]]$metainfo$id <- iname
thebody <- itembody[[type]](exm[[i]][[j]])
if(fix_pre) thebody <- fix_pre_lines(thebody)
ibody <- c(ibody, gsub("##ItemBody##",
paste(thebody, collapse = "\n"),
item_xml, fixed = TRUE))
## insert possible solution
enumerate <- attr(thebody, "enumerate")
if(is.null(enumerate)) enumerate <- FALSE
xsolution <- exm[[i]][[j]]$solution
if(fix_pre) xsolution <- fix_pre_lines(xsolution)
if(!is.null(exm[[i]][[j]]$solutionlist)) {
if(!all(is.na(exm[[i]][[j]]$solutionlist))) {
xsolution <- c(xsolution, if(length(xsolution)) "<br />" else NULL)
xsolution <- c(xsolution, if(enumerate) '<ol type = "a">' else '<ul>')
if(exm[[i]][[j]]$metainfo$type == "cloze") {
g <- rep(seq_along(exm[[i]][[j]]$metainfo$solution), sapply(exm[[i]][[j]]$metainfo$solution, length))
ql <- sapply(split(exm[[i]][[j]]$questionlist, g), paste, collapse = " / ")
sl <- sapply(split(exm[[i]][[j]]$solutionlist, g), paste, collapse = " / ")
} else {
ql <- exm[[i]][[j]]$questionlist
sl <- exm[[i]][[j]]$solutionlist
}
nsol <- length(ql)
xsolution <- c(xsolution, paste(rep('<li>', nsol),
ql, if(length(exm[[i]][[j]]$solutionlist)) "<br />" else NULL,
sl, rep('</li>', nsol)),
if(enumerate) '</ol>' else '</ul>')
}
}
ibody <- gsub("##ItemSolution##", paste(xsolution, collapse = "\n"), ibody, fixed = TRUE)
## insert an item id
ibody <- gsub("##ItemId##", iname, ibody)
## copy supplements
if(length(exm[[i]][[j]]$supplements)) {
if(!base64) {
if(!file.exists(media_dir <- file.path(test_dir, "csfiles", "home_dir")))
dir.create(media_dir, recursive = TRUE)
sj <- 1
while(file.exists(file.path(media_dir, sup_dir <- paste("supplements", sj, sep = "")))) {
sj <- sj + 1
}
dir.create(ms_dir <- file.path(media_dir, sup_dir))
}
for(si in seq_along(exm[[i]][[j]]$supplements)) {
f <- basename(exm[[i]][[j]]$supplements[si])
if(base64) {
replacement <- fileURI(exm[[i]][[j]]$supplements[si])
if(any(grepl(dirname(exm[[i]][[j]]$supplements[si]), ibody))) {
ibody <- gsub(dirname(exm[[i]][[j]]$supplements[si]),
replacement, ibody, fixed = TRUE)
} else {
if(any(grepl(f, ibody))) {
ibody <- gsub(paste(f, '"', sep = ''),
paste(replacement, '"', sep = ''), ibody, fixed = TRUE)
}
}
} else {
xid <- sprintf("xid-1%03d%03d_1", si, sj)
file.copy(exm[[i]][[j]]$supplements[si],
file.path(ms_dir, gsub(".", paste0("__", xid, "."), f, fixed = TRUE)))
if(any(grepl(dirname(exm[[i]][[j]]$supplements[si]), ibody))) {
ibody <- gsub(dirname(exm[[i]][[j]]$supplements[si]),
file.path(sup_dir), ibody, fixed = TRUE)
} else {
if(any(grepl(f, ibody))) {
ibody <- gsub(paste(f, '"', sep = ''),
paste("@X@EmbeddedFile.requestUrlStub@X@bbcswebdav", sup_dir, paste0(xid, "\""), sep = "/"), ibody, fixed = TRUE)
}
}
}
}
}
## insert question type
ibody <- gsub("##QuestionType##", bb_questiontype(type, exm[[i]][[j]]$metainfo$stringtype, item = FALSE), ibody, fixed = TRUE)
ibody <- gsub('##MaxAttempts##', 'maxattempts="1"', ibody, fixed = TRUE)
ibody <- gsub('##NegativePoints##', set_negative_points(eval = eval, type = type) , ibody, fixed = TRUE)
ibody <- gsub('##PartialCredit##', ifelse(grepl("choice", type) & eval$partial, "true", "false"), ibody, fixed = TRUE)
}
## fill pool j with item content and write to file
pool_xml <- gsub('##SectionItems##', paste(ibody, collapse = "\n"), pool_xml, fixed = TRUE)
writeLines(c('<?xml version="1.0" encoding="UTF-8"?>', pool_xml), file.path(test_dir, sprintf("res%05d.dat", j)))
}
## join fixed and variable parts of test description file and write to this file
test_xml <- gsub('##SectionItems##', paste(bank_xml, collapse = "\n"), test_xml, fixed = TRUE)
writeLines(c('<?xml version="1.0" encoding="UTF-8"?>', test_xml), file.path(test_dir, sprintf("res%05d.dat", nq + 1)))
## finish manifest_xml and write to file
manifest_xml <- c(manifest_xml,
sprintf('<resource bb:file="res%05d.dat" bb:title="%s-test" identifier="res%05d" type="assessment/x-bb-qti-test" xml:base="res%05d"/>', nq + 1, name, nq + 1, nq + 1),
'</resources>',
'</manifest>')
writeLines(c('<?xml version="1.0" encoding="UTF-8"?>', manifest_xml), file.path(test_dir, "imsmanifest.xml"))
## write .bb-package-info file, needs just single line
bb.inf <- 'cx.package.info.version=6.0'
writeLines(bb.inf, file.path(test_dir, ".bb-package-info"))
## compress; added all.files=T for including bb info file
if(zip) {
owd <- getwd()
setwd(test_dir)
zip(zipfile = zipname <- paste(name, "zip", sep = "."), files = c(list.files(test_dir), ".bb-package-info"))
setwd(owd)
} else zipname <- list.files(test_dir)
## copy the final .zip file
file.copy(file.path(test_dir, zipname), dir, recursive = TRUE)
## assign test id as an attribute
attr(exm, "test_id") <- test_id
invisible(exm)
}
## Blackboard item body constructor function
make_itembody_blackboard <- function(rtiming = FALSE, shuffle = FALSE, rshuffle = shuffle,
minnumber = NULL, maxnumber = NULL, defaultval = NULL, minvalue = NULL,
maxvalue = NULL, cutvalue = NULL, enumerate = TRUE, digits = NULL, tolerance = is.null(digits),
maxchars = 12, eval = list(partial = TRUE, rule = "false2", negative = FALSE),
qti12 = FALSE, mathjax = FALSE)
{
function(x) {
## how many points?
points <- if(is.null(x$metainfo$points)) 1 else x$metainfo$points
## how many questions
solution <- if(!is.list(x$metainfo$solution)) {
list(x$metainfo$solution)
} else x$metainfo$solution
n <- length(solution)
questionlist <- if(!is.list(x$questionlist)) {
if(x$metainfo$type == "cloze") {
g <- rep(seq_along(x$metainfo$solution), sapply(x$metainfo$solution, length))
split(x$questionlist, g)
} else list(x$questionlist)
} else x$questionlist
if(length(questionlist) < 1) questionlist <- NULL
tol <- if(!is.list(x$metainfo$tolerance)) {
if(x$metainfo$type == "cloze") as.list(x$metainfo$tolerance) else list(x$metainfo$tolerance)
} else x$metainfo$tolerance
tol <- rep(tol, length.out = n)
q_points <- rep(points, length.out = n)
if(x$metainfo$type == "cloze")
points <- sum(q_points)
## set question type(s)
type <- x$metainfo$type
if(type == "cloze") stop('"cloze" type questions not supported in exams2blackboard() yet!')
type <- if(type == "cloze") x$metainfo$clozetype else rep(type, length.out = n)
## evaluation policy
if(is.null(eval) || length(eval) < 1L) eval <- exams_eval()
if(!is.list(eval)) stop("'eval' needs to specify a list of partial/negative/rule")
eval <- eval[match(c("partial", "negative", "rule"), names(eval), nomatch = 0)]
if(x$metainfo$type %in% c("num", "string")) eval$partial <- FALSE
## if(x$metainfo$type == "cloze" && is.null(eval$rule)) eval$rule <- "none"
eval <- do.call("exams_eval", eval) ## always re-call exams_eval
## character fields
maxchars <- if(is.null(x$metainfo$maxchars)) {
if(length(maxchars) < 2) {
c(maxchars, NA, NA)
} else maxchars[1:3]
} else x$metainfo$maxchars
if(!is.list(maxchars))
maxchars <- list(maxchars)
maxchars <- rep(maxchars, length.out = n)
for(j in seq_along(maxchars)) {
if(length(maxchars[[j]]) < 2)
maxchars[[j]] <- c(maxchars[[j]], NA, NA)
}
## include MathJax script?
mathjax <- if(!mathjax) {
NULL
} else {
'<script type="text/javascript" src="https://mathjax.rstudio.com/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML"></script>'
}
## start item presentation
## and insert question
if(qti12) {
xml <- c(
'<presentation>',
'<flow>',
if(!is.null(x$question)) {
c(
'<material>',
'<mat_extension><mat_formattedtext type="HTML"><![CDATA[',
mathjax,
x$question,
']]></mat_formattedtext></mat_extension>',
'</material>'
)
} else NULL
)
} else {
xml <- c(
'<presentation>',
'<flow class="Block">',
'<flow class="QUESTION_BLOCK">',
'<flow class="FORMATTED_TEXT_BLOCK">',
if(!is.null(x$question)) {
c(
'<material>',
'<mat_extension><mat_formattedtext type="HTML"><![CDATA[',
mathjax,
x$question,
']]></mat_formattedtext></mat_extension>',
'</material>'
)
} else NULL,
rep('</flow>', 2)
)
}
## insert responses
ids <- el <- pv <- list()
for(i in 1:n) {
if(!qti12)
xml <- c(xml, '<flow class="RESPONSE_BLOCK">')
## get item id
iid <- x$metainfo$id
## generate ids
ids[[i]] <- list("response" = paste(iid, "RESPONSE", make_id(7), sep = "_"),
"questions" = paste(iid, make_id(10, length(x$metainfo$solution)), sep = "_"))
## evaluate points for each question
pv[[i]] <- eval$pointvec(solution[[i]])
pv[[i]]["pos"] <- pv[[i]]["pos"] * q_points[i]
if(length(grep("choice", type[i])))
pv[[i]]["neg"] <- pv[[i]]["neg"] * q_points[i]
## insert choice type responses
if(length(grep("choice", type[i]))) {
xml <- c(xml,
paste('<response_lid ident="', ids[[i]]$response, '" rcardinality="',
if(type[i] == "mchoice") "Multiple" else "Single", '" rtiming=',
if(rtiming) '"Yes"' else '"No"', '>', sep = ''),
paste('<render_choice shuffle="', if(shuffle) 'Yes' else 'No', '">', sep = '')
)
for(j in seq_along(solution[[i]])) {
if(qti12) {
xml <- c(xml,
'<flow_label class="List">',
paste('<response_label ident="', ids[[i]]$questions[j], '" rshuffle="',
if(rshuffle) 'Yes' else 'No', '">', sep = ''),
'<material>',
'<mat_extension><mat_formattedtext type="HTML"><![CDATA[',
paste(if(enumerate) {
paste(letters[if(x$metainfo$type == "cloze") i else j], ".",
if(x$metainfo$type == "cloze" && length(solution[[i]]) > 1) paste(j, ".", sep = "") else NULL,
sep = "")
} else NULL, questionlist[[i]][j]),
']]></mat_formattedtext></mat_extension>',
'</material>',
'</response_label>',
'</flow_label>'
)
} else {
xml <- c(xml,
'<flow_label class="Block">',
paste('<response_label ident="', ids[[i]]$questions[j], '" rshuffle="',
if(rshuffle) 'Yes' else 'No', '" rarea="Ellipse" rrange="Exact">', sep = ''),
'<flow_mat class="FORMATTED_TEXT_BLOCK">',
'<material>',
'<mat_extension>',
'<mat_formattedtext type="HTML">',
'<![CDATA[',
paste(if(enumerate) {
paste(letters[if(x$metainfo$type == "cloze") i else j], ".", ## Blackboard's enumeration turned off by using <bbmd_numbertype>none
if(x$metainfo$type == "cloze" && length(solution[[i]]) > 1) paste(j, ".", sep = "") else NULL,
sep = "")
} else NULL, questionlist[[i]][j]),
']]>',
'</mat_formattedtext>',
'</mat_extension>',
'</material>',
'</flow_mat>',
'</response_label>',
'</flow_label>'
)
}
}
## finish response tag
xml <- c(xml,
'</render_choice>',
'</response_lid>'
)
}
if(type[i] == "string" || type[i] == "num") {
for(j in seq_along(solution[[i]])) {
soltext <- if(type[i] == "num") {
if(!is.null(digits)) format(round(solution[[i]][j], digits), nsmall = digits) else solution[[i]][j]
} else {
if(!is.character(solution[[i]][j])) format(solution[[i]][j]) else solution[[i]][j]
}
xml <- c(xml,
# if(!is.null(questionlist[[i]][j])) {
# c('<material>',
# paste('<mat_extension><mat_formattedtext type="HTML"><![CDATA[', paste(if(enumerate) {
# paste(letters[i], ".", sep = '')
# } else NULL, questionlist[[i]][j]), ']]></mat_formattedtext></mat_extension>', sep = ""),
# '</material>')
# } else NULL,
paste(if(type[i] == "string") '<response_str ident="' else '<response_num ident="',
ids[[i]]$response, '" rcardinality="Single">', sep = ''),
paste('<render_fib',
if(!is.na(maxchars[[i]][1])) {
paste(' maxchars="', max(c(nchar(soltext), maxchars[[i]][1])), '"', sep = '')
} else NULL,
if(!is.na(maxchars[[i]][2])) {
paste(' rows="', maxchars[[i]][2], '"', sep = '')
} else NULL,
if(!is.na(maxchars[[i]][3])) {
paste(' columns="', maxchars[[i]][3], '"', sep = '')
} else NULL, '>', sep = ''),
'</render_fib>',
if(type[i] == "string") '</response_str>' else '</response_num>')
}
}
if(!qti12)
xml <- c(xml, '</flow>')
}
## finish presentation
xml <- c(xml, '</flow>', '</presentation>')
if(is.null(minvalue)) { ## FIXME: add additional switch, so negative points don't carry over?!
if(eval$negative) {
minvalue <- sum(sapply(pv, function(x) { x["neg"] }))
} else minvalue <- 0
}
## start resprocessing
xml <- c(xml,
'<resprocessing>',
'<outcomes>',
paste('<decvar varname="SCORE" vartype="Decimal" defaultval="',
if(is.null(defaultval)) 0 else defaultval, '" minvalue="',
if(is.null(minvalue)) 0 else minvalue, '" maxvalue="',
if(is.null(maxvalue)) points else maxvalue, '" cutvalue="',
if(is.null(cutvalue)) points else cutvalue, '"/>', sep = ''),
'</outcomes>')
## most is left as with qti12, but some stuff, such as wrong_answers is never used.
## in many cases Blackboard does not check respident, but simply uses the order in <respconditions>
## to deal with it just_answers is introduced
correct_answers <- wrong_answers <- correct_num <- just_answers <- vector(mode = "list", length = n)
for(i in 1:n) {
if(length(grep("choice", type[i]))) {
for(j in seq_along(solution[[i]])) {
if(solution[[i]][j]) {
correct_answers[[i]] <- c(correct_answers[[i]],
paste('<varequal respident="', ids[[i]]$response,
'" case="Yes">', ids[[i]]$questions[j], '</varequal>', sep = '')
)
just_answers[[i]] <- c(just_answers[[i]],
paste('<varequal respident="', ids[[i]]$response,
'" case="Yes">', ids[[i]]$questions[j], '</varequal>', sep = '')
)
} else {
wrong_answers[[i]] <- c(wrong_answers[[i]],
paste('<varequal respident="', ids[[i]]$response,
'" case="Yes">', ids[[i]]$questions[j], '</varequal>', sep = '')
)
just_answers[[i]] <- c(just_answers[[i]],
paste('<not>\n<varequal respident="', ids[[i]]$response,
'" case="Yes">', ids[[i]]$questions[j], '</varequal>\n</not>', sep = '')
)
}
}
}
if(type[i] == "string" || type[i] == "num") {
for(j in seq_along(solution[[i]])) {
if(type[i] == "string") {
soltext <- if(!is.character(solution[[i]][j])) {
format(round(solution[[i]][j], digits), nsmall = digits)
} else solution[[i]][j]
correct_answers[[i]] <- c(correct_answers[[i]], paste('<varequal respident="', ids[[i]]$response,
'" case="', string_evaltype(x$metainfo$evaltype, x$metainfo$usecase)[2], '">', soltext, '</varequal>', sep = "")
)
} else {
correct_answers[[i]] <- c(correct_answers[[i]],
if(!tolerance) {
paste('<varequal respident="', ids[[i]]$response,
'" case="No"><![CDATA[', if(!is.null(digits)) {
format(round(solution[[i]][j], digits), nsmall = digits)
} else solution[[i]][j],
']]></varequal>', sep = "")
} else {
paste(
paste('<vargte respident="', ids[[i]]$response, '">',
solution[[i]][j] - max(tol[[i]]),
'</vargte>\n', sep = ""),
paste('<varlte respident="', ids[[i]]$response, '">',
solution[[i]][j] + max(tol[[i]]),
'</varlte>\n', sep = ""),
paste('<varequal respident="', ids[[i]]$response, '">',
solution[[i]][j],
'</varequal>\n', sep = ""),
collapse = '\n', sep = ''
)
}
)
}
}
}
if(!is.null(correct_answers[[i]])) {
attr(correct_answers[[i]], "points") <- pv[[i]]
attr(correct_answers[[i]], "type") <- type[i]
}
if(!is.null(wrong_answers[[i]]))
attr(wrong_answers[[i]], "points") <- pv[[i]]
if(!is.null(just_answers[[i]]))
attr(just_answers[[i]], "points") <- pv[[i]]
}
## delete NULL list elements
correct_answers <- delete.NULLs(correct_answers)
wrong_answers <- delete.NULLs(wrong_answers)
just_answers <- delete.NULLs(just_answers)
correct_num <- unlist(delete.NULLs(correct_num))
## partial cloze incorrect num string answers
if(eval$partial & x$metainfo$type == "cloze") {
if(length(correct_answers)) {
for(i in seq_along(correct_answers)) {
ctype <- attr(correct_answers[[i]], "type")
if(ctype == "string" || ctype == "num") {
xml <- c(xml,
'<respcondition title="incorrect">',
'<conditionvar>',
'<not>',
correct_answers[[i]],
'</not>',
'</conditionvar>',
paste('<setvar varname="SCORE" action="Add">',
attr(correct_answers[[i]], "points")["neg"], '</setvar>', sep = ''),
'<displayfeedback feedbacktype="Solution" linkrefid="Solution"/>',
'</respcondition>'
)
}
}
}
}
## scoring/solution display for the correct answers
xml <- c(xml,
if(x$metainfo$type != "string" | !is.null(x$metainfo$stringtype))'<respcondition title="correct">' else '<respcondition title="right">',## string fails with "correct"
'<conditionvar>',
if(!is.null(just_answers) & (length(just_answers) > 1 | x$metainfo$type == "mchoice")) '<and>' else NULL
)
xml <- c(xml,
if(x$metainfo$type == "mchoice") unlist(just_answers) else unlist(correct_answers),
if(!is.null(just_answers) & (length(just_answers) > 1 | x$metainfo$type == "mchoice")) '</and>' else NULL,
'</conditionvar>',
if(!eval$partial & grepl("choice", x$metainfo$type)) {
paste('<setvar varname="SCORE" action="Set">', points, '</setvar>', sep = '') ## note that Blackboard never uses "Add" (as in qti12) but "Set"
} else NULL,
if(!eval$partial & x$metainfo$type == "string") {
if(is.null(x$metainfo$stringtype)) {
paste('<setvar varname="EvaluationType" action="Set">"', string_evaltype(x$metainfo$evaltype, x$metainfo$usecase)[1], '"</setvar>', sep = '')
} else '<setvar varname="SCORE" action="Set">SCORE.max</setvar>'
} else NULL,
'<displayfeedback feedbacktype="Response" linkrefid="correct"/>',
'</respcondition>'
)
## earlier stuff concerning forcing display of correct answers deleted
## handling incorrect answers deleted
## handle all other cases
xml <- c(xml,
'<respcondition title="incorrect">',
'<conditionvar>',
'<other/>',
'</conditionvar>',
paste('<setvar varname="SCORE" action="Set">', if(!eval$partial) minvalue else 0, '</setvar>', sep = ''),
#'<displayfeedback feedbacktype="Solution" linkrefid="Solution"/>', NS: changed
'<displayfeedback feedbacktype="Response" linkrefid="incorrect"/>',
'</respcondition>'
)
## handle unanswered cases deleted (Blackboard does not know <unanswered>)
## partial points (Blackboard presents credit bookkeeping at the end of <resprocessing>)
if(eval$partial) {
if(length(unlist(just_answers))) {
for(i in 1:n) {
for(j in seq_along(solution[[i]])) {
if(solution[[i]][j]) {
xml <- c(xml,
'<respcondition>',
'<conditionvar>',
paste('<varequal respident="', ids[[i]]$response,
'" case="No">', ids[[i]]$questions[j], '</varequal>', sep = ''),
'</conditionvar>',
paste('<setvar varname="SCORE" action="Set">',
eval$pointvec(solution[[i]])["pos"]*100, '</setvar>', sep = ''),
'</respcondition>'
)
} else {
xml <- c(xml,
'<respcondition>',
'<conditionvar>',
paste('<varequal respident="', ids[[i]]$response,
'" case="No">', ids[[i]]$questions[j], '</varequal>', sep = ''),
'</conditionvar>',
paste('<setvar varname="SCORE" action="Set">',
eval$pointvec(solution[[i]])["neg"]*100, '</setvar>', sep = ''),
'</respcondition>'
)
}
}
}
}
}
## end of response processing
xml <- c(xml, '</resprocessing>')
attr(xml, "enumerate") <- enumerate
xml
}
}
## some learning management systems (notably Blackboard and Ans) fail to render
## html-<pre> environments properly
fix_pre_lines <- function(x, sep = "<br/>") {
pre_start <- grep("(<pre>)|(<pre )", x)
x[pre_start] <- gsub("<pre [^>]*>", "<pre>", x[pre_start])
pre_end <- grep("</pre>", x, fixed = TRUE)
if(length(pre_start) > 0L) {
pndc <- any(grepl("<code>", x[pre_start]))
for(i in seq_along(pre_start)) {
pre_start_i <- pre_start[i] + 1L - pndc
pre_end_i <- pre_end[i] - 2L *(1L - pndc)
if(pre_end_i >= pre_start_i) x[pre_start_i:pre_end_i] <- paste0(x[pre_start_i:pre_end_i], sep)
}
x[pre_start] <- gsub("<code>", "", x[pre_start], fixed = TRUE)
x[pre_end] <- gsub("</code>", "", x[pre_end], fixed = TRUE)
x[pre_start] <- gsub("<pre>", paste0("<pre><code style=\"font-family: \'courier\';\">", if(pndc) " "), x[pre_start], fixed = TRUE)
x[pre_end] <- gsub("</pre>", "</code></pre>", x[pre_end], fixed = TRUE)
}
return(x)
}
## set evaluation type and case for evaluating string answer of Fill in the Blank
## below, x is x$metainfo$evaltype, and y x$metainfo$usecase. Exercise should have these in metainfo
string_evaltype <- function(x, y) {
if(is.null(x)) type <- "CONTAINS" else{
type <- switch(x,
"contains" = "CONTAINS",
"pattern" = "MATCHES",
"exact" = "EXACT"
)
}
if(is.null(y) | type == "MATCHES") case <- "No" else{
case <- ifelse(y, "Yes", "No")
}
c(type, case)
}
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.