R/exams2tcexam.R
In exams: Automatic Generation of Exams in R

Documented in exams2tcexam

## generate exams in TCEXAM XML format
exams2tcexam <- function(file, n = 1L, nsamp = NULL, dir = ".",
  name = NULL, quiet = TRUE, edir = NULL, tdir = NULL, sdir = NULL, verbose = FALSE,
  resolution = 100, width = 4, height = 4, svg = FALSE, encoding = "UTF-8", points = NULL,
  modulename = name, subjectname = name, subjectdescription = NULL, timer = 0,
  fullscreen = FALSE, inlineanswers = FALSE, autonext = FALSE, shuffle = FALSE,
  lang = "en", date = Sys.time(), zip = FALSE, converter = NULL, ...)
{
  ## set up .html transformer
  if(any(tolower(tools::file_ext(unlist(file))) == "rmd")) {
    if(is.null(converter)) converter <- "pandoc"
  } else {
    if(is.null(converter)) converter <- "ttm"
  }
  htmltransform <- make_exercise_transform_html(converter = converter, ..., base64 = TRUE)

  ## encoding always assumed to be UTF-8 starting from R/exams 2.4-0
  if(!is.null(encoding) && !(tolower(encoding) %in% c("", "utf-8", "utf8"))) {
    warning("the only supported 'encoding' is UTF-8")
  }
  encoding <- "UTF-8"

  ## generate the exam
  exm <- xexams(file, n = n, nsamp = nsamp,
   driver = list(
       sweave = list(quiet = quiet, pdf = FALSE, png = !svg, svg = svg,
         resolution = resolution, width = width, height = height,
         encoding = encoding),
       read = NULL, transform = htmltransform, write = NULL),
     dir = dir, edir = edir, tdir = tdir, sdir = sdir, verbose = verbose)

  ## 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)

  ## create a name
  if(is.null(name)) name <- "tcexam-module"
  if(is.null(modulename)) modulename <- name
  if(is.null(subjectname)) subjectname <- name
  if(is.null(subjectdescription)) subjectdescription <- "tcexam subject generated by R/exams"

  ## create the directory where the test is stored
  dir.create(test_dir <- file.path(file_path_as_absolute(tdir), name))

  ## number of exams and questions
  nx <- length(exm)
  nq <- length(exm[[1L]])

  ## points setting
  if(!is.null(points))
    points <- rep(points, length.out = nq)

  ## encoding (legacy code handling non-UTF-8 encodings)
  enc <- gsub("-", "", tolower(encoding), fixed = TRUE)
  if(enc %in% c("iso8859", "iso88591")) enc <- "latin1"
  if(enc == "iso885915") enc <- "latin9"
  charset <- encoding
  if(enc == "utf8")
    charset <- "UTF-8"
  if(enc == "latin1")
    charset <- "ISO-8859-1"
  if(enc == "latin9")
    charset <- "ISO-8859-15"

  ## header of the .xml file
  xml <- c(
    sprintf('<?xml version="1.0" encoding="%s" ?>', charset),
            '<tcexamquestions version="1.0">\n',
    sprintf('<header lang="%s" date="%s">', lang, date),
            '</header>\n',
            '<body>',
            '<module>',
    sprintf('  <name>%s</name>', modulename),
            '  <enabled>true</enabled>\n',
            '  <subject>\n',
    sprintf('    <name>%s</name>', subjectname),
    sprintf('    <description>%s</description>', subjectdescription),
            '    <enabled>true</enabled>\n'
  )

  ## cycle through all questions and samples
  tcexamquestion <- make_question_tcexam(timer = timer, fullscreen = fullscreen,
    inlineanswers = inlineanswers, autonext = autonext, shuffle = shuffle)
  xml <- c(xml, unlist(lapply(1L:nq, function(j)
    unlist(lapply(1L:nx, function(i) tcexamquestion(exm[[i]][[j]], position = j, points = points[j])))
  )))

  ## footer of the .xml file
  xml <- c(xml,
           '  </subject>\n',
           '</module>',
	   '</body>\n',
	   '</tcexamquestions>\n'
  )


  ## write to dir
  writeLines(xml, file.path(test_dir, paste(name, "xml", sep = ".")))

  ## compress
  if(zip) {
    owd <- getwd()
    setwd(test_dir)
    zip(zipfile = zipname <- paste(name, "zip", sep = "."), files = list.files(test_dir))
    setwd(owd)
  } else zipname <- list.files(test_dir)

  ## copy the final .zip file
  file.copy(file.path(test_dir, zipname), dir, recursive = TRUE)

  invisible(exm)
}

