R/make_QCM.R

In Guillaume-Lombardo/rQCM: Créer des QCM

#' selection_questions
#'
#' Part d'une liste de questions (au bon format) et renvoie une selection
#' de `nb_question` questions qui correspondent aux tag de `tag_filter`
#'
#' @param db une list de list de character avec les champs question, correct, wrong, tag
#' @param tag_filter character vector de tag
#' @param nb_question nombre de question a retourner (limiter par le nombre de questions valides trouvees)
#'
#' @return selection of question material
#' @export
selection_questions <- function(db, tag_filter, nb_question) {
  if (!'list' %in% class(db)) stop('error : db doit etre une liste')
  if (!'character' %in% class(tag_filter)) stop('error : tag_filter doit etre un vecteur de character')

  db %>%
    .[purrr::map_lgl(., function(.y) all(purrr::map_lgl(tag_filter,function(.x) grepl(.x, .y[['tag']]))))] %>%
    .[1:min(nb_question, length(.))]
}

#' make_question
#'
#' Part d'une list de question (au bon format) et renvoi un data.frame avec une colonne pour la question et ses reponse et une colonne pour la signature de la question
#'
#' @param question un character
#' @param correct une list de character
#' @param wrong une list de character
#' @param nb_correct un entier (nombre de reponses correctes)
#' @param nb_choice un entier (nombre de reponses totales)
#'
#' @return use question material to create a question
#' @export
make_question <- function(question, correct, wrong, nb_correct, nb_choice) {

  if (!'list' %in% class(correct) && any(purrr::map_lgl(correct, ~!'character' %in% class(.x)))) stop('erreur : correct doit etre une liste d\'element de type character')
  if (!'list' %in% class(wrong) && any(purrr::map_lgl(wrong, ~!'character' %in% class(.x)))) stop('erreur : wrong doit etre une liste d\'element de type character')
  if (nb_correct > nb_choice) stop('erreur : nb_correct doit etre inferieur a nb_choice')

  shuffle <- sample(1:nb_choice, nb_choice)

  choices <- c(correct[sample(1:length(correct), min(nb_correct, length(correct)))],
               wrong[sample(1:length(wrong), min(nb_choice - nb_correct, length(wrong)))]) %>%
    .[shuffle] %>%
    purrr::set_names(LETTERS[1:length(.)]) %>%
    purrr::imap(~ paste0(.y, ' : ', .x))

  textes <- choices %>% purrr::map_chr(~.x) %>% c(question, .) %>% paste0(collapse = '\n\n')

  correct_answer <- c(rep(TRUE, nb_correct),
                      rep(FALSE, nb_choice - nb_correct)) %>%
    .[shuffle] %>%
    which %>%
    LETTERS[.] %>%
    paste0(collapse = '') %>%
    list(signatures = .)

  data.frame(c(list(question = question), choices, correct_answer, list(textes = textes)), stringsAsFactors = FALSE)
}

