R/check_correctness.R

In autoharp: Semi-Automatic Grading of R and Rmd Scripts

match_ttout_tfile <- function(ttout, tfileout) {
  ttout_test_names <- sapply(ttout, function(x) x$test, USE.NAMES=FALSE)
  all_results <- NULL
  
  for(ii in seq_along(tfileout)){
    tfileout_test_name <- names(tfileout)[ii]
    ttout_results <- rep(NA_character_, length(tfileout[[ii]]))
    names_ttout_results <- paste(tfileout_test_name, tfileout[[ii]], sep=".")
    names_ttout_results <- stringr::str_replace_all(names_ttout_results,  '[ ,()"]', '') 
    names(ttout_results) <- names_ttout_results
    
    ttout_id <- which(ttout_test_names == tfileout_test_name)
    if(length(ttout_id) != 0){
      ttout_results_srcref <- vapply(ttout[[ttout_id]]$results, 
                              function(x) paste0(as.character(x$srcref),
                              collapse=""),
                              FUN.VALUE = "character")
      #print(ttout_results_srcref)
      
      for(jj in seq_along(tfileout[[ii]])){
        ttout_res_id <- which(stringr::str_replace_all(ttout_results_srcref, " ", "") == stringr::str_replace_all(tfileout[[ii]][jj], " ", ""))
        if(length(ttout_res_id) > 0) {
          # take the first check result if there's more than one. e.g. with setequal
          if(length(ttout_res_id) > 1){
              ttout_res_id <- ttout_res_id[1] 
          }
          ttout_res_class <- class(ttout[[ttout_id]]$results[[ttout_res_id]])[1]
          ttout_results[jj] <- ttout_res_class
          # print(tfileout[[ii]][jj])
        }
      }
      # print(ttout[[ttout_id]]$test)
    }
    all_results <- c(all_results, ttout_results)
      
  }
  all_results
}

#' Check correctness of student solution rmd.
#'
#' This will run unit tests on the students' rmd file.
#'
#' @param e_stud The environment containing the output objects from running the
#' studnent Rmd file.
#' @param e_soln The environment containing the objects from the solution
#' template. It will probably contain objects with the suffix "_soln". These
#' will be tested against the versions generated by the student.
#' @param test_fname The R script containing the test chunks.
#' 
#' @details Prior to calling this, \code{\link{populate_soln_env}} should 
#' already have been called on the solution template, and the student 
#' file should already have been knitted in order to generate the students' 
#' objects. Of course, one could generate the test script independent of 
#' \code{\link{populate_soln_env}}, but the solution environment that contains 
#' objects with a "_soln" suffix is also needed.
#' 
#' The student environment, solution environment, test file and the list of 
#' tests and expectations are the inputs to this function.
#'
#' @return A data frame with one row, and the number of columns equal to the 
#' number of tests run plus the number of scalars to keep.
#' @export
#' 
#' @seealso \code{\link{populate_soln_env}}, \code{\link{render_one}}
#'
check_correctness <- function(e_stud, e_soln, test_fname) {

  obj_to_copy <- ls(e_soln, pattern="^\\.", all.names = TRUE)
  obj_to_copy <- setdiff(obj_to_copy, ".myfilename")
  copy_out <- sapply(obj_to_copy,
                     function(zzz) copy_e2e(zzz, e_soln, zzz, e_stud))
  # running test_file
  source(test_fname, local=e_stud)

  #test_output <- testthat::test_file(test_fname, env = e_stud, reporter = "silent")

#  if(length(test_list) > 0){
#    tt_parsed <- match_ttout_tfile(test_output, test_list)
#    #tt_parsed <- stringr::str_replace_all(tt_parsed, "expectation_", "")
#    tt_parsed <- data.frame(as.list(tt_parsed), stringsAsFactors=FALSE)
#  } else {
#    tt_parsed <- NULL
#  }
  #browser()

#  # # running ah_check_scalars
   if(".scalars_to_keep" %in% names(e_stud)) {
     scalars_out <- lapply(get(".scalars_to_keep", envir = e_stud), 
                           function(x) {
                             get0(x, envir = e_stud, ifnotfound=NA,
                                  mode=mode(get(x, e_soln)))
                           })
     scalars_out <- lapply(scalars_out, 
                    function(x){ 
                        if(is.atomic(x) && (length(x) == 1)){
                            return(x)
                        } else {
                            return(NA)
                        }
                    })
     names(scalars_out) <- e_stud$.scalars_to_keep
     scalars_out <- data.frame(scalars_out, stringsAsFactors = FALSE)
#     #outcome <- c(outcome, scalars_out)
#     outcome2 <- data.frame(t(scalars_out), stringsAsFactors = FALSE)
#     names(outcome2) <- e_stud$.scalars_to_keep
#     outcome <- dplyr::bind_cols(outcome, outcome2)
   } else {
     scalars_out <- NULL
   }
  
#  # combine if necessary
#  if(!is.null(tt_parsed) && !is.null(scalars_out)) {
#    out <- cbind(tt_parsed, scalars_out)
#  } else if(!is.null(tt_parsed)){
#    out <- tt_parsed
#  } else if(!is.null(scalars_out)) {
#    out <- scalars_out
#  } else {
#    out <- NULL
#  }
  scalars_out
#  return(outcome)
}