fix_html_tcexam <- function(x, collapse = " ")
{
  ## collapse <pre>-formatted code
  pre1 <- grep("<pre>", x, fixed = TRUE)
  pre2 <- grep("</pre>", x, fixed = TRUE)
  if(length(pre1) != length(pre2)) warning("cannot properly fix <pre> tags")
  if(length(pre1) > 0L) {
    for(i in length(pre1):1L) {
      p1 <- pre1[i]
      p2 <- pre2[i]
      if(p2 > p1) {
        x[p1] <- paste(x[p1:p2], collapse = "\n")
	x <- x[-((p1 + 1L):p2)]
      }
    }
  }
    
  ## collapse everything else
  x <- paste(x, collapse = collapse)

  ## fix up HTML formatting for TCExam
  fix <- rbind(
    c("<i>", "[i]"),
    c("</i>", "[/i]"),
    c("<em>", "[i]"),
    c("</em>", "[/i]"),
    c("<b>", "[b]"),
    c("</b>", "[/b]"),
    c("<strong>", "[b]"),
    c("</strong>", "[/b]"),
    c("<u>", "[u]"),
    c("</u>", "[/u]"),
    c("<ul>", "[ulist]"),
    c("</ul>", "[/ulist]"),
    c("<ol>", "[olist]"),
    c("</ol>", "[/olist]"),
    c("<li>", "[li]"),
    c("</li>", "[/li]"),
    c("<code>", ""), ## FIXME
    c("</code>", ""),
    c("<pre>", "[code]"),
    c("</pre>", "[/code]"),
    c("<table", "[html]<table"),
    c("</table>", "</table>[/html]"),
    c("<h1>", "[html]<h1>"),
    c("</h1>", "</h1>[/html]"),
    c("<h2>", "[html]<h2>"),
    c("</h2>", "</h2>[/html]"),
    c("<h3>", "[html]<h3>"),
    c("</h3>", "</h3>[/html]"),
    c("&nbsp;", " "),
    c("<p>", ""),
    c("</p>", "\n"),
    c("<br/>", "\n"),
    c("<br />", "\n"),
    c("<math ", "[mathml]<math "),
    c("</math>", "</math>[/mathml]"),
    c("<img", "[html]<img"),
    c("/>", "/>[/html]"),
    c("<div class=\"p\"><!----></div>", "\n"),
    c("<div style=\"text-align:center\">", "\n"),
    c("</div>", ""),
    c("<span>", " "),
    c("</span>", " "),
    c("&", "&amp;"),
    c("<", "&lt;"),
    c(">", "&gt;"),
    c("&amp;#", "&#")
  )
  for(i in 1:nrow(fix)) x <- gsub(fix[i,1], fix[i,2], x, fixed = TRUE)

  return(x)
}

## tcexam question constructor function
make_question_tcexam <- function(timer = 0, fullscreen = FALSE,
  inlineanswers = FALSE, autonext = FALSE, shuffle = FALSE)
{
  function(x, points = NULL, position = 1L) {
    ## how many points?
    if(is.null(points)) points <- x$metainfo$points
    if(is.null(points)) points <- 1L

    ## match question type
    type <- switch(x$metainfo$type,
      "num" = "text",
      "mchoice" = "multiple",
      "schoice" = "single",
      "cloze" = "cloze",
      "string" = "text"
    )
    if(type == "cloze") stop("extype 'cloze' is not supported by tcexam")

    ## start the question xml
    xml <- c(
              '',
              '<question>',
	      '  <enabled>true</enabled>',
      sprintf('  <type>%s</type>', type),
      sprintf('  <difficulty>%s</difficulty>', points),
      sprintf('  <position>%s</position>', position),
      sprintf('  <timer>%s</timer>', timer),
      sprintf('  <fullscreen>%s</fullscreen>', tolower(as.character(fullscreen))),
      sprintf('  <inline_answers>%s</inline_answers>', tolower(as.character(inlineanswers))),
      sprintf('  <auto_next>%s</auto_next>', tolower(as.character(autonext))),
      sprintf('  <description>%s</description>', fix_html_tcexam(x$question)),
              '  <explanation></explanation>'
    )

    ## add questionlist (if any)
    answer_xml <- function(question, solution, position) c(
              '',
              '  <answer>',
	      '    <enabled>true</enabled>',
      sprintf('    <isright>%s</isright>', tolower(as.character(solution))),
      sprintf('    <position>%s</position>', position),
	      '    <keyboard_key></keyboard_key>',
      sprintf('    <description>%s</description>', question),
              '    <explanation></explanation>',
              '  </answer>'
    )
    if(type %in% c("single", "multiple")) {
      answerlist <- lapply(seq_along(x$questionlist), function(i)
        answer_xml(question = fix_html_tcexam(x$questionlist[i]), solution = x$metainfo$solution[i], position = if(shuffle) "" else i))
      xml <- c(xml, unlist(answerlist))
    }
	      
    ## end the question xml
    xml <- c(xml, '</question>\n')

    ## return with some padding
    xml <- paste0('    ', xml)
    xml
  }
}