(.*?)
", "\\1", html) #remove tags, coded by front end.
36 | }
37 |
--------------------------------------------------------------------------------
/R/rstudio-test-chunk-options.R:
--------------------------------------------------------------------------------
1 | #' Check whether the student defined the correct chunk options (R Markdown
2 | #' exercises)
3 | #'
4 | #' Check whether the student defined the correct chunk options in an R Markdown
5 | #' exercise
6 | #'
7 | #' This test can only be called inside a test_rmd_group() call!
8 | #'
9 | #' @param options Set of options
10 | #' @param not_called_msg feedback message if option was not specified
11 | #' @param incorrect_msg feedback message if option was incorrectly set
12 | #' @keywords internal
13 | test_chunk_options <- function(options = NULL,
14 | not_called_msg = NULL,
15 | incorrect_msg = NULL) {
16 | fail_if_v2_only()
17 | state <- ex()
18 | chunk_number <- state$get("chunk_number")
19 | student_chunk <- state$get("student_ds_part")
20 | solution_chunk <- state$get("solution_ds_part")
21 |
22 | # First, check if both student and solution chunk are 'block' class (i.e. code chunks)
23 | if (class(solution_chunk) != "block") {
24 | stop("The specified rmd group is not of 'block' class.")
25 | }
26 |
27 | check_that(is_equal(class(student_chunk), "block"), "Wrong class student chunk")
28 |
29 | sol_options <- solution_chunk$params
30 | stud_options <- student_chunk$params
31 |
32 | if (is.null(options)) {
33 | options <- names(sol_options)
34 | if (length(options) == 0) {
35 | return(TRUE)
36 | }
37 | }
38 |
39 | # Set up default messages
40 | # message if specified function was not called
41 | if (is.null(not_called_msg)) {
42 | not_called_msg = sprintf("Code chunk %i of your submission should contain the option%s %s.",
43 | chunk_number, if (length(options) == 1) "" else "s", collapse_props(options))
44 | }
45 |
46 | # message if the properties or not found or set incorrectly
47 | if (is.null(incorrect_msg)) {
48 | incorrect_msg = sprintf("In code chunk %i of your submission, make sure to correctly define the option%s %s.",
49 | chunk_number, if (length(options) == 1) "" else "s", collapse_props(options))
50 | }
51 |
52 | # select from sol_options and stud_props the ones to check on
53 | #
54 | # reverse the list, because in case options are defined multiple times,
55 | # the last options are the ones that are seen as valid by RMarkdown
56 | sol_options_select = rev(sol_options)[options]
57 | stud_options_select = rev(stud_options)[options]
58 | if (any(is.na(names(sol_options_select)))) {
59 | stop(sprintf("You defined options that are not in code chunk %i of the solution", chunk_number))
60 | }
61 |
62 | no_nas <- any(is.na(names(stud_options_select)))
63 | # check if all options available
64 | check_that(is_false(no_nas), not_called_msg)
65 |
66 |
67 | # check the equality of stud and solution options.
68 | if (!no_nas) {
69 | check_that(is_equal(sol_options_select, stud_options_select), incorrect_msg)
70 | }
71 | }
72 |
73 |
--------------------------------------------------------------------------------
/R/rstudio-test-pipe.R:
--------------------------------------------------------------------------------
1 | #' Check whether a student used the pipe operator sufficiently (ggvis and dplyr exercises)
2 | #'
3 | #' Check whether a student used the pipe sufficiently. By default, the function only checks if
4 | #' the pipe was used at least once. The user can also select the minimal
5 | #' number of occurrences of the pipe.
6 | #'
7 | #' @param num minimal number of times the pipe operator has to appear (default = 1)
8 | #' @param absent_msg feedback message in case the student did not use a single pipe.
9 | #' @param insuf_msg feeback message in case the student did not use the pipe operator sufficiently.
10 | #' @keywords internal
11 | test_pipe <- function(num = 1, absent_msg = NULL, insuf_msg = NULL) {
12 | fail_if_v2_only()
13 | if (is.null(insuf_msg)) {
14 | insuf_msg = sprintf("You should use the pipe operator at least %i times in total in your solution code",num)
15 | }
16 | ex() %>% check_code(regex = "%>%", times = num, missing_msg = insuf_msg)
17 | }
18 |
--------------------------------------------------------------------------------
/R/rstudio-test-rmd-group.R:
--------------------------------------------------------------------------------
1 | #' Test a single R Markdown file group (R Markdown exercises)
2 | #'
3 | #' Test a single R Markdown file group (R Markdown exercises) with arbitrary testwhat functions.
4 | #'
5 | #' @param group_number Number of the group.
6 | #' @param code SCT code to test the group (in curly braces)
7 | #' @keywords internal
8 | test_rmd_group <- function(group_number, code) {
9 | fail_if_v2_only()
10 | old_state <- ex()
11 | on.exit(tw$set(state = old_state))
12 | test_env <- old_state$get("test_env")
13 | tw$set(state = get_rmd_group(old_state, group_number))
14 | eval(substitute(code), envir = test_env)
15 | }
16 |
17 | get_rmd_group <- function(state, group_number) {
18 | student_code <- state$get("student_code")
19 | solution_code <- state$get("solution_code")
20 |
21 | group_state <- MarkdownState$new(state)
22 | group_state <- parse_docs(group_state)
23 |
24 | solution_ds <- group_state$get("solution_ds")
25 | student_ds <- group_state$get("student_ds")
26 |
27 | if (group_number > length(solution_ds)) {
28 | stop(sprintf("Invalid group_number (%s), while solution contains only %s parts",
29 | group_number,length(solution_ds)))
30 | }
31 |
32 | student_ds_part <- student_ds[[group_number]]
33 | solution_ds_part <- solution_ds[[group_number]]
34 | group_state$set(student_ds_part = student_ds_part,
35 | solution_ds_part = solution_ds_part,
36 | student_code = student_ds_part$input,
37 | solution_code = solution_ds_part$input)
38 |
39 | # set numbers, to be used in default messages of tests
40 | if (class(student_ds_part) == "block") {
41 | group_state$set(chunk_number = group_number - sum(sapply(student_ds[1:group_number],class) == "inline"),
42 | student_pd = build_pd(student_ds_part$input),
43 | solution_pd = build_pd(solution_ds_part$input))
44 | } else if (class(student_ds_part) == "inline") {
45 | group_state$set(inline_number = group_number - sum(sapply(student_ds[1:group_number],class) == "block"))
46 | }
47 | return(group_state)
48 | }
49 |
50 |
--------------------------------------------------------------------------------
/R/rstudio-test-text.R:
--------------------------------------------------------------------------------
1 | #' Test inline text and formatting (Markdown)
2 | #'
3 | #' Test inline text and its formatting for R Markdown exercises.
4 | #' This test can only be called inside a test_rmd_group() call!
5 | #'
6 | #' @param text Text to match (can be a regular expression!)
7 | #' @param format the format of the text that the text should be in ("any", "italics", "bold", "code", "inline_code", "brackets", "parentheses", "list").
8 | #' If none of the above, the format string is appended to text in front and in the back and used as a regexp.
9 | #' @param freq How often the text should appear with this formatting
10 | #' @param not_called_msg feedback message if the text was not there
11 | #' @param incorrect_msg feedback message if the text was not properly formatted
12 | #'
13 | #' @keywords internal
14 | test_text <- function(text,
15 | format = "any",
16 | freq = 1,
17 | not_called_msg = NULL,
18 | incorrect_msg = NULL) {
19 | state <- ex()
20 | inline_number <- state$get("inline_number")
21 | student_inline <- state$get("student_ds_part")
22 | solution_inline <- state$get("solution_ds_part")
23 |
24 | # First, check if both student and solution chunk are 'inline' class
25 | if(class(solution_inline) != "inline") {
26 | stop("The specified rmd group is not of 'inline' class.")
27 | }
28 | check_that(is_equal(class(student_inline), "inline"),
29 | feedback = "The student rmd group is not inline!")
30 |
31 | # Set up default messages
32 | # message if text was not found
33 | if(is.null(not_called_msg)) {
34 | not_called_msg = sprintf("Inline group %i of your submission should contain the text \"%s\".",
35 | inline_number, text)
36 | }
37 |
38 | # message if the properties or not found or set incorrectly
39 | if(is.null(incorrect_msg)) {
40 | incorrect_msg = sprintf("In inline group %i of your submission, make sure to correctly format the text \"%s\".",
41 | inline_number, text)
42 | }
43 |
44 | # first, check if text is found in student_inline
45 | hits <- gregexpr(pattern = text, student_inline$input)[[1]]
46 | check_that(is_false(hits[1] == -1), feedback = not_called_msg)
47 | check_that(is_gte(length(hits), freq), feedback = not_called_msg)
48 |
49 | if(hits[1] == -1 || length(hits) < freq) {
50 | return(FALSE)
51 | }
52 |
53 | patt <- text;
54 | for(i in seq_along(format)) {
55 | if(format[i] == "any") return(TRUE)
56 | else if(format[i] == "italics") patt <- paste0("((\\*",patt,"\\*)|(_",patt,"_))")
57 | else if(format[i] == "bold") patt <- paste0("((\\*{2}",patt,"\\*{2})|(_{2}",patt,"_{2}))")
58 | else if(format[i] == "code") patt <- paste0("`",patt,"`")
59 | else if(format[i] == "inline_code") patt <- paste0("`r\\s*",patt,"`")
60 | else if(format[i] == "brackets") patt <- paste0("\\[",patt,"\\]")
61 | else if(format[i] == "parentheses") patt <- paste0("\\(",patt,"\\)")
62 | else if(format[i] == "list") patt <- paste0("[-\\*]\\s*",patt)
63 | else patt <- paste0(format[i],patt,format[i])
64 | }
65 |
66 | hits = gregexpr(pattern = patt, student_inline$input)[[1]]
67 | check_that(is_false(hits[1] == -1), feedback = incorrect_msg)
68 | check_that(is_gte(length(hits), freq), feedback = not_called_msg)
69 | }
70 |
--------------------------------------------------------------------------------
/R/rstudio-test-yaml-header.R:
--------------------------------------------------------------------------------
1 | #' Check yaml header (Markdown)
2 | #'
3 | #' Check whether the student specified the correct options in the yaml header (for
4 | #' R Markdown exercises). This test should be called outside an test_rmd_group call.
5 | #'
6 | #' @param options Set of options. Embedded options have to be specified using the dot notation.
7 | #' @param check_equality whether or not to actually check the value assigned to the option (default TRUE)
8 | #' @param not_called_msg feedback message if option was not specified (optional but recommended)
9 | #' @param incorrect_msg feedback message if option was incorrectly set (optional but recommended)
10 | #' @keywords internal
11 | test_yaml_header <- function(options = NULL,
12 | check_equality = TRUE,
13 | not_called_msg = NULL,
14 | incorrect_msg = NULL) {
15 | fail_if_v2_only()
16 | state <- ex()
17 | chunk_number <- state$get("chunk_number")
18 | student_code <- state$get("student_code")
19 | solution_code <- state$get("solution_code")
20 |
21 | yaml_solution <- try(unlist(rmarkdown:::parse_yaml_front_matter(strsplit(solution_code, split = "\n")[[1]])), silent = TRUE)
22 | if(inherits(yaml_solution, "try-error")) {
23 | stop("Something wrong with yaml header of solution code!")
24 | }
25 |
26 | yaml_student <- try(unlist(rmarkdown:::parse_yaml_front_matter(strsplit(student_code, split = "\n")[[1]])), silent = TRUE)
27 | check_that(is_false(inherits(yaml_student, "try-error")),
28 | feedback = "Make sure the YAML header contains no errors. Beware of erroneous indentation.")
29 |
30 | if(is.null(options)) {
31 | options <- names(yaml_solution)
32 | if(length(options) == 0) {
33 | return(TRUE)
34 | }
35 | }
36 |
37 | # Set up default messages
38 | # message if specified function was not called
39 | if(is.null(not_called_msg)) {
40 | not_called_msg <- sprintf("The YAML header of your submission should contain the option%s %s.",
41 | if(length(options) == 1) "" else "s", collapse_props(options))
42 | }
43 |
44 | # message if the properties are not found or set incorrectly
45 | if(is.null(incorrect_msg)) {
46 | incorrect_msg = sprintf("In your YAML header, correctly define the option%s %s.",
47 | if(length(options) == 1) "" else "s", collapse_props(options))
48 | }
49 |
50 | # select from sol_options and stud_props the ones to check on
51 | sol_options_select = yaml_solution[options]
52 | stud_options_select = yaml_student[options]
53 | if(any(is.na(names(sol_options_select)))) {
54 | stop(sprintf("You want to test on yaml options that are not in the solution's yaml header", chunk_number))
55 | }
56 |
57 | no_nas = any(is.na(names(stud_options_select)))
58 | # check if all options available
59 | check_that(is_false(no_nas), feedback = not_called_msg)
60 |
61 | if(!no_nas && check_equality) {
62 | check_that(is_equal(sol_options_select, stud_options_select), feedback = incorrect_msg)
63 | }
64 | }
65 |
--------------------------------------------------------------------------------
/R/success-msg.R:
--------------------------------------------------------------------------------
1 | #' Define the success message
2 | #'
3 | #' If all tests in an SCT pass, the student is presented with a
4 | #' congratulatory message. You can specify this message with
5 | #' /code{success_msg()}. It does not matter where in the SCT
6 | #' you specify this message, but at the end makes most sense.
7 | #'
8 | #' For multiple choice exercises, the success message is specified
9 | #' inside \code{\link{check_mc}}, so an additional call of \code{success_msg}
10 | #' is not necessary.
11 | #'
12 | #' @param msg The success message as a character string.
13 | #' @param praise Whether or not to prepend a message of praise from the \code{praise} package.
14 | #'
15 | #' @export
16 | #' @importFrom praise praise
17 | success_msg <- function(msg, praise = FALSE) {
18 | if (isTRUE(praise)) {
19 | msg <- paste(praise::praise(), msg)
20 | }
21 | tw$set(success_msg = capitalize(trim(msg)))
22 | }
23 |
--------------------------------------------------------------------------------
/R/test-exercise.R:
--------------------------------------------------------------------------------
1 | #' Run all tests for an exercise
2 | #'
3 | #' Run all tests for an exercise and report the results (including feedback).
4 | #' This function is run by R Backend and should not be used by course creators.
5 | #'
6 | #' @param sct Submission correctness tests as a character string.
7 | #' @param ex_type Type of the exercise
8 | #' @param pec pre-exercise-code
9 | #' @param student_code character string representing the student code
10 | #' @param solution_code character string representing the solution code
11 | #' @param student_env environment containing the objects defined by the student.
12 | #' @param solution_env environment containing the objects defined by solution code
13 | #' @param output_list the output structure that is generated by RBackend
14 | #' @param allow_errors whether or not errors are allowed by RBackend (FALSE by default)
15 | #' @param force_diagnose whether diagnose tests have to pass even if the checks pass (FALSE by default)
16 | #' @param seed random seed that is used for SCTs that run expressions (42 by default).
17 | #'
18 | #' @return A list with components \code{passed} that indicates whether all
19 | #' tests were sucessful, and \code{feedback} that contains a feedback message.
20 | #'
21 | #' @export
22 | test_exercise <- function(sct,
23 | ex_type,
24 | pec,
25 | student_code,
26 | solution_code,
27 | student_env,
28 | solution_env,
29 | output_list,
30 | allow_errors = FALSE,
31 | force_diagnose = FALSE,
32 | seed = 42) {
33 | # backwards compatibility with older versions of RBackend
34 | if (missing(student_env)) {
35 | student_env <- globalenv()
36 | }
37 |
38 | # First check if parsing worked out
39 | if (any(sapply(output_list, `[[`, "type") == "parse-error")) {
40 | report <- tryCatch(do_parse(student_code),
41 | error = function(e) {
42 | list(message = parse_fallback_msg)
43 | })
44 | return(c(list(correct = FALSE), report))
45 | } else {
46 | # Store everything that's needed locally (initialize does a full reset)
47 | tw$clear()
48 | tw$set(success_msg = sample(c("Good Job!", "Well done!", "Great work!"), 1))
49 | state <- RootState$new(pec = pec,
50 | student_code = student_code,
51 | student_pd = build_pd(student_code),
52 | student_env = student_env,
53 | solution_code = solution_code,
54 | solution_pd = build_pd(solution_code),
55 | solution_env = solution_env,
56 | output_list = output_list,
57 | test_env = new.env(parent = environment()),
58 | force_diagnose = force_diagnose)
59 | tw$set(state = state,
60 | stack = TRUE,
61 | seed = seed)
62 | on.exit(tw$clear())
63 |
64 | # Execute sct with the DataCamp reporter such that it collects test results
65 | res <- run_until_fail(parse(text = sct))
66 |
67 | # If the SCT passed, check whether there is an error as the last step
68 | if (isTRUE(res$correct) && !allow_errors) {
69 | res <- run_until_fail(ex() %>% check_error())
70 | }
71 |
72 | return(post_process(res, ex_type))
73 | }
74 | }
75 |
76 | #' Run SCT until it fails
77 | #'
78 | #' @param code the SCT script to run as an expression
79 | #'
80 | #' @export
81 | run_until_fail <- function(code) {
82 | tryCatch({
83 | # Run the SCT
84 | eval(code, envir = tw$get("state")$get("test_env"))
85 | # If it got here, the SCT passed
86 | return(list(correct = TRUE, message = tw$get("success_msg")))
87 | }, sct_failure = function(e) {
88 | return(list(correct = FALSE,
89 | message = e$message,
90 | feedback = attr(e, "feedback")))
91 | })
92 | }
93 |
94 |
95 | post_process <- function(res, ex_type) {
96 | # convert to HTML
97 | res$message <- to_html(res$message)
98 |
99 | # Only add line info if:
100 | # - message is incorrect, and
101 | # - exercise is not markdown / rcpp (post-processing of code chunks gives strange things)
102 | if (!res$correct && !(ex_type %in% c("MarkdownExercise", "RCppExercise"))) {
103 | line_info <- get_line_info(res$feedback)
104 | if (!is.null(line_info)) {
105 | res <- c(res, line_info)
106 | }
107 | }
108 | res$feedback <- NULL
109 | return(res)
110 | }
--------------------------------------------------------------------------------
/R/test_an_object.R:
--------------------------------------------------------------------------------
1 | # Deprecated
2 |
3 | test_an_object <- function(name,
4 | undefined_msg = NULL,
5 | eq_condition = "equivalent") {
6 | fail_if_v2_only()
7 |
8 | # Get needed elements from tw
9 | student_env <- ex()$get("student_env")
10 | solution_env <- ex()$get("solution_env")
11 |
12 | if (is.null(undefined_msg)) {
13 | # Avoid returning this message, always set undefined_msg
14 | undefined_msg <- "There is some object missing in your code."
15 | }
16 |
17 | check_defined(name, solution_env)
18 | solution <- get(name, envir = solution_env, inherits = FALSE)
19 |
20 | valid_values <- list()
21 | length(valid_values) <- length(ls(student_env))
22 |
23 | counter <- 1
24 | for (student_var in ls(student_env)) {
25 | student_value <- get(student_var, envir = student_env, inherits = FALSE)
26 | if (identical(class(student_value), class(solution))) {
27 | valid_values[[counter]] <- student_value
28 | counter <- counter + 1
29 | }
30 | }
31 |
32 | if (counter > 1) {
33 | correct <- vapply(valid_values[1:counter-1], function(x) { is_equal(x, solution, eq_condition) }, logical(1))
34 | } else {
35 | correct <- FALSE
36 | }
37 |
38 | check_that(is_true(any(correct)), feedback = undefined_msg)
39 | }
--------------------------------------------------------------------------------
/R/utils-control.R:
--------------------------------------------------------------------------------
1 | #' @importFrom utils getParseText
2 | extract_control <- function(pd, keyword, elnames) {
3 | if(any(pd$token == keyword)) {
4 | # Intersection of parent of ids with the correct keyword WITH
5 | # ids that are top-level (whose parent is not in pd) OR
6 | # ids of children of top-level parents that have curly brackets
7 | parents <- pd$parent[pd$token == keyword]
8 | top_level_ids <- pd$id[!(pd$parent %in% pd$id)]
9 | top_level_ids_with_curly_brackets <- pd$id[grepl("^\\s*\\{.*?\\}\\s*$", pd$text) & pd$id %in% top_level_ids]
10 | children_of_curly_brackets <- pd$id[pd$parent %in% top_level_ids_with_curly_brackets]
11 | ids <- base::intersect(parents, c(top_level_ids, children_of_curly_brackets))
12 |
13 | chop_up_pd <- function(id, elnames) {
14 | expr_ids <- pd$id[pd$parent == id & pd$token %in% c("expr", "forcond")]
15 | sub_codes <- lapply(expr_ids, getParseText, parseData = pd)
16 | sub_pds <- lapply(expr_ids, get_sub_pd, pd = pd)
17 | out <- mapply(function(code, pd) list(code = code, pd = pd), sub_codes, sub_pds, SIMPLIFY = FALSE)
18 | names(out) <- elnames[1:length(out)]
19 | out
20 | }
21 |
22 | lapply(ids, chop_up_pd, elnames = elnames)
23 | } else {
24 | return(list())
25 | }
26 | }
27 |
28 | extract_if <- function(pd) {
29 | extract_control(pd, keyword = "IF", elnames = c("cond_part", "if_part", "else_part"))
30 | }
31 |
32 | extract_for <- function(pd) {
33 | extract_control(pd, keyword = "FOR", elnames = c("cond_part", "expr_part"))
34 | }
35 |
36 | extract_while <- function(pd) {
37 | extract_control(pd, keyword = "WHILE", elnames = c("cond_part", "expr_part"))
38 | }
39 |
40 |
41 |
--------------------------------------------------------------------------------
/R/utils-learnr.R:
--------------------------------------------------------------------------------
1 | #' A checker function to use with learnr
2 | #'
3 | #' For exercise checking, learnr tutorials require a function that learnr can
4 | #' use in the background to run the code in each "-check" chunk and to format
5 | #' the results into a format that learnr can display. The function must accept a
6 | #' specific set of inputs and return a specific type of output. Users are not
7 | #' intended to use the function themselves, but to pass it to the
8 | #' \code{exercise.checker} knitr chunk option within the setup chunk of the
9 | #' tutorial.
10 | #'
11 | #' Similar to grader's \code{grade_learnr()}, testwhat provides
12 | #' \code{testwhat_learnr()} for this purpose. To enable exercise checking in
13 | #' your learnr tutorial, set \code{tutorial_options(exercise.checker =
14 | #' testwhat_learnr)} in the setup chunk of your tutorial.
15 | #'
16 | #' @param label Label for exercise chunk
17 | #' @param solution_code R code submitted by the user
18 | #' @param user_code Code provided within the "-solution" chunk for the
19 | #' exercise.
20 | #' @param check_code Code provided within the "-check" chunk for the exercise.
21 | #' @param envir_result The R environment after the execution of the chunk.
22 | #' @param evaluate_result The return value from the \code{evaluate::evaluate}
23 | #' function.
24 | #' @param ... Unused (include for compatibility with parameters to be added in
25 | #' the future)
26 | #'
27 | #' @return An R list which contains several fields indicating the result of the
28 | #' check.
29 | #' @export
30 | testwhat_learnr <- function(label = NULL,
31 | solution_code = NULL,
32 | user_code = NULL,
33 | check_code = NULL,
34 | envir_result = NULL,
35 | evaluate_result = NULL,
36 | ...) {
37 |
38 | ######### START COPY FROM grade_learnr ##################
39 | # Sometimes no user code is provided, but
40 | # that means there is nothing to check. Also,
41 | # you do not want to parse NULL
42 | if (is.null(user_code)) {
43 | return(list(
44 | message = "I didn't receive your code. Did you write any?",
45 | correct = FALSE,
46 | type = "error",
47 | location = "append"
48 | ))
49 | }
50 |
51 | # Sometimes no solution is provided, but that
52 | # means there is nothing to check against. Also,
53 | # you do not want to parse NULL
54 | if (is.null(solution_code)) {
55 | return(list(
56 | message = "No solution is provided for this exercise.",
57 | correct = TRUE,
58 | type = "info",
59 | location = "append"
60 | ))
61 | }
62 | ######### END COPY FROM grade_learnr ##################
63 |
64 | setup_state(sol_code = solution_code,
65 | stu_code = user_code,
66 | sol_env = NULL,
67 | stu_env = envir_result,
68 | stu_result = evaluate_result)
69 |
70 | res <- run_until_fail(parse(text = check_code))
71 | return(list(message = res$message,
72 | correct = res$correct,
73 | location = "append",
74 | type = if(res$correct) "success" else "error"))
75 | }
76 |
--------------------------------------------------------------------------------
/R/utils-pd.R:
--------------------------------------------------------------------------------
1 | #' Build ParseData from string representing code
2 | #'
3 | #' @param code character string representing code
4 | #' @param silent if TRUE, parsing errors are caugt and NULL is returned.
5 | #' @importFrom utils getParseData
6 | #' @export
7 | build_pd <- function(code, silent=TRUE) {
8 | tryCatch(getParseData(parse(text = code, keep.source = TRUE), includeText = TRUE),
9 | error = function(e) {
10 | if (silent) {
11 | return(NULL)
12 | } else {
13 | stop(e)
14 | }
15 | })
16 | }
17 |
18 | get_children <- function(pd, ids) {
19 | all_childs <- c()
20 | childs <- function(index){
21 | kids <- pd$id[ pd$parent %in% index ]
22 | if( length(kids) ){
23 | all_childs <<- c(all_childs, kids )
24 | childs( kids )
25 | }
26 | }
27 | sapply(ids, childs)
28 | return(all_childs)
29 | }
30 |
31 | get_sub_pd <- function(pd, ids) {
32 | children <- get_children(pd, ids)
33 | pd[pd$id %in% c(children, ids), ]
34 | }
35 |
36 | extract_assignments <- function(pd, name) {
37 | symbols <- pd[pd$token == "SYMBOL" & pd$text == name, ]
38 | assigns <- pd[pd$token %in% c("LEFT_ASSIGN", "RIGHT_ASSIGN", "EQ_ASSIGN"), ]
39 |
40 | if(nrow(assigns) == 0) return(NULL)
41 |
42 | sub_pds <- list()
43 | for(i in 1:nrow(assigns)) {
44 | assign <- assigns[i, ]
45 | valid_ids <- get_valid_ids(pd, assign, symbols)
46 | if(is.null(valid_ids)) next
47 | sub_pd <- get_sub_pd(pd, ids = valid_ids)
48 | sub_pds <- c(sub_pds, list(sub_pd))
49 | }
50 |
51 | return(sub_pds)
52 | }
53 |
54 | get_valid_ids <- function(pd, assign, symbols) {
55 | if(assign$token == "EQ_ASSIGN") {
56 | siblings <- pd$id[pd$parent == assign$parent]
57 | close_siblings <- siblings[which(siblings == assign$id) + c(-1, 1)]
58 | symbol_children <- intersect(union(get_children(pd, close_siblings), close_siblings), symbols$id)
59 | } else {
60 | symbol_children <- intersect(get_children(pd, assign$parent), symbols$id)
61 | }
62 | assign_row <- which(pd$id == assign$id)
63 | children_rows <- which(pd$id %in% symbol_children)
64 | if(assign$token == "LEFT_ASSIGN") {
65 | if(any(children_rows < assign_row)) {
66 | return(assign$parent)
67 | } else {
68 | return(NULL)
69 | }
70 | } else if (assign$token == "RIGHT_ASSIGN") {
71 | if(any(children_rows > assign_row)) {
72 | return(assign$parent)
73 | } else {
74 | return(NULL)
75 | }
76 | } else if (assign$token == "EQ_ASSIGN") {
77 | if(any(children_rows < assign_row)) {
78 | return(c(close_siblings, assign$id))
79 | } else {
80 | return(NULL)
81 | }
82 | } else {
83 | stop("token not supported")
84 | }
85 | }
86 |
87 |
88 | extract_object_assignment <- function(pd, name) {
89 | if (is.null(pd)) {
90 | return(NA)
91 | }
92 | sub_pds <- extract_assignments(pd, name)
93 | if(length(sub_pds) == 1) {
94 | return(sub_pds[[1]])
95 | } else {
96 | return(NA)
97 | }
98 | }
99 |
100 | #' @importFrom utils tail getParseText
101 | extract_function_definition <- function(pd, name) {
102 | # body of the function is the last brother of the function keyword
103 | sub_pds <- extract_assignments(pd, name)
104 | if(length(sub_pds) == 1) {
105 | pd <- sub_pds[[1]]
106 | function_parents <- pd$parent[pd$token == "FUNCTION"]
107 | if (length(function_parents) == 0) {
108 | return(NULL)
109 | }
110 | fundefs <- lapply(function_parents, function(function_parent) {
111 | last_brother <- tail(pd$id[pd$parent == function_parent], 1)
112 | code <- getParseText(pd, last_brother)
113 | sub_pd <- get_sub_pd(pd, last_brother)
114 | return(list(code = code, pd = sub_pd))
115 | })
116 | # only the first parent (if there are embbedded definitions)
117 | return(fundefs[[1]])
118 | } else {
119 | return(NULL)
120 | }
121 |
122 | }
--------------------------------------------------------------------------------
/R/utils-rmd.R:
--------------------------------------------------------------------------------
1 | build_doc_structure <- function(text) {
2 |
3 | # Fix markdown format
4 | old.format <- knitr::opts_knit$get()
5 | knitr::opts_knit$set(out.format = "markdown")
6 |
7 | # Fix pattern business
8 | apat <- knitr::all_patterns
9 | opat <- knitr::knit_patterns$get()
10 | on.exit({
11 | knitr::knit_patterns$restore(opat)
12 | knitr:::chunk_counter(reset = TRUE)
13 | knitr:::knit_code$restore(list())
14 | knitr::opts_knit$set(old.format)
15 | })
16 | knitr::pat_md()
17 |
18 | # split the file
19 | content = knitr:::split_file(lines = knitr:::split_lines(text))
20 | code_chunks <- knitr:::knit_code$get()
21 |
22 | for(i in seq_along(content)) {
23 | if(class(content[[i]]) == "block") {
24 | label <- content[[i]]$params$label
25 | content[[i]]$input <- paste(code_chunks[[label]],collapse = "\n")
26 | }
27 | }
28 |
29 | # remove the inline blocks that contain nothing or only spaces:
30 | content[sapply(content, function(part) {
31 | all(grepl(pattern = "^\\s*$", x = part$input.src)) && class(part) == "inline"
32 | })] <- NULL
33 |
34 | return(content)
35 | }
36 |
37 | parse_docs <- function(state) {
38 | student_code <- state$get("student_code")
39 | solution_code <- state$get("solution_code")
40 |
41 | student_ds <- build_doc_structure(student_code) #list(list(input = ""))
42 | solution_ds <- build_doc_structure(solution_code) #list(list(input = ""))
43 |
44 | n_student <- length(student_ds)
45 | n_solution <- length(solution_ds)
46 | n_inline_student <- sum(sapply(student_ds, class) == "inline")
47 | n_inline_solution <- sum(sapply(solution_ds, class) == "inline")
48 | n_block_student <- sum(sapply(student_ds, class) == "block")
49 | n_block_solution <- sum(sapply(solution_ds, class) == "block")
50 |
51 | check_that(is_equal(n_student, n_solution),
52 | feedback = sprintf("Make sure the structure of your document is OK. The solution expects %i inline (text) blocks and %i code chunks.", n_inline_solution, n_block_solution))
53 |
54 | check_that(is_equal(n_inline_student, n_inline_solution),
55 | feedback = sprintf("Make sure you have the correct amount of inline (text) blocks in your R markdown document. The solution expects %i.",n_inline_solution))
56 |
57 | check_that(is_equal(n_block_student, n_block_solution),
58 | feedback = sprintf("Make sure you have the correct amount of code blocks in your R markdown document. The solution expects %i.", n_block_solution))
59 |
60 | check_that(is_true(all.equal(sapply(student_ds, class), sapply(solution_ds, class))),
61 | feedback = sprintf("Make sure the overall code structure of your document is OK. The soltion expects the following setup: %s.",
62 | collapse_props(sapply(solution_ds, class), conn = ", ")))
63 |
64 | if(n_student != n_solution) return(FALSE)
65 | if(n_inline_student != n_inline_solution) return(FALSE)
66 | if(n_block_student != n_block_solution) return(FALSE)
67 | if(!isTRUE(all.equal(sapply(student_ds, class), sapply(solution_ds, class)))) return(FALSE)
68 |
69 | state$set(student_ds = student_ds)
70 | state$set(solution_ds = solution_ds)
71 | return(state)
72 | }
--------------------------------------------------------------------------------
/R/utils.R:
--------------------------------------------------------------------------------
1 | #' Get the number of hits for a series of regexes
2 | #'
3 | #' @param regex vector of regular expressions against which to match
4 | #' @param x character vector where matches are sought
5 | #' @param fixed logical. If \code{TRUE}, \code{regex} are strings to be matched as is.
6 | #'
7 | #' @export
8 | get_num_hits <- function(regex, x, fixed) {
9 | if (length(regex) == 0 || (length(regex) == 1 && nchar(regex) == 0)) {
10 | return(0)
11 | } else {
12 | counts <- sapply(regex, function(patt) {
13 | if (!fixed) {
14 | patt = paste0('(?s)', patt)
15 | }
16 | res <- gregexpr(patt, text = x, perl = !fixed, fixed = fixed)[[1]]
17 | if (any(res == -1)) {
18 | return(0L)
19 | } else {
20 | return(length(res))
21 | }
22 | }, USE.NAMES = FALSE)
23 | if (length(counts) == 0) {
24 | return(0)
25 | } else {
26 | return(sum(counts))
27 | }
28 | }
29 | }
30 |
31 | remove_comments <- function(code) {
32 | lines <- strsplit(code, "\\n")[[1]]
33 | return(paste0(lines[!grepl("^#", lines)], collapse = "\n"))
34 | }
35 |
36 | check_defined <- function(name, sol_env) {
37 | if (!exists(name, sol_env, inherits = FALSE)) {
38 | stop(paste(name, "is not defined in your solution environment.",
39 | "Specify the name of an object that is actually defined in the solution code"))
40 | }
41 | }
42 |
43 | check_sufficient <- function(calls, index, name) {
44 | if (index > length(calls)) {
45 | stop(sprintf("Fix either the index argument or the solution code; currently, there aren't %s calls of %s available in the solution.", index, name))
46 | }
47 | }
48 |
49 | v2_only <- function() {
50 | env_var <- "TESTWHAT_V2_ONLY"
51 | Sys.getenv(env_var) != "" && Sys.getenv(env_var) == "1"
52 | }
53 |
54 | fail_if_v2_only <- function(errmsg = sprintf("%s() can no longer be used in SCTs. Use its check equivalent instead.", deparse(sys.call(-1)[[1]]))) {
55 | if (v2_only()) {
56 | stop(errmsg)
57 | } else {
58 | return(invisible(NULL))
59 | }
60 | }
61 |
62 | failure <- function() {
63 | FALSE
64 | }
65 |
66 | get_solution_code <- function() { ex()$get("solution_code") }
67 |
68 | #' @importFrom magrittr %>%
69 | #' @export
70 | magrittr::`%>%`
71 |
72 | assert_is_string <- function(x, sct_name) {
73 | if (!is.character(x))
74 | stop(x, paste0(sys.call(1)[1], " requires a string, but received the class", typeof(x), '.'))
75 | }
76 |
77 | tw_accessors <- function() {
78 | tw_data <- list()
79 |
80 | get = function(name) {
81 | if(missing(name)) {
82 | tw_data
83 | } else {
84 | tw_data[[name]]
85 | }
86 | }
87 |
88 | set = function(...) {
89 | tw_data <<- merge(list(...))
90 | invisible(NULL)
91 | }
92 |
93 | clear = function() {
94 | tw_data <<- list()
95 | invisible(NULL)
96 | }
97 |
98 | initialize = function(data) {
99 | tw_data <<- data
100 | invisible(NULL)
101 | }
102 |
103 | merge = function(values) merge_list(tw_data, values)
104 | list(get = get, set = set, clear = clear, initialize = initialize)
105 | }
106 |
107 | merge_list <- function(x, y) {
108 | x[names(y)] = y
109 | x
110 | }
111 |
112 | #' tw singleton object to access data across SCT chains.
113 | #'
114 | #' @export
115 | tw <- tw_accessors()
116 |
117 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | > :warning: **This repo had outdated tokens in its travisci config**
2 | > To make new releases for this project it needs to be moved to circleci
3 |
4 | # testwhat
5 |
6 | [](https://app.fossa.io/projects/git%2Bgithub.com%2Fdatacamp%2Ftestwhat?ref=badge_shield)
7 |
8 | Verify R code submissions and auto-generate meaningful feedback messages.
9 | Originally developed for R exercises on DataCamp for so-called Submission Correctness Tests, but can also be used independently.
10 |
11 | - If you are new to teaching on DataCamp, check out https://instructor-support.datacamp.com.
12 | - If you want to learn what SCTs are and how they work, visit [this article](https://instructor-support.datacamp.com/courses/course-development/submission-correctness-tests) specifically.
13 | - For a complete overview of all functionality inside `testwhat` and articles about what to use when, consult https://datacamp.github.io/testwhat.
14 |
15 | For details, questions and suggestions, [contact us](mailto:content-engineering@datacamp.com).
16 |
17 |
18 | ## Installation
19 |
20 | ```R
21 | library("remotes")
22 | install_github("datacamp/testwhat")
23 | ```
24 |
25 | ## Demo
26 |
27 | Experimenting locally:
28 |
29 | ```R
30 | library(testwhat)
31 | setup_state(sol_code = "x <- 5",
32 | stu_code = "x <- 4")
33 |
34 | ex() %>% check_object("x")
35 | # No error: x is defined in both student and solution code
36 |
37 | ex() %>% check_object("x") %>% check_equal()
38 | # Error: The contents of the variable `x` aren't correct.
39 |
40 | # Debugging state
41 | s <- ex() %>% check_object()
42 | s # only prints out state class
43 | str(s) # full overview of state
44 | s$get("student_code") # access student code in state
45 | ```
46 |
47 | To include an SCT in a DataCamp course, visit https://instructor-support.datacamp.com.
48 |
49 | ## Tests
50 |
51 | `testwhat` currently depends on the proprietary `RBackend` and `RCompletion` packages to run tests. Tests run automatically on every branch that is updated through travis.
52 |
53 | ```R
54 | devtools::test()
55 | ```
56 |
57 | ## Documentation
58 |
59 | Whenever a push is done to the `master` branch, this repo will automatically build a `pkgdown` website (containing reference documentation and vignettes), push it to the `gh-pages` branch, which in turn is served by GitHub at https://datacamp.github.io/testwhat.
60 |
61 |
62 |
63 | ## License
64 | [](https://app.fossa.io/projects/git%2Bgithub.com%2Fdatacamp%2Ftestwhat?ref=badge_large)
65 |
--------------------------------------------------------------------------------
/_pkgdown.yml:
--------------------------------------------------------------------------------
1 | url: https://datacamp.github.io/testwhat/
2 |
3 | template:
4 | params:
5 | bootswatch: cosmo
6 | ganalytics: "UA-120925561-1"
7 | docsearch:
8 | api_key: cba84df952b7606852b92617801244e5
9 | index_name: datacamp_testwhat
10 |
11 | reference:
12 | - title: Commonly used functions
13 | contents:
14 | - starts_with("check_")
15 | - success_msg
16 | - override
17 | - disable_highlighting
18 | - title: Checking markdown
19 | contents:
20 | - check_rmd
21 | - check_header
22 | - check_chunk
23 | - check_option.MarkdownChunkState
24 | - check_equal.MarkdownChunkOptionState
25 | - check_yaml
26 | - check_option.MarkdownYamlState
27 | - check_equal.MarkdownYamlOptionState
28 | - title: Internals
29 | contents:
30 | - build_pd
31 | - compare
32 | - ex
33 | - get_num_hits
34 | - is_equal
35 | - run_until_fail
36 | - setup_state
37 | - state
38 | - test_exercise
39 | - tw
40 | - testwhat_learnr
41 |
42 | navbar:
43 | title: ~
44 | type: default
45 | left:
46 | - text: Syntax
47 | href: articles/syntax.html
48 | - text: Glossary
49 | href: articles/glossary.html
50 | - text: Guides
51 | menu:
52 | - text: Checking objects
53 | href: articles/checking-objects.html
54 | - text: Checking function calls
55 | href: articles/checking-function-calls.html
56 | - text: Checking output
57 | href: articles/checking-output.html
58 | - text: Checking control flow
59 | href: articles/checking-control-flow.html
60 | - text: Checking function definitions
61 | href: articles/checking-function-definitions.html
62 | - text: Checking through string matching
63 | href: articles/checking-through-string-matching.html
64 | - text: Combining sets of SCTs
65 | href: articles/combining-sets-of-SCTs.html
66 | - text: Checking markdown documents
67 | href: articles/checking-markdown-documents.html
68 | - text: Electives
69 | href: articles/electives.html
70 | - text: Advanced
71 | menu:
72 | - text: Test to Check
73 | href: articles/test-to-check.html
74 | - text: Extensions
75 | href: articles/extensions.html
76 |
77 | - text: Reference
78 | href: reference/index.html
79 |
--------------------------------------------------------------------------------
/inst/experiment.R:
--------------------------------------------------------------------------------
1 | pec <- '
2 | # pec here
3 | '
4 |
5 | sol_code <- '
6 | x <- mean(1:3)
7 | '
8 |
9 | stu_code <- '
10 | x <- mean(1:3)
11 | '
12 |
13 | library(testwhat)
14 | setup_state(pec = pec, sol_code = sol_code, stu_code = stu_code)
15 |
16 | ex() %>% check_function('mean') %>% disable_highlighting() %>% check_arg('x') %>% check_equal()
17 |
--------------------------------------------------------------------------------
/man/build_pd.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/utils-pd.R
3 | \name{build_pd}
4 | \alias{build_pd}
5 | \title{Build ParseData from string representing code}
6 | \usage{
7 | build_pd(code, silent = TRUE)
8 | }
9 | \arguments{
10 | \item{code}{character string representing code}
11 |
12 | \item{silent}{if TRUE, parsing errors are caugt and NULL is returned.}
13 | }
14 | \description{
15 | Build ParseData from string representing code
16 | }
17 |
--------------------------------------------------------------------------------
/man/check_chunk.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-rmd.R
3 | \name{check_chunk}
4 | \alias{check_chunk}
5 | \title{Check markdown code chunk}
6 | \usage{
7 | check_chunk(state, index = 1, not_found_msg = NULL, append = TRUE)
8 | }
9 | \arguments{
10 | \item{state}{the state to start from. This state can be produced by
11 | \code{\link{check_rmd}}, but can also follow on \code{\link{check_header}}
12 | to look for a chunk in a specific header section.}
13 |
14 | \item{index}{number that specifies which code chunk to check in the student
15 | and solution code that is zoomed in on.}
16 |
17 | \item{not_found_msg}{If specified, this overrides the automatically generated
18 | message in case no index'th chunk was found.}
19 |
20 | \item{append}{Whether or not to append the feedback to feedback built in
21 | previous states.}
22 | }
23 | \value{
24 | A state that zooms in on the code chunk.
25 | }
26 | \description{
27 | Checks if a code chunk was specified. If not, generates a feedback message.
28 | If yes, zooms in on the code chunk so you can use functions like
29 | \code{\link{check_function}} as for any regular R exercise.
30 | }
31 |
--------------------------------------------------------------------------------
/man/check_code.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-code.R
3 | \name{check_code}
4 | \alias{check_code}
5 | \title{Test the student's code as text}
6 | \usage{
7 | check_code(state, regex, fixed = FALSE, times = 1,
8 | missing_msg = NULL, append = TRUE, drop_comments = FALSE)
9 | }
10 | \arguments{
11 | \item{state}{the state to start from}
12 |
13 | \item{regex}{A set of strings/regexes that should be in the student code.}
14 |
15 | \item{fixed}{if TRUE, strings are treated literally. If FALSE, strings are
16 | treated as regex patterns.}
17 |
18 | \item{times}{how often should any of the strings be matched?}
19 |
20 | \item{missing_msg}{Custom feedback in case the pattern is not contained often
21 | enough in the student's submission.}
22 |
23 | \item{append}{Whether or not to append the feedback to feedback built in
24 | previous states}
25 |
26 | \item{drop_comments}{Logical value indicating whether or not to remove
27 | comments from these student code before looking for the pattern. Defaults
28 | to FALSE for backwards compatibility reasons.}
29 | }
30 | \description{
31 | Some rudimentary string cleaning is performed to allow for different ways of
32 | saying the same things (removing spaces, changing single quotes to double
33 | quotes, changing TRUE to T ...).
34 | }
35 | \details{
36 | Using these function should be a last resort, as there are myriad ways of
37 | solving the same problem with R!
38 | }
39 | \examples{
40 | \dontrun{
41 | # Example 1
42 | TRUE & FALSE
43 |
44 | # SCT
45 | ex() \%>\% check_code(c("TRUE & FALSE", "FALSE & TRUE"), fixed = TRUE)
46 |
47 | # Example 2:
48 | "Hello, world!"
49 |
50 | # SCT, robust to small typos
51 | ex() \%>\% check_code("[H|h]ello,*\\\\s*[W|w]orld\\\\!*")
52 | }
53 |
54 | }
55 |
--------------------------------------------------------------------------------
/man/check_control.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-control.R
3 | \name{check_control}
4 | \alias{check_control}
5 | \alias{check_if_else}
6 | \alias{check_while}
7 | \alias{check_for}
8 | \alias{check_cond}
9 | \alias{check_body.ControlState}
10 | \alias{check_if}
11 | \alias{check_else}
12 | \title{Check whether student coded a control statement correctly}
13 | \usage{
14 | check_if_else(state, index = 1, not_found_msg = NULL, append = TRUE)
15 |
16 | check_while(state, index = 1, not_found_msg = NULL, append = TRUE)
17 |
18 | check_for(state, index = 1, not_found_msg = NULL, append = TRUE)
19 |
20 | check_cond(state)
21 |
22 | \method{check_body}{ControlState}(state, ...)
23 |
24 | check_if(state)
25 |
26 | check_else(state, not_found_msg = NULL, append = TRUE)
27 | }
28 | \arguments{
29 | \item{state}{state to start from (for \code{check_} functions)}
30 |
31 | \item{index}{Number of that particular control statement to check}
32 |
33 | \item{not_found_msg}{Custom message in case the control statement was not found}
34 |
35 | \item{append}{Whether or not to append the feedback to feedback built in previous states}
36 |
37 | \item{...}{S3 stuff}
38 | }
39 | \description{
40 | Check whether student coded a control statement correctly
41 | }
42 | \examples{
43 | \dontrun{
44 | # Example 1: if else
45 | vec <- c("a", "b", "c")
46 | if("a" \%in\% vec) {
47 | print("a in here")
48 | } else if(any("b" > vec)) {
49 | cat("b not smallest")
50 | } else {
51 | str(vec)
52 | }
53 |
54 | # SCT
55 | check_if_else(1) \%>\% {
56 | check_cond(.) \%>\% {
57 | check_code(., "\%in\%")
58 | check_code(., "vec")
59 | }
60 | check_if(.) \%>\% check_function(., "print")
61 | check_else(.) \%>\% check_if_else() \%>\% {
62 | check_cond(.) \%>\% check_code(">")
63 | check_if(.) \%>\% check_function("cat")
64 | check_else(.) \%>\% check_function("str")
65 | }
66 | }
67 |
68 | # Example 2: while loop
69 | while(x < 18) {
70 | x <- x + 5
71 | print(x)
72 | }
73 |
74 | # SCT
75 | check_while(1) \%>\% {
76 | check_cond(.) \%>\% check_code(c("< 18", "18 >"))
77 | check_body(.) \%>\% {
78 | check_code(., c("x + 5", "5 + x"))
79 | check_function(., "print") \%>\% test_arg("x")
80 | }
81 | }
82 |
83 | # Example 3: for loop
84 | for(i in 1:5) {
85 | print("hurray!")
86 | }
87 |
88 | # SCT
89 | ex() \%>\% check_for() \%>\% {
90 | check_cond(.) \%>\% {
91 | check_code(., "in")
92 | check_code(., "1")
93 | check_code(., "5")
94 | }
95 | check_body(.) \%>\% check_function("print") \%>\% check_arg("x") \%>\% check_equal()
96 | }
97 | }
98 | }
99 |
--------------------------------------------------------------------------------
/man/check_equal.MarkdownChunkOptionState.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-rmd.R
3 | \name{check_equal.MarkdownChunkOptionState}
4 | \alias{check_equal.MarkdownChunkOptionState}
5 | \title{Check equality of markdown code chunk option}
6 | \usage{
7 | \method{check_equal}{MarkdownChunkOptionState}(state,
8 | incorrect_msg = NULL, append = FALSE, ...)
9 | }
10 | \arguments{
11 | \item{state}{the state to start from. Should be a state produced by \code{\link{check_option}}.}
12 |
13 | \item{incorrect_msg}{If specified, this overrides the automatically generated message in case the options don't match between student and solution.}
14 |
15 | \item{append}{Whether or not to append the feedback to feedback built in previous states.}
16 |
17 | \item{...}{S3 stuff}
18 | }
19 | \description{
20 | Check equality of markdown code chunk option
21 | }
22 |
--------------------------------------------------------------------------------
/man/check_equal.MarkdownYamlOptionState.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-rmd.R
3 | \name{check_equal.MarkdownYamlOptionState}
4 | \alias{check_equal.MarkdownYamlOptionState}
5 | \title{Check equality of markdown YAML header option}
6 | \usage{
7 | \method{check_equal}{MarkdownYamlOptionState}(state,
8 | incorrect_msg = NULL, append = TRUE, ...)
9 | }
10 | \arguments{
11 | \item{state}{the state to start from. Should be a state produced by
12 | \code{\link{check_option}}.}
13 |
14 | \item{incorrect_msg}{If specified, this overrides the automatically generated
15 | message in case the options don't match between student and solution.}
16 |
17 | \item{append}{Whether or not to append the feedback to feedback built in
18 | previous states.}
19 |
20 | \item{...}{S3 stuff}
21 | }
22 | \description{
23 | Check equality of markdown YAML header option
24 | }
25 |
--------------------------------------------------------------------------------
/man/check_error.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-error.R
3 | \name{check_error}
4 | \alias{check_error}
5 | \alias{check_error.default}
6 | \title{Explicitly check whether the student's submission threw an error.}
7 | \usage{
8 | check_error(state, ...)
9 |
10 | \method{check_error}{default}(state, incorrect_msg = NULL, ...)
11 | }
12 | \arguments{
13 | \item{state}{State to start from (for \code{check_error})}
14 |
15 | \item{...}{S3 stuff}
16 |
17 | \item{incorrect_msg}{additional message that is appended to the automatically
18 | generated feedback message.}
19 | }
20 | \description{
21 | With information gathered from the R Backend, testwhat can detect whether the
22 | student's submission generated an error.
23 | }
24 | \details{
25 | If all SCTs for an exercise pass, before marking the submission as correct
26 | testwhat will automatically check whether the student submission generated an
27 | error, unless the exercise explicitly allows for errors. This means it is not
28 | needed to use \code{check_error} explicitly. However, in some cases,
29 | using \code{check_error} explicitly somewhere
30 | throughout your SCT execution can be helpful:
31 |
32 | \itemize{
33 | \item{If you want to make sure people didn't write typos when
34 | writing a long function name.}
35 | \item{If you want to first verify whether a
36 | function call actually runs,before checking whether the arguments were
37 | specified correctly.}
38 | \item{More generally, if, because of the content, it's
39 | instrumental that the script runs without errors before doing any other
40 | verifications.}
41 | }
42 | }
43 | \examples{
44 | \dontrun{
45 | # Example student code: x <- 4 + "a"
46 |
47 | # SCT that explicitly checks for an error first
48 | ex() \%>\% check_error()
49 | ex() \%>\% check_object('x') \%>\% check_equal()
50 |
51 | # SCT that does not have to check for an error
52 | # testwhat will verify for an error implicitly
53 | ex() \%>\% check_object('x') \%>\% check_equal()
54 | }
55 |
56 | }
57 |
--------------------------------------------------------------------------------
/man/check_fun_def.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-fun-def.R
3 | \name{check_fun_def}
4 | \alias{check_fun_def}
5 | \alias{check_arguments}
6 | \alias{check_body.FunDefState}
7 | \alias{check_call}
8 | \title{Check whether the student defined a function correctly}
9 | \usage{
10 | check_fun_def(state, name, undefined_msg = NULL, no_fundef_msg = NULL,
11 | append = TRUE)
12 |
13 | check_arguments(state, incorrect_number_arguments_msg = NULL,
14 | append = TRUE)
15 |
16 | \method{check_body}{FunDefState}(state, not_found_msg = NULL,
17 | append = TRUE, ...)
18 |
19 | check_call(state, ...)
20 | }
21 | \arguments{
22 | \item{state}{the state to start from}
23 |
24 | \item{name}{The name of the function to test}
25 |
26 | \item{undefined_msg}{Custom message in case the specified function
27 | was not defined}
28 |
29 | \item{no_fundef_msg}{Custom message in case the function specified in \code{name} is not a function.}
30 |
31 | \item{append}{Whether or not to append the feedback to feedback built in previous states}
32 |
33 | \item{incorrect_number_arguments_msg}{Optional feedback message in case the
34 | function does not have the correct number of arguments.}
35 |
36 | \item{not_found_msg}{Custom feedback message if function definition was not
37 | found.}
38 |
39 | \item{...}{arguments to pass to the user-defined function to test result, output or error in a later stage}
40 | }
41 | \description{
42 | \code{check_fun_def} checks whether an object is defined in the student enviornment, and returns a state that can be piped to:
43 | \itemize{
44 | \item{\code{check_arguments}, to check whether the correct arguments where specified.}
45 | \item{\code{check_call}, to call the function with the provided arguments, and produces a state that can be piped to \code{check_output}, \code{check_result} and \code{check_error} to compare the output, result or error from calling the function between student and solution.}
46 | \item{\code{check_body}, that returns a state that focuses on the body that defines the function. Note that you cannot use \code{\link{check_object}} to compare variables that are limited to the function scope.}
47 | }
48 | }
49 | \examples{
50 | \dontrun{
51 | # Example:
52 | my_op <- function(a, b) {
53 | stopifnot(length(a) == length(b))
54 | return(abs(a) + abs(b))
55 | }
56 |
57 | # Robust SCT
58 | ex() \%>\% check_fun_def('my_op') \%>\% check_correct(
59 | {
60 | check_call(., c(1, 2), c(3, 4)) \%>\% check_result() \%>\% check_equal()
61 | check_call(., c(1, -2), c(3, -4)) \%>\% check_result() \%>\% check_equal()
62 | check_call(., c(-1, 2), c(-3, 4)) \%>\% check_result() \%>\% check_equal()
63 | check_call(., 1, c(3, 4)) \%>\% check_error()
64 | check_call(., c(1, -2), 3) \%>\% check_error()
65 | },
66 | {
67 | check_arguments(.)
68 | check_body(.) \%>\% {
69 | check_function(., 'stopifnot') \%>\% check_arg('...') \%>\% {
70 | check_function(., 'length', index = 1) \%>\% check_arg('x') \%>\% check_equal(eval = FALSE)
71 | check_function(., 'length', index = 2) \%>\% check_arg('x') \%>\% check_equal(eval = FALSE)
72 | check_code(., '==')
73 | }
74 | check_function(., 'abs', index = 1) \%>\% check_arg('x') \%>\% check_equal(eval = FALSE)
75 | check_function(., 'abs', index = 2) \%>\% check_arg('x') \%>\% check_equal(eval = FALSE)
76 | }
77 | }
78 | )
79 | }
80 |
81 | }
82 |
--------------------------------------------------------------------------------
/man/check_function.Rd:
--------------------------------------------------------------------------------
1 | % Generated by roxygen2: do not edit by hand
2 | % Please edit documentation in R/check-function.R
3 | \name{check_function}
4 | \alias{check_function}
5 | \alias{check_operator}
6 | \alias{check_arg}
7 | \alias{check_equal.ArgumentState}
8 | \title{Check whether a student correctly called a function/operator}
9 | \usage{
10 | check_function(state, name, index = 1, not_called_msg = NULL,
11 | append = TRUE)
12 |
13 | check_operator(state, name, index = 1, append = TRUE,
14 | not_called_msg = NULL)
15 |
16 | check_arg(state, arg, arg_not_specified_msg = NULL, append = TRUE)
17 |
18 | \method{check_equal}{ArgumentState}(state, incorrect_msg = NULL,
19 | eval = TRUE, eq_condition = "equivalent", eq_fun = NULL,
20 | append = TRUE, ...)
21 | }
22 | \arguments{
23 | \item{state}{state to start from}
24 |
25 | \item{name}{name of the function/operator as a string, e.g. \code{"mean"} or
26 | \code{"+"}}
27 |
28 | \item{index}{integer that specifies which call of \code{name} in the
29 | solution code will be checked.}
30 |
31 | \item{not_called_msg}{custom feedback message in case the student did not
32 | call the function often enough.}
33 |
34 | \item{append}{Whether or not to append the feedback to feedback built in
35 | previous states}
36 |
37 | \item{arg}{name or position of argument to specify
38 | ... Arguments can be accessed using '..a\\{2\\}")
13 |
14 | lst$DC_CODE <- "# aa"
15 | output <- test_it(lst)
16 | passes(output)
17 | })
18 |
19 | test_that("check_code - basic - custom", {
20 | lst <- list()
21 | lst$DC_SCT <- "ex() %>% check_code('a{2}', missing_msg = 'missing')"
22 |
23 | lst$DC_CODE <- "# a"
24 | output <- test_it(lst)
25 | fails(output, mess_patt = "Missing")
26 |
27 | lst$DC_CODE <- "# aa"
28 | output <- test_it(lst)
29 | passes(output)
30 | })
31 |
32 | test_that("check_code - different patterns", {
33 | lst <- list()
34 | lst$DC_SCT <- "ex() %>% check_code(c('a{2}', 'b{2}'))"
35 |
36 | lst$DC_CODE <- "# a"
37 | output <- test_it(lst)
38 | fails(output)
39 |
40 | lst$DC_CODE <- "# aa"
41 | output <- test_it(lst)
42 | passes(output)
43 |
44 | lst$DC_CODE <- "# bb"
45 | output <- test_it(lst)
46 | passes(output)
47 | })
48 |
49 | test_that("check_code - fixed", {
50 | lst <- list()
51 | lst$DC_SCT <- "ex() %>% check_code('a{2}', fixed = TRUE)"
52 |
53 | lst$DC_CODE <- "# a"
54 | output <- test_it(lst)
55 | fails(output)
56 |
57 | lst$DC_CODE <- "# aa"
58 | output <- test_it(lst)
59 | fails(output)
60 |
61 | lst$DC_CODE <- "# a{2}"
62 | output <- test_it(lst)
63 | passes(output)
64 | })
65 |
66 | test_that("check_code - times", {
67 | lst <- list()
68 | lst$DC_SCT <- "ex() %>% check_code('a{2}', times = 2)"
69 |
70 | lst$DC_CODE <- "# a"
71 | output <- test_it(lst)
72 | fails(output)
73 |
74 | lst$DC_CODE <- "# aa"
75 | output <- test_it(lst)
76 | fails(output)
77 |
78 | lst$DC_CODE <- "# aaaa"
79 | output <- test_it(lst)
80 | passes(output)
81 | })
82 |
83 | test_that("check_code - drop_comments", {
84 | lst <- list()
85 | lst$DC_SCT <- "ex() %>% check_code('a', drop_comments = TRUE)"
86 |
87 | lst$DC_CODE <- "# a"
88 | output <- test_it(lst)
89 | fails(output)
90 |
91 | lst$DC_CODE <- "a <- 1"
92 | output <- test_it(lst)
93 | passes(output)
94 | })
95 |
96 |
97 | test_that("check_code - different patterns + fixed + times", {
98 | lst <- list()
99 | lst$DC_SCT <- "ex() %>% check_code(c('a{2}', 'b{2}'), times = 3, fixed = TRUE)"
100 |
101 | lst$DC_CODE <- "# aaaabb"
102 | output <- test_it(lst)
103 | fails(output)
104 |
105 | lst$DC_CODE <- "# aabbbb"
106 | output <- test_it(lst)
107 | fails(output)
108 |
109 | lst$DC_CODE <- "# bbbb"
110 | output <- test_it(lst)
111 | fails(output)
112 |
113 | lst$DC_CODE <- "# a{2} b{2}"
114 | output <- test_it(lst)
115 | fails(output)
116 |
117 | lst$DC_CODE <- "# a{2} b{2} b{2}"
118 | output <- test_it(lst)
119 | passes(output)
120 |
121 | lst$DC_CODE <- "# a{2} a{2} b{2}"
122 | output <- test_it(lst)
123 | passes(output)
124 |
125 | lst$DC_CODE <- "# a{2} b{2} b{2}"
126 | output <- test_it(lst)
127 | passes(output)
128 | })
129 |
130 | test_that("check_code - backwards compatible (test_student_typed)", {
131 | lst <- list()
132 | lst$DC_SCT <- "test_student_typed(c('a{2}', 'b{2}'), times = 3)" # fixed = TRUE by default!
133 |
134 | lst$DC_CODE <- "# aaaabb"
135 | output <- test_it(lst)
136 | fails(output)
137 |
138 | lst$DC_CODE <- "# aabbbb"
139 | output <- test_it(lst)
140 | fails(output)
141 |
142 | lst$DC_CODE <- "# bbbb"
143 | output <- test_it(lst)
144 | fails(output)
145 |
146 | lst$DC_CODE <- "# a{2} b{2}"
147 | output <- test_it(lst)
148 | fails(output)
149 |
150 | lst$DC_CODE <- "# a{2} b{2} b{2}"
151 | output <- test_it(lst)
152 | passes(output)
153 |
154 | lst$DC_CODE <- "# a{2} a{2} b{2}"
155 | output <- test_it(lst)
156 | passes(output)
157 |
158 | lst$DC_CODE <- "# a{2} b{2} b{2}"
159 | output <- test_it(lst)
160 | passes(output)
161 | })
162 |
163 | test_that("check_code - test_student_typed doesn't append", {
164 | lst <- list()
165 | lst$DC_SOLUTION <- "if (TRUE) { print('hello') }"
166 | lst$DC_CODE <- "if (TRUE) { print('goodnight') }"
167 |
168 | lst$DC_SCT <- "test_if_else(if_expr_test = test_student_typed('hello'))"
169 | output <- test_it(lst)
170 | fails(output)
171 | fb_contains(output, "Check the first if statement.")
172 | fb_contains(output, "Check the if part.")
173 | fb_contains(output, "Have you typed hello?")
174 |
175 | lst$DC_SCT <- "test_if_else(if_expr_test = test_student_typed('hello', not_typed_msg = 'nottyped'))"
176 | output <- test_it(lst)
177 | fails(output)
178 | fb_excludes(output, "Check the first if statement.")
179 | fb_excludes(output, "Check the if part.")
180 | fb_contains(output, "Nottyped")
181 | })
--------------------------------------------------------------------------------
/tests/testthat/test-check-error.R:
--------------------------------------------------------------------------------
1 | context("check_error")
2 |
3 | test_that("check_error", {
4 | lst <- list()
5 | lst$DC_SCT <- "ex () %>% check_error()"
6 |
7 | lst$DC_CODE <- "3 + 3"
8 | output <- test_it(lst)
9 | passes(output)
10 |
11 | lst$DC_CODE <- "\"a\" + 3"
12 | output <- test_it(lst)
13 | fails(output)
14 | })
15 |
16 | test_that("check_error - backwards compatible", {
17 | lst <- list()
18 | lst$DC_SCT <- "test_error()"
19 |
20 | lst$DC_CODE <- "3 + 3"
21 | output <- test_it(lst)
22 | passes(output)
23 |
24 | lst$DC_CODE <- "\"a\" + 3"
25 | output <- test_it(lst)
26 | fails(output)
27 | })
28 |
29 | test_that("check_error - line of error", {
30 | lst <- list()
31 | lst$DC_SCT <- "ex() %>% check_error()"
32 | lst$DC_ECHO <- TRUE # This is important here!
33 |
34 | lst$DC_CODE <- "a <- b"
35 | output <- test_it(lst)
36 | fails(output)
37 | line_info(output, 1, 1)
38 |
39 | lst$DC_CODE <- "a <- b\na <- b"
40 | output <- test_it(lst)
41 | fails(output)
42 | line_info(output, 1, 1)
43 |
44 | lst$DC_CODE <- "b <- 4\na <- b\nrm(b)\na <- b"
45 | output <- test_it(lst)
46 | fails(output)
47 | line_info(output, 4, 4)
48 |
49 | lst$DC_CODE <- "sum(\"a\", \n\n \"b\")"
50 | output <- test_it(lst)
51 | fails(output)
52 | line_info(output, 1, 3)
53 | })
54 |
55 | test_that("check_error - incorrect_msg", {
56 | lst <- list()
57 | lst$DC_SCT <- "test_error(incorrect_msg = 'additionalmessage')"
58 |
59 | lst$DC_CODE <- "3 + 3"
60 | output <- test_it(lst)
61 | passes(output)
62 |
63 | lst$DC_CODE <- "\"a\" + 3"
64 | output <- test_it(lst)
65 | fb_contains(output, "non-numeric argument to binary operator")
66 | fb_contains(output, "additionalmessage")
67 | fails(output)
68 | })
--------------------------------------------------------------------------------
/tests/testthat/test-check-ggplot.R:
--------------------------------------------------------------------------------
1 | context("test_ggplot")
2 |
3 | pec <- "library(ggplot2)"
4 | ex_code <- 'ggplot(mtcars, aes(x = factor(cyl), fill = factor(am))) +
5 | geom_bar(position = "dodge") +
6 | scale_fill_manual("Transmission", values = c("#E41A1C", "#377EB8"), labels = c("Manual", "Automatic")) +
7 | scale_y_continuous("Number") +
8 | scale_x_discrete("Cylinders") + xlab("test")'
9 |
10 | test_that("test_ggplot works 1", {
11 | res <- setup_state(ex_code, ex_code, pec = pec) %>% check_ggplot(1, check = c("geom", "scale"), exact_geom = TRUE, check_extra = "xlab")
12 | passes2(res)
13 | })
14 |
15 | test_that("backwards comp", {
16 | setup_state(ex_code, ex_code, pec = pec)
17 | res <- test_ggplot(1, check = c("geom", "scale"), exact_geom = TRUE, check_extra = "xlab")
18 | passes2(res)
19 | })
20 |
21 | test_that("test_ggplot works 2", {
22 | s <- setup_state(
23 | stu_code = 'ggplot(mtcars, aes(x = wt, y = mpg)) + geom_smooth(se = F)',
24 | sol_code = 'ggplot(mtcars, aes(x = wt, y = mpg)) + stat_smooth(method = "auto",se = F)',
25 | pec = pec
26 | )
27 |
28 | passes2(s %>% check_ggplot(1, check = "geom", check_geom_params = "method"))
29 | passes2(s %>% check_ggplot(1, check = "geom", check_geom_params = "se"))
30 | })
31 |
32 | test_that("spots wrong facetting (grid)", {
33 | code <- "ggplot(CO2, aes(conc, uptake)) + geom_point() + facet_grid(Treatment ~ Type)"
34 | s <- setup_state(
35 | stu_code = code,
36 | sol_code = "ggplot(CO2, aes(conc, uptake)) + geom_point() + facet_grid(. ~ Plant)",
37 | pec = pec
38 | )
39 | expect_error(check_ggplot(s), class = "sct_failure")
40 | s <- setup_state(
41 | stu_code = code,
42 | sol_code = code,
43 | pec = pec
44 | )
45 | passes2(check_ggplot(s))
46 | })
47 |
48 | test_that("spots wrong facetting (wrap)", {
49 | code <- "ggplot(CO2, aes(conc, uptake)) + geom_point() + facet_wrap(~ Type)"
50 | s <- setup_state(
51 | stu_code = code,
52 | sol_code = "ggplot(CO2, aes(conc, uptake)) + geom_point() + facet_wrap(~ Plant)",
53 | pec = pec
54 | )
55 | expect_error(check_ggplot(s), class = "sct_failure")
56 | s <- setup_state(
57 | stu_code = code,
58 | sol_code = code,
59 | pec = pec
60 | )
61 | passes2(check_ggplot(s))
62 | })
63 |
64 | test_that("can handle the pipe operator", {
65 | code <- "mtcars %>% filter(gear == 4) %>% ggplot(aes(x = hp, y = wt)) + geom_point()"
66 | s <- setup_state(
67 | pec = paste0(pec, "\nlibrary(dplyr)"),
68 | stu_code = code,
69 | sol_code = code
70 | )
71 | passes2(check_ggplot(s))
72 | })
73 |
74 | test_that("can handle british students", {
75 | code <- "ggplot(mtcars, aes(x = wt, y = hp)) + geom_point(aes(colour = factor(cyl)))"
76 | scale <- " + scale_colour_manual(values = c('red', 'blue', 'green'))"
77 | s <- setup_state(
78 | pec = pec,
79 | stu_code = gsub("scale_colour", "scale_color", paste0(code, scale)),
80 | sol_code = paste0(code, scale)
81 | )
82 | passes2(check_ggplot(s))
83 | s2 <- setup_state(
84 | pec = pec,
85 | stu_code = paste0(code, scale),
86 | sol_code = paste0(code, scale)
87 | )
88 | passes2(check_ggplot(s2))
89 | s3 <- setup_state(
90 | pec = pec,
91 | stu_code = code,
92 | sol_code = paste0(code, scale)
93 | )
94 | expect_error(check_ggplot(s3), class = "sct_failure")
95 | })
96 |
97 | test_that("can handle exotic geom_labels", {
98 | code <- "ggplot(cars, aes(speed, dist)) + geom_label(label = rownames(cars))"
99 | s <- setup_state(
100 | pec = pec,
101 | stu_code = code,
102 | sol_code = code
103 | )
104 | passes2(check_ggplot(s))
105 | })
106 |
107 | test_that("different ways of specifying ggplots", {
108 | # normal + assignment
109 | plotcalls <- c(
110 | "ggplot(cars, aes(speed, dist)) + geom_point()",
111 | "x <- ggplot(cars, aes(speed, dist)) + geom_point()"
112 | )
113 | for (p in plotcalls) {
114 | s <- setup_state(pec = pec, stu_code = p, sol_code = plotcalls[1])
115 | passes2(check_ggplot(s))
116 | }
117 |
118 | # incremental
119 | code <- "x <- ggplot(cars, aes(speed, dist))\nx + geom_point()"
120 | s <- setup_state(pec = pec, stu_code = code, sol_code = code)
121 | passes2(check_ggplot(s, 1))
122 | passes2(check_ggplot(s, 2))
123 |
124 | # in pec
125 | local_pec <- "library(ggplot2)\nx <- ggplot(cars, aes(speed, dist))"
126 | code <- "x + geom_point()"
127 | s <- setup_state(pec = local_pec, stu_code = code, sol_code = code)
128 | passes2(check_ggplot(s, 1))
129 | })
130 |
131 |
--------------------------------------------------------------------------------
/tests/testthat/test-check-library-function.R:
--------------------------------------------------------------------------------
1 | context("test_library_function")
2 |
3 | test_that("test/check_library(_function) works", {
4 | for (sct in c("test_library_function('yaml')",
5 | "ex() %>% check_library('yaml')")) {
6 | lst <- list(DC_SCT = sct)
7 | for (s in c("library(yaml)",
8 | "library('yaml')",
9 | "library(\"yaml\")",
10 | "require(yaml)",
11 | "require('yaml')",
12 | "require(\"yaml\")")) {
13 | lst$DC_CODE <- s
14 | output <- test_it(lst)
15 | passes(output)
16 | }
17 |
18 | for (s in c("", "library(ggvis)", "require('ggvis')")) {
19 | lst$DC_CODE <- s
20 | output <- test_it(lst)
21 | fails(output)
22 | }
23 | }
24 | })
25 |
26 | test_that("test/check_library(_function) messaging", {
27 | for (sct in c("test_library_function('yaml', not_called_msg = 'NCM', incorrect_msg = 'ICM')",
28 | "ex() %>% check_library('yaml', not_called_msg = 'NCM', incorrect_msg = 'ICM')")) {
29 | lst <- list(DC_SCT = sct)
30 | lst$DC_CODE <- ""
31 | output <- test_it(lst)
32 | fails(output, "NCM")
33 |
34 | lst$DC_CODE <- "#library("
35 | output <- test_it(lst)
36 | fails(output, "NCM")
37 |
38 | lst$DC_CODE <- "library('ggvis')"
39 | output <- test_it(lst)
40 | fails(output, "ICM")
41 | }
42 | })
43 |
44 |
--------------------------------------------------------------------------------
/tests/testthat/test-check-mc.R:
--------------------------------------------------------------------------------
1 | context("test_mc")
2 |
3 | test_that("check_mc works", {
4 | lst <- list()
5 | lst$DC_TYPE <- "MultipleChoiceExercise"
6 | lst$DC_CODE <- "DM.result <- 2"
7 |
8 | lst$DC_SCT <- "ex() %>% check_mc(2, feedback_msgs = c('this is the WRONG answer', 'this is the CORRECT answer'))"
9 | output <- test_it(lst)
10 | passes(output, mess_patt = "This is the CORRECT answer")
11 |
12 | lst$DC_SCT <- "ex() %>% check_mc(2)"
13 | output <- test_it(lst)
14 | passes(output)
15 |
16 | lst$DC_SCT <- "ex() %>% check_mc(1, feedback_msgs = c('this is the CORRECT answer', 'this is the WRONG answer'))"
17 | output <- test_it(lst)
18 | fails(output, mess_patt = "This is the WRONG answer")
19 |
20 | lst$DC_SCT <- "ex() %>% check_mc(1)"
21 | output <- test_it(lst)
22 | fails(output)
23 |
24 | lst$DC_SCT <- "ex() %>% check_mc(1, feedback_msgs = c('not enugh messages'))"
25 | expect_error(test_it(lst))
26 |
27 | lst <- list()
28 | lst$DC_TYPE <- "MultipleChoiceExercise"
29 | lst$DC_CODE <- "not.DM.result <- 12"
30 | lst$DC_SCT <- "ex() %>% check_mc(1)"
31 | output <- test_it(lst)
32 | fails(output, mess_patt = "Please select one of the options!")
33 |
34 | lst <- list()
35 | lst$DC_TYPE <- "MultipleChoiceExercise"
36 | lst$DC_CODE <- "DM.result <- 2"
37 | lst$DC_SCT <- "ex() %>% check_mc(c(1, 2))"
38 | output <- test_it(lst)
39 | passes(output)
40 | })
41 |
42 | test_that("test_mc works", {
43 | lst <- list()
44 | lst$DC_TYPE <- "MultipleChoiceExercise"
45 | lst$DC_CODE <- "DM.result <- 2"
46 |
47 | lst$DC_SCT <- "test_mc(2, feedback_msgs = c('this is the WRONG answer', 'this is the CORRECT answer'))"
48 | output <- test_it(lst)
49 | passes(output, mess_patt = "This is the CORRECT answer")
50 |
51 | lst$DC_SCT <- "test_mc(2)"
52 | output <- test_it(lst)
53 | passes(output)
54 |
55 | lst$DC_SCT <- "test_mc(1, feedback_msgs = c('this is the CORRECT answer', 'this is the WRONG answer'))"
56 | output <- test_it(lst)
57 | fails(output, mess_patt = "This is the WRONG answer")
58 |
59 | lst$DC_SCT <- "test_mc(1)"
60 | output <- test_it(lst)
61 | fails(output)
62 |
63 | lst$DC_SCT <- "test_mc(1, feedback_msgs = c('not enugh messages'))"
64 | expect_error(test_it(lst))
65 |
66 | lst <- list()
67 | lst$DC_TYPE <- "MultipleChoiceExercise"
68 | lst$DC_CODE <- "not.DM.result <- 12"
69 | lst$DC_SCT <- "test_mc(1)"
70 | output <- test_it(lst)
71 | fails(output, mess_patt = "Please select one of the options!")
72 |
73 | lst <- list()
74 | lst$DC_TYPE <- "MultipleChoiceExercise"
75 | lst$DC_CODE <- "DM.result <- 2"
76 | lst$DC_SCT <- "test_mc(c(1, 2))"
77 | output <- test_it(lst)
78 | passes(output)
79 | })
--------------------------------------------------------------------------------
/tests/testthat/test-check-that.R:
--------------------------------------------------------------------------------
1 | context("check_that")
2 |
3 | test_that("check_that works as it should", {
4 | expect_error(run_until_fail(check_that(is_true(TRUE))))
5 | expect_error(run_until_fail(check_that(is_true(TRUE), feedback = NULL)))
6 | expect_error(run_until_fail(check_that(is_true(TRUE), feedback = list(not_message = "test"))))
7 | expect_error(run_until_fail(check_that(is_true(TRUE), feedback = list(message = NULL))))
8 | })
9 |
10 | test_that("backwards compatibility", {
11 | tw$set(state = RootState$new(test_env = environment()))
12 | expect_true(run_until_fail(test_what(expect_true(TRUE), feedback = 'testtest'))$correct)
13 | expect_false(run_until_fail(test_what(expect_true(FALSE), feedback = 'testtest'))$correct)
14 | })
15 |
--------------------------------------------------------------------------------
/tests/testthat/test-check-wd.R:
--------------------------------------------------------------------------------
1 | context("check_wd")
2 |
3 | test_that("check_wd - 1", {
4 | withr::with_file("testing.txt", {
5 | writeLines("test", con = "testing.txt")
6 | s <- setup_state(stu_code = "")
7 | passes2(ex() %>% check_wd(path = 'testing.txt'))
8 | passes2(test_file_exists('testing.txt'))
9 | })
10 | })
11 |
12 | test_that("check_wd - 2", {
13 | expect_error(ex() %>% check_wd('non_existing.txt'),
14 | regexp = "The file `non_existing.txt` does not appear to be",
15 | class = "sct_failure")
16 | expect_error(test_file_exists('non_existing.txt'),
17 | regexp = "The file `non_existing.txt` does not appear to be",
18 | class = "sct_failure")
19 |
20 | expect_error(ex() %>% check_wd('non_existing.txt', missing_msg = 'incorrect'),
21 | regexp = "Incorrect",
22 | class = "sct_failure")
23 | expect_error(test_file_exists('non_existing.txt', incorrect_msg = 'incorrect'),
24 | regexp = "Incorrect",
25 | class = "sct_failure")
26 | })
27 |
28 | test_that("check_wd - 3", {
29 | expect_error(ex() %>% check_wd('test/non_existing.txt'),
30 | regexp = "The file `non_existing.txt` does not appear to be inside the folder `test` in your working directory",
31 | class = "sct_failure")
32 | expect_error(test_file_exists('test/non_existing.txt'),
33 | regexp = "The file `non_existing.txt` does not appear to be inside the folder `test` in your working directory",
34 | class = "sct_failure")
35 |
36 | expect_error(ex() %>% check_wd('test/non_existing.txt', missing_msg = "incorrect"),
37 | regexp = "Incorrect",
38 | class = "sct_failure")
39 | expect_error(test_file_exists('test/non_existing.txt', incorrect_msg = "incorrect"),
40 | regexp = "Incorrect",
41 | class = "sct_failure")
42 |
43 | })
--------------------------------------------------------------------------------
/tests/testthat/test-content-examples.R:
--------------------------------------------------------------------------------
1 | context("content_examples")
2 |
3 | test_that("exercise intermediate r (1)", {
4 | lst <- list()
5 | lst$DC_CODE <- "today <- Sys.Date()\nday1 <- today - 11"
6 | lst$DC_SOLUTION <- "today <- Sys.Date()\nday1 <- today - 11"
7 | lst$DC_SCT <- 'test_object("day1")'
8 | output <- test_it(lst)
9 | passes(output)
10 | })
11 |
12 | test_that("exercise intermediate r (2)", {
13 | lst <- list()
14 | lst$DC_PEC <- "linkedin <- c(16, 9, 13, 5, 2, 17, 14)"
15 | lst$DC_SOLUTION <- "for (li in linkedin) { print(li) }"
16 | lst$DC_CODE <- "for (li in linkedin) { print(li + 1) }"
17 | lst$DC_SCT <- "test_output_contains('invisible(lapply(linkedin,print))')"
18 | output <- test_it(lst)
19 | fails(output)
20 |
21 | lst$DC_CODE <- lst$DC_SOLUTION
22 | output <- test_it(lst)
23 | passes(output)
24 | })
25 |
26 | test_that("exercise ggplot2 - v1", {
27 | lst <- list()
28 | lst$DC_PEC <- "library(ggplot2)"
29 | lst$DC_SCT <- "
30 | test_function_v2('qplot', 'data', index = 1)
31 | test_function_v2('qplot', 'x', eval = FALSE, index = 1)
32 | test_function_v2('qplot', 'data', index = 2)
33 | test_function_v2('qplot', 'x', eval = FALSE, index = 2)
34 | test_function_v2('qplot', 'y', eval = FALSE, index = 2)
35 | test_function_v2('qplot', 'data', index = 3)
36 | test_function_v2('qplot', 'x', eval = FALSE, index = 3)
37 | test_function_v2('qplot', 'y', eval = FALSE, index = 3)
38 | test_function_v2('qplot', 'geom', eval = FALSE, index = 3)
39 | test_error()
40 | success_msg('Good job!')
41 | "
42 | lst$DC_SOLUTION <- "
43 | qplot(factor(cyl), data = mtcars)
44 | qplot(factor(cyl), factor(vs), data = mtcars)
45 | qplot(factor(cyl), factor(vs), data = mtcars, geom = 'jitter')
46 | "
47 | lst$DC_CODE <- lst$DC_SOLUTION
48 | output <- test_it(lst)
49 | passes(output)
50 | })
51 |
52 | test_that("exercise ggplot2 - v2", {
53 | lst <- list()
54 | lst$DC_PEC <- "library(ggplot2)"
55 | lst$DC_SCT <- "
56 | test_function_v2('qplot', args = c('data', 'x'), eval = c(T, F), index = 1)
57 | test_function_v2('qplot', c('data', 'x', 'y'), eval = c(T, F, F), index = 2)
58 | test_function_v2('qplot', c('data', 'x', 'y','geom'), eval = c(T, F, F, F), index = 3)
59 | test_error()
60 | "
61 | lst$DC_SOLUTION <- "
62 | qplot(factor(cyl), data = mtcars)
63 | qplot(factor(cyl), factor(vs), data = mtcars)
64 | qplot(factor(cyl), factor(vs), data = mtcars, geom = 'jitter')
65 | "
66 | lst$DC_CODE <- lst$DC_SOLUTION
67 | output <- test_it(lst)
68 | passes(output)
69 | })
70 |
71 | # # NOT FIXED!
72 | # test_that("exercise cleaning data", {
73 | # lst <- list()
74 | # lst$DC_PEC <- "states <- c('a', 'b', 'c', 'd')"
75 | # lst$DC_CODE <- "states\nstates_upper <- toupper(states)\ntolower <- tolower(states_upper)"
76 | # lst$DC_SOLUTION <- "states\nstates_upper <- toupper(states)\ntolower(states_upper)"
77 | # lst$DC_SCT <- "test_function('tolower', 'x')"
78 | # output <- test_it(lst)
79 | # passes(output)
80 | # })
--------------------------------------------------------------------------------
/tests/testthat/test-highlighting.R:
--------------------------------------------------------------------------------
1 | context("highlighting")
2 |
3 | test_that("disable_highlighting() works", {
4 |
5 | lst <- list(DC_CODE = "if (3 > 2) round(1)",
6 | DC_SOLUTION = "if (3 > 2) round(2)")
7 |
8 | lst$DC_SCT <- "ex() %>% check_if_else() %>% check_if() %>% check_function('round') %>% check_arg('x') %>% check_equal()"
9 | output <- test_it(lst)
10 | fails(output)
11 | line_info(output, 1, 1, 18, 18)
12 |
13 | # fall back on body highlighting
14 | lst$DC_SCT <- "ex() %>% check_if_else() %>% check_if() %>% check_function('round') %>% disable_highlighting() %>% check_arg('x') %>% check_equal()"
15 | output <- test_it(lst)
16 | fails(output)
17 | line_info(output, 1, 1, 12, 19)
18 |
19 | # disableing is preserved throughout chain
20 | lst$DC_SCT <- "ex() %>% disable_highlighting() %>% check_if_else() %>% check_if() %>% check_function('round') %>% check_arg('x') %>% check_equal()"
21 | output <- test_it(lst)
22 | fails(output)
23 | no_line_info(output)
24 | })
25 |
--------------------------------------------------------------------------------
/tests/testthat/test-message-utils.R:
--------------------------------------------------------------------------------
1 | context("message-utils")
2 |
3 | test_that("yaml_option_desc", {
4 | expect_equal(yaml_option_desc("a"), "`a`")
5 | expect_equal(yaml_option_desc(c("a", "b")), "`a:b`")
6 | expect_equal(yaml_option_desc(c("a", "b", "c")), "`a:b:c`")
7 | })
--------------------------------------------------------------------------------
/tests/testthat/test-messages.R:
--------------------------------------------------------------------------------
1 | context("messages")
2 |
3 | test_that("trim works as expected", {
4 | x <- "hello. this? is! a. test?! ok? fine."
5 | res <- capitalize(x)
6 | expected <- "Hello. This? Is! A. Test?! Ok? Fine."
7 | expect_equal(res, expected)
8 | })
9 |
10 | test_that("language is deprecated", {
11 | expect_message(set_language("en"), "Different languages are no longer supported in testwhat")
12 | })
--------------------------------------------------------------------------------
/tests/testthat/test-rstudio-test-pipe.R:
--------------------------------------------------------------------------------
1 | context("test_pipe")
2 |
3 | test_that("test_pipe works", {
4 | lst <- list()
5 | lst$DC_CODE <- "mean(abs(-5:6))"
6 | lst$DC_SCT <- "test_pipe(1)"
7 | output <- test_it(lst)
8 | fails(output)
9 | lst$DC_SCT <- "test_pipe(1, insuf_msg = 'missing')"
10 | output <- test_it(lst)
11 | fails(output, mess_patt = "Missing")
12 |
13 | lst$DC_CODE <- "-5:6 %>% abs() %>% mean()"
14 | lst$DC_SCT <- "test_pipe(1)"
15 | output <- test_it(lst)
16 | passes(output)
17 | lst$DC_SCT <- "test_pipe(2)"
18 | output <- test_it(lst)
19 | passes(output)
20 | lst$DC_SCT <- "test_pipe(3)"
21 | output <- test_it(lst)
22 | fails(output)
23 | lst$DC_SCT <- "test_pipe(3, insuf_msg = 'not enough man!')"
24 | output <- test_it(lst)
25 | fails(output, mess_patt = "Not enough man!")
26 | })
--------------------------------------------------------------------------------
/tests/testthat/test-rstudio-test-rmd-group.R:
--------------------------------------------------------------------------------
1 | context("test_rmd_group")
2 |
3 | test_that("test_rmd_group works", {
4 | lst <- list()
5 | lst$DC_TYPE <- "MarkdownExercise"
6 |
7 | lst$DC_CODE <- c(my_doc.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n \n ```{r}\n dim(cars)\n ```\n \n You can also embed plots, for example:\n \n ```{r, echo=FALSE}\n plot(cars)\n ```\n \n Wowww.")
8 | lst$DC_SOLUTION <- c(my_sol.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n but\n doesn't \n matter\n \n ```{r}\n dim(cars)\n ```\n \n You can also embed plots, for falafel:\n \n ```{r, echo=FALSE}\n str(cars)\n ```\n \n Wowww.")
9 | lst$DC_SCT <- "test_rmd_group(1, NULL)"
10 | output <- test_it(lst)
11 | passes(output)
12 |
13 | lst$DC_CODE <- c(my_doc.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n \n ```{r, echo = TRUE}\n dim(cars)\n ```\n \n You can also embed plots, for example:\n \n ```{r, message = FALSE}\n plot(cars)\n ```\n \n Wowww.")
14 | lst$DC_SOLUTION <- c(my_sol.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n but\n doesn't \n matter\n \n ```{r, echo = TRUE}\n dim(cars)\n ```\n \n You can also embed plots, for falafel:\n \n ```{r, message = FALSE}\n str(cars)\n ```")
15 | lst$DC_SCT <- "test_rmd_group(1, NULL)"
16 | output <- test_it(lst)
17 | fails(output, mess_patt = "Make sure the structure of your document is OK.")
18 |
19 | lst$DC_CODE <- c(my_doc.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n \n ```{r, echo = TRUE}\n dim(cars)\n ```\n \n You can also embed plots, for example:\n \n ```{r, message = FALSE}\n plot(cars)\n ```\n \n Wowww.")
20 | lst$DC_SOLUTION <- c(my_sol.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n but\n doesn't \n matter\n \n ```{r, echo = TRUE}\n dim(cars)\n ```\n \n You can also embed plots, for falafel:\n \n ```{r, message = FALSE}\n str(cars)\n ```\n \n ```{r}\n mean(cars)\n ```")
21 | lst$DC_SCT <- "test_rmd_group(1, NULL)"
22 | output <- test_it(lst)
23 | fails(output, mess_patt = "Make sure you have the correct amount of inline")
24 |
25 | lst$DC_CODE <- c(my_doc.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n \n ```{r, echo = TRUE}\n dim(cars)\n ```\n \n You can also embed plots, for example:\n \n ```{r, message = FALSE}\n plot(cars)\n ```\n \n Wowww.\n\n ```{r}\n mean(cars)\n ```")
26 | lst$DC_SOLUTION <- c(my_sol.Rmd = "\n ---\n title: \"Testing\"\n author: \"Tester\"\n date: \"January 1, 2015\"\n output: html_document\n ---\n \n This\n is\n a\n test\n but\n doesn't \n matter\n \n ```{r, echo = TRUE}\n dim(cars)\n ```\n \n You can also embed plots, for falafel:\n \n ```{r, message = FALSE}\n str(cars)\n ```\n \n ```{r}\n mean(cars)\n ```\n \n Woowwww.")
27 | lst$DC_SCT <- "test_rmd_group(1, NULL)"
28 | output <- test_it(lst)
29 | fails(output, mess_patt = "Make sure the overall code structure of your document is OK.")
30 | })
--------------------------------------------------------------------------------
/tests/testthat/test-rstudio-test-text.R:
--------------------------------------------------------------------------------
1 | context("test_text")
2 |
3 | test_that("test_text works", {
4 | lst <- list()
5 | lst$DC_TYPE <- "MarkdownExercise"
6 | lst$DC_CODE <- c(my_doc.Rmd = "
7 | ---
8 | title: \"Testing\"
9 | author: \"Tester\"
10 | date: \"January 1, 2015\"
11 | output: html_document
12 | ---
13 |
14 | This
15 | is
16 | a
17 | test
18 |
19 | testing **good**
20 |
21 | ```{r}
22 | dim(cars)
23 | ```
24 |
25 | You can also embed plots, for example:
26 |
27 | ```{r, echo=FALSE}
28 | plot(cars)
29 | ```
30 |
31 | Wowww.")
32 |
33 | lst$DC_SOLUTION <- c(my_sol.Rmd = "
34 | ---
35 | title: \"Testing\"
36 | author: \"Tester\"
37 | date: \"January 1, 2015\"
38 | output: html_document
39 | ---
40 |
41 | This
42 | is
43 | a
44 | test
45 |
46 | testing **good**
47 |
48 | ```{r}
49 | dim(cars)
50 | ```
51 |
52 | You can also embed plots, for example:
53 |
54 | ```{r, echo=FALSE}
55 | plot(cars)
56 | ```
57 |
58 | Wowww.")
59 |
60 | lst$DC_SCT <- "test_rmd_group(1, test_text('test'))"
61 | output <- test_it(lst)
62 | passes(output)
63 |
64 | lst$DC_SCT <- "test_rmd_group(1, test_text('test', freq = 2))"
65 | output <- test_it(lst)
66 | passes(output)
67 |
68 | lst$DC_SCT <- "test_rmd_group(1, test_text('good', format = 'bold'))"
69 | output <- test_it(lst)
70 | passes(output)
71 |
72 | lst$DC_SCT <- "test_rmd_group(1, test_text('rest', not_called_msg = 'not calllled'))"
73 | output <- test_it(lst)
74 | fails(output, mess_patt = "Not calllled")
75 |
76 | lst$DC_SCT <- "test_rmd_group(1, test_text('good', freq = 2, not_called_msg = 'not called twice'))"
77 | output <- test_it(lst)
78 | fails(output, mess_patt = "Not called twice")
79 |
80 | lst$DC_SCT <- "test_rmd_group(1, test_text('good', format = 'parentheses', incorrect_msg = 'that is not correct'))"
81 | output <- test_it(lst)
82 | fails(output, mess_patt = "That is not correct")
83 | })
84 |
85 |
--------------------------------------------------------------------------------
/tests/testthat/test-state.R:
--------------------------------------------------------------------------------
1 | context("override_solution")
2 |
3 | test_that("override_solution", {
4 | s <- setup_state('x <- 2', 'x <- 2')
5 | expect_equal(get("x", envir = s$get("student_env")), 2)
6 | expect_equal(get("x", envir = s$get("solution_env")), 2)
7 | s2 <- override_solution(s, x = 3)
8 | expect_equal(get("x", envir = s2$get("student_env")), 2)
9 | expect_equal(get("x", envir = s2$get("solution_env")), 3)
10 | s3 <- override_solution_env(s, x = 3)
11 | expect_equal(get("x", envir = s3$get("student_env")), 2)
12 | expect_equal(get("x", envir = s3$get("solution_env")), 3)
13 |
14 | code <- 'mean(1:3)'
15 | s <- setup_state(code, code)
16 | expect_equal(s$get("student_code"), code)
17 | expect_equal(s$get("solution_code"), code)
18 | s2 <- override_solution(s, code = 'sum(1:3)')
19 | expect_equal(s2$get("student_code"), code)
20 | expect_equal(s2$get("solution_code"), 'sum(1:3)')
21 | s3 <- override_solution_code(s, code = 'sum(1:3)')
22 | expect_equal(s3$get("student_code"), code)
23 | expect_equal(s3$get("solution_code"), 'sum(1:3)')
24 |
25 | expect_error(override_solution(s, code = 'sum(1:3'))
26 | })
27 |
28 |
--------------------------------------------------------------------------------
/tests/testthat/test-success-msg.R:
--------------------------------------------------------------------------------
1 | context("success_msg")
2 |
3 | test_that("success_msg", {
4 | lst <- list(DC_SCT = "success_msg('this is correct')")
5 | output <- test_it(lst)
6 | passes(output, mess_patt = "This is correct")
7 | lst <- list(DC_SCT = "success_msg('this is correct', praise = TRUE)")
8 | output <- test_it(lst)
9 | passes(output, mess_patt = "You are") # verify random praise
10 | passes(output, mess_patt = "This is correct")
11 | })
12 |
13 |
--------------------------------------------------------------------------------
/tests/testthat/test-test-an-object.R:
--------------------------------------------------------------------------------
1 | context("test_an_object")
2 |
3 | test_that("test_an_object", {
4 | lst <- list()
5 | lst$DC_SOLUTION <- "a <- 2"
6 | lst$DC_SCT <- "test_an_object('a')"
7 |
8 | lst$DC_CODE <- "a <- 2"
9 | output <- test_it(lst)
10 | passes(output)
11 |
12 | lst$DC_CODE <- "b <- 2"
13 | output <- test_it(lst)
14 | passes(output)
15 |
16 | lst$DC_CODE <- "a <- 3"
17 | output <- test_it(lst)
18 | fails(output)
19 |
20 | lst$DC_CODE <- "b <- 3"
21 | output <- test_it(lst)
22 | fails(output)
23 | })
24 |
--------------------------------------------------------------------------------
/tests/testthat/test-test-exercise.R:
--------------------------------------------------------------------------------
1 | context("test_exercise")
2 |
3 | test_that("test_exercise works properly", {
4 |
5 | run_test_exercise <- function(stu_code, stu_env, sct = '', output_list = list(), allow_errors=FALSE) {
6 | test_exercise(
7 | sct = sct,
8 | ex_type = "NormalExercise",
9 | pec = "",
10 | student_code = stu_code,
11 | solution_code = "x <- 4",
12 | student_env = list2env(stu_env, parent = globalenv()),
13 | solution_env = list2env(list(x = 4), parent = globalenv()),
14 | output_list = output_list,
15 | allow_errors = allow_errors,
16 | seed = 42
17 | )
18 | }
19 |
20 | # sct fails
21 | res <- run_test_exercise(stu_code = "x <- 5",
22 | stu_env = list(x = 5),
23 | sct = "ex() %>% check_object('x') %>% check_equal()")
24 | expect_false(res$correct)
25 |
26 | # sct fails with custom message
27 | res <- run_test_exercise(stu_code = "x <- 5",
28 | stu_env = list(x = 5),
29 | sct = "ex() %>% check_object('x') %>% check_equal(incorrect_msg='abc')")
30 | expect_false(res$correct)
31 | expect_true(grepl('Abc', res$message))
32 |
33 | # sct fails with custom message outside of function
34 | res <- run_test_exercise(stu_code = "x <- 5",
35 | stu_env = list(x = 5),
36 | sct = "msg <- 'abc'\nex() %>% check_object('x') %>% check_equal(incorrect_msg = msg)")
37 | expect_false(res$correct)
38 | expect_true(grepl('Abc', res$message))
39 |
40 | # sct passes, but contains an error
41 | res <- run_test_exercise(stu_code = "x <- y",
42 | stu_env = list(),
43 | sct = '',
44 | output_list = list(list(type = 'r-error', payload = 'undefined variable')))
45 | expect_false(res$correct)
46 | expect_true(grepl('Your code contains an error that you should fix', res$message))
47 |
48 | # sct passes, contains an error, but errors are allowed: should be fine
49 | res <- run_test_exercise(stu_code = "x <- y",
50 | stu_env = list(),
51 | sct = '',
52 | output_list = list(list(type = 'r-error', payload = 'undefined variable')),
53 | allow_errors = TRUE)
54 | expect_true(res$correct)
55 |
56 | # sct passes
57 | res <- run_test_exercise(stu_code = "x <- 4",
58 | stu_env = list(x = 4),
59 | sct = "ex() %>% check_object('x') %>% check_equal()")
60 | expect_true(res$correct)
61 | })
62 |
63 |
--------------------------------------------------------------------------------
/tests/testthat/test-test-predefined-objects.R:
--------------------------------------------------------------------------------
1 | context("test-predefined-objects")
2 |
3 | test_that("test_predefined_objects works", {
4 | lst <- list()
5 | lst$DC_SOLUTION <- "a <- 2\nb <- 3\nc <- c(x = 2)\nd <- 4"
6 | lst$DC_CODE <- "a <- 2\nb <- 3\nc <- 2"
7 |
8 | lst$DC_SCT <- "test_predefined_objects()"
9 | expect_error(test_it(lst))
10 |
11 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'))"
12 | output <- test_it(lst)
13 | passes(output)
14 |
15 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'), eq_condition = 'equivalent')"
16 | output <- test_it(lst)
17 | passes(output)
18 |
19 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'), eq_condition = c('equivalent', 'equivalent'))"
20 | output <- test_it(lst)
21 | passes(output)
22 |
23 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'), eq_condition = c('equivalent', 'equivalent', 'equal'))"
24 | output <- test_it(lst)
25 | fails(output, "change the contents")
26 |
27 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c', 'd'))"
28 | output <- test_it(lst)
29 | fails(output, "remove the predefined")
30 |
31 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'), eq_condition = c('equivalent', 'equivalent', 'equal'), eval = c(T, T, F))"
32 | output <- test_it(lst)
33 | passes(output)
34 |
35 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'), eq_condition = 'equal', incorrect_msg = 'notok')"
36 | output <- test_it(lst)
37 | fails(output, 'Notok')
38 |
39 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c'), eq_condition = 'equal', incorrect_msg = c('anotok', 'bnotok', 'cnotok'))"
40 | output <- test_it(lst)
41 | fails(output, 'Cnotok')
42 |
43 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c', 'd'), undefined_msg = 'notok')"
44 | output <- test_it(lst)
45 | fails(output, 'Notok')
46 |
47 | lst$DC_SCT <- "test_predefined_objects(c('a', 'b', 'c', 'd'), undefined_msg = c('anotok', 'bnotok', 'cnotok', 'dnotok'))"
48 | output <- test_it(lst)
49 | fails(output, 'Dnotok')
50 |
51 | })
--------------------------------------------------------------------------------
/tests/testthat/test-utils-state.R:
--------------------------------------------------------------------------------
1 | context("utils-state")
2 |
3 | test_that("setup_state works", {
4 | code <- "x <- 5\nx"
5 | s <- setup_state(stu_code = code, sol_code = code, pec = "y <- 6")
6 | expect_equal(get("x", s$get("student_env")), 5)
7 | expect_equal(get("x", s$get("solution_env")), 5)
8 | expect_equal(get("y", s$get("student_env")), 6)
9 | expect_equal(get("y", s$get("solution_env")), 6)
10 | expect_equal("[1] 5", s$get("output_list")[[length(s$get("output_list"))]]$payload)
11 |
12 | s <- setup_state("", "", stu_result = evaluate::evaluate("7"))
13 | expect_equal("[1] 7", s$get("output_list")[[length(s$get("output_list"))]]$payload)
14 |
15 | s <- setup_state(stu_code = code)
16 | expect_equal(get("x", s$get("student_env")), 5)
17 | expect_false("y" %in% ls(s$get("student_env")))
18 | expect_false("x" %in% ls(s$get("solution_env")))
19 | expect_false("y" %in% ls(s$get("solution_env")))
20 | expect_equal("[1] 5", s$get("output_list")[[length(s$get("output_list"))]]$payload)
21 |
22 | s <- setup_state(sol_code = code)
23 | expect_equal(get("x", s$get("solution_env")), 5)
24 | expect_false("y" %in% ls(s$get("solution_env")))
25 | expect_false("x" %in% ls(s$get("student_env")))
26 | expect_false("y" %in% ls(s$get("student_env")))
27 |
28 | s <- setup_state()
29 | expect_equal(length(s$get("solution_env")), 0)
30 | expect_equal(length(s$get("student_env")), 0)
31 |
32 | erroneous_code <- "non_existing_var"
33 | expect_error(setup_state(sol_code = erroneous_code))
34 | s <- setup_state(stu_code = erroneous_code, sol_code = code)
35 | expect_true("r-error" %in% sapply(s$get("output_list"), `[[`, "type"))
36 | expect_equal("Error: object 'non_existing_var' not found", s$get("output_list")[[length(s$get("output_list"))]]$payload)
37 | })
38 |
--------------------------------------------------------------------------------
/tests/testthat/test-utils.R:
--------------------------------------------------------------------------------
1 | context("utils")
2 |
3 | test_that("accessor works", {
4 | tw <- tw_accessors()
5 | tw$initialize(data = list(a = 2, b = 3, c = 4))
6 | expect_equal(tw$get("a"), 2)
7 | expect_equal(tw$get("b"), 3)
8 | expect_equal(tw$get("c"), 4)
9 | expect_equal(tw$get("d"), NULL)
10 | tw$set(d = 5)
11 | expect_equal(tw$get("a"), 2)
12 | expect_equal(tw$get("b"), 3)
13 | expect_equal(tw$get("c"), 4)
14 | expect_equal(tw$get("d"), 5)
15 | tw$clear()
16 | expect_equal(tw$get(), list())
17 | expect_equal(tw$get("a"), NULL)
18 | })
19 |
20 | test_that("get_num_hits works", {
21 | expect_equal(get_num_hits('a', 'abc', TRUE), 1)
22 | expect_equal(get_num_hits('a', 'aba', TRUE), 2)
23 | })
24 |
25 | test_that("get_num_hits uses Perl regex", {
26 | expect_equal(get_num_hits('^[^b]+(?!b)', 'abc', FALSE), 0)
27 | expect_equal(get_num_hits('^[^b]+(?!b)', 'ac', FALSE), 1)
28 | multiline_string <- 'a
29 | a'
30 | expect_equal(get_num_hits('a.*', multiline_string, FALSE), 1)
31 | expect_equal(get_num_hits('(?-s)a.*', multiline_string, FALSE), 2)
32 | })
33 |
34 | test_that("check_defined works", {
35 | testenv <- new.env()
36 | assign("x", 5, envir = testenv)
37 | expect_silent(check_defined("x", testenv))
38 | expect_error(check_defined("y", testenv))
39 | })
40 |
41 | test_that("remove_comments works", {
42 | cases <- c("# c\n4", "#c\n4", "4\n#c", "4\n\n#c", "#c\n4\n# c\n")
43 | for (case in cases) {
44 | no_comments_stripped = stringr::str_trim(remove_comments(case))
45 | expect_equal(no_comments_stripped, "4")
46 | }
47 | cases2 <- c("#", "#\n")
48 | for (case in cases2) {
49 | expect_equal(remove_comments("#"), "")
50 | }
51 | })
52 |
53 | test_that("fail_if_v2_only", {
54 | withr::with_envvar(c(TESTWHAT_V2_ONLY = ''), {
55 | expect_equal(fail_if_v2_only(), NULL)
56 | })
57 | withr::with_envvar(c(TESTWHAT_V2_ONLY = '0'), {
58 | expect_equal(fail_if_v2_only(), NULL)
59 | })
60 | withr::with_envvar(c(TESTWHAT_V2_ONLY = '1'), {
61 | expect_error(fail_if_v2_only())
62 | })
63 | withr::with_envvar(c(TESTWHAT_V2_ONLY = '1'), {
64 | expect_error(fail_if_v2_only('test'), regexp = 'test')
65 | })
66 | })
67 |
68 | test_that("unpipe works with a single pipe", {
69 | expected <- quote(select(cars, speed))
70 | actual <- unpipe(quote(cars %>% select(speed)))
71 | expect_identical(actual, expected)
72 | })
73 |
74 | test_that("unpipe works with a single pipe and dot", {
75 | expected <- quote(select(cars, speed))
76 | actual <- unpipe(quote(cars %>% select(., speed)))
77 | expect_identical(actual, expected)
78 | })
79 |
80 | test_that("unpipe works with two pipes", {
81 | expected <- quote(filter(select(cars, speed), speed > 20))
82 | actual <- unpipe(quote(cars %>% select(speed) %>% filter(speed > 20)))
83 | expect_identical(actual, expected)
84 | })
85 |
86 | test_that("unpipe works with two pipes and dot", {
87 | expected <- quote(filter(select(cars, speed), speed > 20))
88 | actual <- unpipe(quote(cars %>% select(., speed) %>% filter(., speed > 20)))
89 | expect_identical(actual, expected)
90 | })
91 |
92 | test_that("unpipe works with qualifed function names", {
93 | expected <- quote(dplyr::filter(dplyr::select(cars, speed), speed > 20))
94 | actual <- unpipe(quote(cars %>% dplyr::select(speed) %>% dplyr::filter(speed > 20)))
95 | expect_identical(actual, expected)
96 | })
97 |
98 | test_that("unpipe works with multiple dots", {
99 | expected <- quote(setNames(letters, letters))
100 | actual <- unpipe(quote(letters %>% setNames(., .)))
101 | expect_identical(actual, expected)
102 | })
103 |
--------------------------------------------------------------------------------
/testwhat.Rproj:
--------------------------------------------------------------------------------
1 | Version: 1.0
2 |
3 | RestoreWorkspace: No
4 | SaveWorkspace: No
5 | AlwaysSaveHistory: No
6 |
7 | EnableCodeIndexing: Yes
8 | UseSpacesForTab: Yes
9 | NumSpacesForTab: 2
10 | Encoding: UTF-8
11 |
12 | RnwWeave: Sweave
13 | LaTeX: pdfLaTeX
14 |
15 | BuildType: Package
16 | PackageUseDevtools: Yes
17 | PackageInstallArgs: --no-multiarch --with-keep.source
18 | PackageRoxygenize: rd,collate,namespace,vignette
19 |
--------------------------------------------------------------------------------
/vignettes/checking-control-flow.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Checking control flow"
3 | output: rmarkdown::html_vignette
4 | vignette: >
5 | %\VignetteIndexEntry{Checking control flow}
6 | %\VignetteEngine{knitr::rmarkdown}
7 | %\VignetteEncoding{UTF-8}
8 | ---
9 |
10 | ```{r setup, include = FALSE}
11 | knitr::opts_chunk$set(
12 | collapse = TRUE,
13 | comment = "#>",
14 | eval = FALSE
15 | )
16 | ```
17 |
18 | You can use `check_for()`, `check_while()` and `check_if_else()` chains to check whether a student has properly coded control constructs.
19 |
20 | ## Example 1: For loop
21 |
22 | Consider the following solution:
23 |
24 | ```{r}
25 | # Print out the integers 1 to 10
26 | for (i in 1:10) {
27 | print(i)
28 | }
29 | ```
30 |
31 | A suitable SCT for this exercise can be the following:
32 |
33 | ```{r}
34 | ex() %>% check_for() %>% {
35 | check_cond(.) %>% check_code("in\\s*1:10", missing_msg = "You can use `i in 1:10` to define your for loop.")
36 | check_body(.) %>% check_function("print") %>% check_arg("x") %>% check_equal(eval = FALSE)
37 | }
38 | ```
39 |
40 | - `check_for()` checks whether students have specified a `for` loop in their code. If this is the case, it produces a substate, referring to the condition of the for loop and its body.
41 | - Next, you can 'zoom in' on the condition and body of the `for` loop, using `check_cond()` and `check_body()` respectively. After this zooming in, you can continue the chain of SCT functions to check these 'parts' of the code. The `check_code()` call, for example, only looks to match the regular expression in the iteration part of the `for` loop.
42 |
43 | ## Example 2: Check if else
44 |
45 | Consider the following solution:
46 |
47 | ```{r}
48 | # Predefined value of x
49 | x <- TRUE
50 |
51 | # Code the if else construct
52 | if (x) {
53 | print("x is TRUE!")
54 | } else {
55 | print("x is not TRUE!")
56 | }
57 | ```
58 |
59 | The following SCT checks its correctness:
60 |
61 | ```{r}
62 | ex() %>% check_object("x")
63 | ex() %>% check_if_else() %>% {
64 | check_cond(.) %>% check_code("x")
65 | check_if(.) %>% check_function("print") %>% check_arg("x") %>% check_equal()
66 | check_else(.) %>% check_function("print") %>% check_arg("x") %>% check_equal()
67 | }
68 | ```
69 |
70 | - `check_if_else()` parses the student code and checks if there is an if-else statement in there.
71 | - `check_cond`, `check_if`, and `check_else()` all 'zoom in' on a particular part of the if-else statement: the condition, the body of the `if` statement and the body of the `else` statement. After this zooming in, you can continue the chain of SCT functions to check these 'parts' of the code. The first `check_function("print")` chain for example, only looks for the function call inside the `if` body.
72 |
73 | ### Example 3: Check if, else if, else
74 |
75 | It is also possible to use `else if` in R. How to test this? Well, behind the scenes, R parses the following structure:
76 |
77 | ```{r}
78 | if (condition1) {
79 | expression
80 | } else if (condition2) {
81 | expression
82 | } else {
83 | expression
84 | }
85 | ```
86 |
87 | as if it follows this structure:
88 |
89 | ```{r}
90 | if (condition1) {
91 | expression
92 | } else {
93 | if (condition2) {
94 |
95 | } else {
96 |
97 | }
98 | }
99 | ```
100 |
101 | If you want to test such a piece of code, you therefore need the following construct:
102 |
103 | ```{r}
104 | ex() %>% check_if_else() %>% {
105 | check_cond(.) %>% ...
106 | check_if(.) %>% ...
107 | check_else(.) %>% check_if_else() %>% {
108 | check_cond(.) %>% ...
109 | check_if(.) %>% ...
110 | check_else(.) %>% ...
111 | }
112 | }
113 | ```
114 |
115 | ## Caution
116 |
117 | Not all of the SCT chains that you specify after a 'zooming in' step might work as you'd expect. Remember that functions like `check_object()` and `check_function()` often depend on both the student and solution environment. It is possible that during execution of control flow these values change. The `testwhat` functions will always compare the 'end environment' of student and solution, it is not possible to do matching on intermediate values of objects that are changed further in the script.
118 |
119 |
--------------------------------------------------------------------------------
/vignettes/checking-function-definitions.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Checking function definitions"
3 | output: rmarkdown::html_vignette
4 | vignette: >
5 | %\VignetteIndexEntry{Checking function definitions}
6 | %\VignetteEngine{knitr::rmarkdown}
7 | %\VignetteEncoding{UTF-8}
8 | ---
9 |
10 | ```{r setup, include = FALSE}
11 | knitr::opts_chunk$set(
12 | collapse = TRUE,
13 | comment = "#>",
14 | eval = FALSE
15 | )
16 | ```
17 |
18 | Some exercises require a student to hand-craft a function to make their code DRY. With `check_fun_def()` and a range of related helper `check_` functions you can check the correctness of these user-defined functions.
19 |
20 | As an example, have a look at the following solution:
21 |
22 | ```{r}
23 | # Define my_fun
24 | my_fun <- function(a, b) {
25 | abs(a) + abs(b)
26 | }
27 | ```
28 |
29 | The following SCT checks the function definition and whether the function was properly called:
30 |
31 | ```{r}
32 | ex() %>% check_fun_def("my_fun") %>% {
33 | check_arguments(.)
34 | check_call(., 1, 2) %>% check_result() %>% check_equal()
35 | check_call(., -1, 2) %>% check_result() %>% check_equal()
36 | check_call(., 1, -2) %>% check_result() %>% check_equal()
37 | check_call(., -1, -2) %>% check_result() %>% check_equal()
38 | check_body(.) %>% {
39 | check_function(., "abs", index = 1)
40 | check_function(., "abs", index = 2)
41 | }
42 | }
43 | ```
44 |
45 | - `check_fun_def` checks whether `my_fun` was defined by the student. If this is the case, it will produce a substate that contains a reference to the function arguments and its body.
46 | - `check_arguments()` checks whether the student specified the same number of arguments as the function definition in the solution did.
47 | - `check_call()` will create an R expression that calls the function `my_fun()` with the arguments specified in it. As an example, `check_call(., 1, 2)` will generate the expression `my_fun(1, 2)`. `check_result()` will then execute this expression (in both student and solution workspace), and focus on the result of the expression. Finally, `check_equal()` verifies whether these call results correspond.
48 | - `check_body()` zooms in on the body of the function definition (as if the body of the function was the only code in the student submission). If, for example, the student used `abs()` outside the function definition, this would be ignored. Notice here that no arguments are specified. If we did this, `check_function()` would compare the actual values of the arguments. This is information that is not available, as `a` and `b` are not variables that are available in the workspace, only in the scope of the function.
49 |
50 | **Note:** in addition to `check_result()`, you can also pipe the result of `check_call()` into `check_output()` and `check_error()`, and follow up with `check_equal()`. These functions will respectively check the output and error the function call generated when executed in the student/solution environment.
51 |
--------------------------------------------------------------------------------
/vignettes/checking-markdown-documents.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Checking markdown documents"
3 | output: rmarkdown::html_vignette
4 | vignette: >
5 | %\VignetteIndexEntry{Checking markdown documents}
6 | %\VignetteEngine{knitr::rmarkdown}
7 | %\VignetteEncoding{UTF-8}
8 | ---
9 |
10 | ```{r setup, include = FALSE}
11 | knitr::opts_chunk$set(
12 | collapse = TRUE,
13 | comment = "#>",
14 | eval = FALSE
15 | )
16 | ```
17 |
18 | DataCamp's campus application also features exercises of the type `MarkdownExercise`, where students are asked to make changes to a markdown document. When they submit their document, DataCamp's RBackend will render the markdown doc and verify its correctness with testwhat. Because a markdown document is pretty different from an R script, testwhat features a set of dedicated functions to test elements of a markdown document. This article will give one extended example, and walk through what the different functions do. For more details about each of the functions, check out the function documentation (see Reference section).
19 |
20 | Until the extended example is added and elaborated on, have a look at [the tests in `test-check-rmd.R` of the testwhat repository on GitHub](https://github.com/datacamp/testwhat/blob/master/tests/testthat/test-check-rmd.R). At the end, you will find a full example of an SCT chain that tests an entire Markdown document. The tests should be largely self-explanatory.
21 |
--------------------------------------------------------------------------------
/vignettes/checking-output.Rmd:
--------------------------------------------------------------------------------
1 | ---
2 | title: "Checking output"
3 | output: rmarkdown::html_vignette
4 | vignette: >
5 | %\VignetteIndexEntry{Checking output}
6 | %\VignetteEngine{knitr::rmarkdown}
7 | %\VignetteEncoding{UTF-8}
8 | ---
9 |
10 | ```{r setup, include = FALSE}
11 | knitr::opts_chunk$set(
12 | collapse = TRUE,
13 | comment = "#>",
14 | eval = FALSE
15 | )
16 | ```
17 |
18 | ## Search for pattern in output
19 |
20 | `check_output()` enables you to check for patterns or literal matches in the output the student generated with his or her submission. Where `check_output_expr()` (see next section) _executes_ the `expr` argument you pass it and then tries to match it to the student's output, the `check_output()` function doesn't perform any execution: it simply looks for matches for the `pattern` you specify.
21 |
22 | ### Example
23 |
24 | Suppose you want to check whether the student printed out `My name is