#' make_QCM
#'
#' creer un triplet rmd_document (un string qui correspond au Rmd a produire), signatures (les reponses correctes du encrypte par safer), pssword le mot de passe pour decrypter le questionnaire.
#'
#' @param questions une list de list de questions (au bon format)
#' @param output character vector de format de sorties
#' @param qcm_title character un titre pour le QCM
#' @param qcm_author character un titre pour le QCM
#' @param qcm_date une date pour le QCM
#' @param max_correct integer maximum number of right anwsers
#' @param max_choice integer maximum number of anwsers
#' @param psswrd character un mot de passe pour chiffrer le bonnes reponses
#' @param consigne character un texte de consigne à mettre au début du document
#'
#' @return make a rmd document from questions data base
#' @export
make_QCM <- function(questions, output = c('html_document'), qcm_title = NULL, qcm_author = NULL, qcm_date = NULL, max_correct = 1, max_choice = 4, psswrd = 'mot de passe', consigne = NULL) {

  yaml_content <- c(ifelse(is.null(qcm_title),'',paste0('title: "', qcm_title,'"')),
                    ifelse(is.null(qcm_author),'',paste0('author: "', qcm_author,'"')),
                    ifelse(is.null(qcm_date),'',paste0('date: "', qcm_date,'"')),
                    'output:',
                    dplyr::case_when(output == 'html_document' ~ '  html_document: default',
                                     output == 'ioslides_presentation' ~ '  ioslides_presentation: default',
                                     output == 'pdf_document' ~ '  pdf_document: default',
                                     TRUE ~ '  html_document: default')) %>%
    .[nchar(.) > 0]

  dtqcm <- questions %>%
    purrr::map_dfr(~make_question(question = .x[['question']],
                                  correct = .x[['correct']], wrong = .x[['wrong']],
                                  nb_correct = min(max_correct, max_choice, length(.x[['correct']])),
                                  nb_choice = min(max_choice, min(max(max_correct, max_choice), length(.x[['correct']]) + length(.x[['wrong']])))))

  signatures <- dtqcm[['signatures']] %>% paste0(collapse = '|') %>% safer::encrypt_string(string = ., key = psswrd)

  yaml_header <- paste0(c('---', yaml_content, '---', '\n\n\n\n'), collapse = '\n')
  qcm_body <- dtqcm[['textes']] %>% paste0('## Question ', seq_along(.), ' :\n\n', ., collapse = '\n\n\n')
  rmd_document <- paste0(yaml_header, ifelse(is.null(consigne), '', consigne), qcm_body, paste0('\n\n\n\nsignature : `', signatures, '`\n\n ```{r, echo = FALSE, message = FALSE, warning = FALSE}\n library(qrcode)\n qrcode::qrcode_gen(dataString = \'',signatures,'\')\n```\n\n'), collapse = '\n\n')

  list(rmd_document = rmd_document, signatures = signatures, psswrd = psswrd)
}

#' produce_QCM
#'
#' @param qcm_material list avec 3 composantes : rmd_document, signature, psswrd
#' @param keep_rmd boolean keep Rmd after rendering
#' @param keep_psswrd write a text file containing the password
#' @param keep_signatures write a text file containing the signatures
#' @param destination directory path for grenrating the MCQ
#' @param qcm_name debut du nom du fichier
#'
#' @return generate the output (html, pdf, ...)
#' @export
produce_QCM <- function(qcm_material, keep_rmd = FALSE, keep_psswrd = TRUE, keep_signatures = TRUE, destination = NULL, qcm_name = paste0('QCM_', Sys.Date(), '_')) {
  temp_dir <- ifelse(is.null(destination), tempdir(), destination)
  temp_rmd <- tempfile(pattern = qcm_name, tmpdir = temp_dir, fileext = '.Rmd')

  writeLines(text = qcm_material[['rmd_document']], con = file(description = temp_rmd, encoding = 'UTF-8'))


  rmarkdown::render(temp_rmd, output_format = 'all', clean = TRUE, encoding = 'UTF-8')

  if (!keep_rmd) unlink(temp_rmd)
  if (keep_psswrd) {
    fcon <- file(file.path(temp_dir, paste0(qcm_name, 'psswrd.txt')))
    writeLines(text = qcm_material[['psswrd']], con = fcon)
    close(fcon)
  }
  if (keep_signatures) {
    fcon <- file(file.path(temp_dir, paste0(qcm_name, 'signatures.txt')))
    writeLines(text = qcm_material[['signatures']], con = fcon)
    close(fcon)
  }

}

#' recover_answer
#'
#' transform signatures back to good answer list
#'
#' @param signatures chararter
#' @param pssword character
#'
#' @return return the answers from the signature using a password
#' @export
recover_answer <- function(signatures, pssword = 'mot de passe') {
  safer::decrypt_string(string = signatures, key = pssword) %>%
    stringr::str_split(pattern = '\\|') %>%
    .[[1]]
}