/
grade_code.R
171 lines (161 loc) · 6.21 KB
/
grade_code.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
#' Grade student code against a solution (Legacy)
#'
#' `r lifecycle::badge("superseded")` Please use [grade_this_code()].
#'
#' Checks the code expression or the code result against a solution.
#'
#' `grade_code()` compares student code to a solution (i.e. model code) and
#' describes the first way that the student code differs. If the student code
#' exactly matches the solution, `grade_code()` returns a customizable success
#' message (`correct`). If the student code does not match the solution, a
#' customizable incorrect message (`incorrect`) can also be provided.
#'
#' `grade_code()` provides a *strict* check in that the student code must
#' exactly match the solution. It is not enough for the student code to be
#' equivalent to the solution code (e.g. to return the same result as the
#' solution).
#'
#' You can provide solution code for `grade_code()` to use in two ways:
#'
#' 1. Pass code as a character string or a quoted expression to the solution
#' argument of `grade_code()`
#'
#' 2. Make a "-solution" code chunk for the exercise to be checked in a learnr
#' document. There is no need to supply a solution argument for `grade_code()`
#' if you call it from the "-check" chunk of the same exercise. Likewise, there
#' is no need to supply a student submitted code argument when you call
#' `grade_code()` from a learnr document (learnr will provide the code that the
#' student submits when it runs `grade_code()`.
#'
#' For best results, name all arguments provided in the solution code.
#'
#' @param correct A character string to display if the student answer matches a
#' known correct answer.
#'
#' @param incorrect A character string to display if the student answer matches
#' a known incorrect answer.
#' @inheritParams code_feedback
#' @param grader_args A list of parameters passed to `grader` functions
#' (provided by [gradethis_exercise_checker()]). This contains:
#'
#' * `user_quo`: Quoted R code submitted by the user. For example
#' \code{\link[rlang:quo]{rlang::quo(1)}}
#'
#' * `solution_quo`: (Optional) Quoted solution R code provided by the
#' `*-solution` chunk for an exercise.
#'
#' @param learnr_args A list of all parameters passed to
#' [gradethis_exercise_checker()] by `learnr`. See
#' <https://rstudio.github.io/learnr/exercises.html#exercise_checking> for
#' more details.
#'
#' @param glue_correct A glue string that returns the final correct message
#' displayed. Defaults to `getOption("gradethis_glue_correct")`.
#'
#' @param glue_incorrect A glue string that returns the final incorrect message
#' displayed. Defaults to `getOption("gradethis_glue_incorrect")`.
#'
#' @param glue_pipe A glue string that returns the final message displayed when
#' the student uses a pipe, `%>%`. Defaults to
#' `getOption("gradethis.pipe_warning")`.
#' @param ... ignored. Should be empty
#'
#' @return a function whose first parameter should be an environment that contains
#' all necessary information to compare the code. The result of the returned
#' function will be a [graded()] object. An incorrect message will describe the
#' first way that the answer differs, the message will be the content of the `glue_pipe`
#' argument.
#'
#' @seealso [grade_this_code()], [grade_code()]
#' @keywords internal
#' @export
#' @examples
#' \dontrun{
#' gradethis_demo()
#' }
#'
#' # This is a manual example, see grading demo for `learnr` tutorial usage
#' y <- expression(sqrt(log(2)))
#' z <- expression(sqrt(log(1)))
#' grade_code(grader_args = list(user_quo = y, solution_quo = z))
grade_code <- function(
correct = NULL,
incorrect = NULL,
...,
allow_partial_matching = getOption("gradethis.allow_partial_matching", TRUE),
glue_correct = getOption("gradethis.glue_correct"),
glue_incorrect = getOption("gradethis.glue_incorrect"),
glue_pipe = deprecated(),
grader_args = deprecated(),
learnr_args = deprecated()
) {
ellipsis::check_dots_empty()
if (is_present(grader_args)) deprecate_warn("0.2.0", "grade_code(grader_args = )")
if (is_present(learnr_args)) deprecate_warn("0.2.0", "grade_code(learnr_args = )")
if (is_present(glue_pipe)) {
deprecate_warn(
"0.2.1",
"grade_code(glue_pipe = )",
details = paste(
"Use the global option `gradethis.pipe_warning` to set the pipe warning message.",
"Or use `\"{pipe_warning()}\"` in the `glue_correct` or `glue_incorrect` arguments of `grade_code()`.",
sep = "\n"
)
)
}
# return script style function
function(check_env) {
if (is.list(check_env)) {
check_env <- list2env(check_env)
}
user_code <- check_env$.user_code
if (is.null(user_code)) {
return(legacy_graded(
correct = FALSE,
message = "I didn't receive your code. Did you write any?"
))
}
solution_code_all <- check_env$.solution_code_all
# If `.solution_code_all` is missing, make it from `.solution_code`
if (is.null(solution_code_all) || length(str2expression(solution_code_all)) == 0) {
solution_code_all <- solutions_prepare(check_env$.solution_code)
}
# If `.solution_code_all` is still missing, return an error
if (is.null(solution_code_all) || length(str2expression(solution_code_all)) == 0) {
return(legacy_graded(
correct = FALSE,
message = "No exercise solution provided. Defaulting to _incorrect_."
))
}
message <- code_feedback(
user_code = user_code,
solution_code = solution_code_all,
user_env = check_env$.envir_result %||% check_env,
solution_env = check_env$.envir_solution %||% check_env,
allow_partial_matching = allow_partial_matching
)
if (is.null(message)) {
# correct!
return(legacy_graded(
correct = TRUE,
message = glue_message(
glue_correct %||% gradethis_legacy_options$gradethis.glue_correct,
.is_correct = TRUE,
.message = NULL,
.correct = correct,
.user_code = user_code
)
))
}
# is incorrect
message <- glue_message(
glue_incorrect %||% gradethis_legacy_options$gradethis.glue_incorrect,
.is_correct = FALSE,
.message = message,
.incorrect = incorrect,
.user_code = user_code
)
# final grade
legacy_graded(correct = FALSE, message = message)
}
}