Skip to content

Commit

Permalink
Merge pull request swirldev#453 from swirldev/dev
Browse files Browse the repository at this point in the history
swirl 2.4.1
  • Loading branch information
seankross committed Apr 15, 2016
2 parents 50cf8f6 + 248d285 commit 06dd821
Show file tree
Hide file tree
Showing 25 changed files with 233 additions and 50 deletions.
1 change: 1 addition & 0 deletions .Rbuildignore
Original file line number Diff line number Diff line change
Expand Up @@ -4,3 +4,4 @@
user_data/
^\.travis\.yml$
^cran-comments\.md$
^revdep$
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ Description: Use the R console as an interactive learning
environment. Users receive immediate feedback as they are guided through
self-paced lessons in data science and R programming.
URL: http://swirlstats.com
Version: 2.4.0
Version: 2.4.1
License: MIT + file LICENSE
Authors@R: c(
person("Sean", "Kross", email = "[email protected]", role = c("aut", "cre")),
Expand Down
7 changes: 1 addition & 6 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -46,12 +46,7 @@ importFrom(stringr,str_match)
importFrom(stringr,str_split)
importFrom(stringr,str_split_fixed)
importFrom(stringr,str_trim)
importFrom(testthat,equals)
importFrom(testthat,expectation)
importFrom(testthat,is_a)
importFrom(testthat,is_equivalent_to)
importFrom(testthat,is_identical_to)
importFrom(testthat,matches)
importFrom(testthat,compare)
importFrom(tools,file_ext)
importFrom(tools,file_path_sans_ext)
importFrom(yaml,yaml.load)
Expand Down
6 changes: 6 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
# swirl 2.4.1

* Added new answer test: `calculates_same_value()`.

* Now compatible with versions of testthat later than 0.11.0.

# swirl 2.4.0

* Added support for multiple languages, including Spanish, French, German,
Expand Down
29 changes: 12 additions & 17 deletions R/answerTests.R
Original file line number Diff line number Diff line change
Expand Up @@ -153,10 +153,10 @@ runTest.newcmd <- function(keyphrase,e){
correct.expr <- parse(text=rightside(keyphrase))[[1]]
correct.ans <- eval(correct.expr)
ansResults <- expectThat(e$val,
equals(correct.ans,label=correct.ans),
equals_legacy(correct.ans,label=correct.ans),
label=e$val)
callResults <- expectThat(as.expression(e$expr)[[1]],
is_identical_to(correct.expr,label=deparse(correct.expr)),
is_identical_to_legacy(correct.expr,label=deparse(correct.expr)),
label=deparse(e$expr))

# identical(as.expression(e$expr)[[1]], as.expression(correct.expr)[[1]])
Expand Down Expand Up @@ -221,7 +221,7 @@ runTest.is_a <- function(keyphrase, e) {
val <- e$val
}
label <- val
results <- expectThat(val, is_a(class), label=label)
results <- expectThat(val, is_a_legacy(class), label=label)
if(is(e,"dev") && !results$passed)swirl_out(results$message)
return(results$passed)
}
Expand All @@ -245,7 +245,7 @@ runTest.matches <- function(keyphrase, e) {
correctVal <- tolower(str_trim(rightside(keyphrase)))
userVal <- str_trim(as.character(e$val))
results <- expectThat(tolower(userVal),
matches(correctVal),
matches_legacy(correctVal),
label=userVal)
if(is(e,"dev") && !results$passed)swirl_out(results$message)
return(results$passed)
Expand All @@ -264,12 +264,12 @@ runTest.creates_var <- function(keyphrase, e){
}
correctName <- rightside(keyphrase)
if(is.na(correctName)){
results <- expectThat(length(delta), equals(1),
results <- expectThat(length(delta), equals_legacy(1),
label=paste(deparse(e$expr),
"does not create a variable."))
} else {
results <- expectThat(names(delta),
is_equivalent_to(correctName, label=correctName),
is_equivalent_to_legacy(correctName, label=correctName),
label=paste(deparse(e$expr),
"does not create a variable named",
correctName))
Expand All @@ -295,7 +295,7 @@ runTest.equals <- function(keyphrase, e){
correctAns <- safeEval(parse(text=correctExpr))
if(length(correctAns) != 1)return(FALSE)
results <- expectThat(e$var,
equals(correctAns[[1]],
equals_legacy(correctAns[[1]],
label=correctExprLabel),
label=deparse(e$expr))
if(is(e, "dev") && !results$passed)swirl_out(results$message)
Expand All @@ -310,7 +310,7 @@ runTest.equivalent <- function(keyphrase,e) {
correctExpr <- as.list(parse(text=rightside(keyphrase)))
userExpr <- as.list(as.expression(e$expr))
results <- expectThat(userExpr,
is_equivalent_to(correctExpr,deparse(correctExpr)),
is_equivalent_to_legacy(correctExpr,deparse(correctExpr)),
label=deparse(userExpr))

if(is(e,"dev") && !results$passed)swirl_out(results$message)
Expand Down Expand Up @@ -345,7 +345,7 @@ runTest.expr_identical <- function(keyphrase, e){
expr <- e$expr
if(is.expression(expr))expr <- expr[[1]]
results <- expectThat(expr,
is_identical_to(correct, label=rightside(keyphrase)),
is_identical_to_legacy(correct, label=rightside(keyphrase)),
label=deparse(expr))
if( is(e, "dev") && !results$passed)swirl_out(results$message)
return(results$passed)
Expand All @@ -359,7 +359,7 @@ runTest.val_length <- function(keyphrase, e){
stop(message=paste("BUG: right side of", keyphrase,
"is not an integer."))
}
results <- expectThat(length(e$val), equals(n, label=n),
results <- expectThat(length(e$val), equals_legacy(n, label=n),
label=paste0("length(c(", toString(e$val), "))"))
if( is(e, "dev") && !results$passed)swirl_out(results$message)
return(results$passed)
Expand Down Expand Up @@ -435,7 +435,7 @@ uses_func <- function(expected, label = NULL, ...){
function(expr){
uses <- (is.call(expr) || is.expression(expr)) &&
expected %in% flatten(expr)
expectation(identical(uses, TRUE),
expectation_legacy(identical(uses, TRUE),
str_c("does not use ", label))
}
}
Expand All @@ -446,12 +446,7 @@ in_range <- function(range, label=NULL){
isOK <- is.numeric(number) &&
isTRUE(number >= range[1]) &&
isTRUE(number <= range[2])
expectation(identical(isOK, TRUE),
expectation_legacy(identical(isOK, TRUE),
str_c("is not between ", range[1], " and ", range[2]))
}
}





47 changes: 36 additions & 11 deletions R/answerTests2.R
Original file line number Diff line number Diff line change
Expand Up @@ -65,6 +65,8 @@
#' examples.
#'
#' \code{\link{any_of_exprs}}: Test that the user's expression matches any of several possible expressions.
#'
#' \code{\link{calculates_same_value}}: Test that the user's expression evaluates to a certain value.
#'
#' \code{\link{expr_creates_var}}: Test that a new variable has been created.
#'
Expand Down Expand Up @@ -116,7 +118,6 @@
#'
#' @family AnswerTests
NULL


#' Test for a correct expression, a correct value, or both.
#'
Expand Down Expand Up @@ -199,15 +200,15 @@ omnitest <- function(correctExpr=NULL, correctVal=NULL, strict=FALSE, eval_for_c
if(!is.null(correctVal)){
if(is.character(e$val)){
valResults <- expectThat(e$val,
is_equivalent_to(correctVal, label=correctVal),
is_equivalent_to_legacy(correctVal, label=correctVal),
label=(e$val))
if(is(e, "dev") && !valResults$passed)swirl_out(valResults$message)
valGood <- valResults$passed
# valGood <- val_matches(correctVal)
} else if(!is.na(e$val) && is.numeric(e$val) && length(e$val) == 1){
cval <- try(as.numeric(correctVal), silent=TRUE)
valResults <- expectThat(e$val,
equals(cval, label=correctVal),
equals_legacy(cval, label=correctVal),
label=toString(e$val))
if(is(e, "dev") && !valResults$passed)swirl_out(valResults$message)
valGood <- valResults$passed
Expand Down Expand Up @@ -253,12 +254,36 @@ expr_identical_to <- function(correct_expression){
if(is.expression(expr))expr <- expr[[1]]
correct <- parse(text=correct_expression)[[1]]
results <- expectThat(expr,
is_identical_to(correct, label=correct_expression),
is_identical_to_legacy(correct, label=correct_expression),
label=deparse(expr))
if( is(e, "dev") && !results$passed)swirl_out(results$message)
return(results$passed)
}

#' Test that the user's expression evaluates to a certain value.
#'
#' Test that the value calculated by the user's expression is the same as the
#' value calculated by the given expression.
#' @param expression An expression whose value will be compared to the value
#' of the user's expression.
#' @return \code{TRUE} or \code{FALSE}
#' @examples
#' \dontrun{
#' # Test that a user's expression evaluates to a certain value
#' #
#' calculates_same_value('matrix(1:20, nrow=4, ncol=5)')
#' }
#' @family AnswerTests
calculates_same_value <- function(expression){
e <- get("e", parent.frame())
# Calculate what the user should have done.
eSnap <- cleanEnv(e$snapshot)
val <- eval(parse(text=expression), eSnap)
passed <- isTRUE(all.equal(val, e$val))
if(!passed)e$delta <- list()
return(passed)
}

#' Test that the user's expression matches a regular expression.
#'
#' Returns \code{TRUE} if \code{as.character(e$val)} matches the regular
Expand All @@ -278,7 +303,7 @@ val_matches <- function(regular_expression) {
e <- get("e", parent.frame())
userVal <- str_trim(as.character(e$val))
results <- expectThat(userVal,
matches(regular_expression),
matches_legacy(regular_expression),
label=userVal)
if(is(e,"dev") && !results$passed)swirl_out(results$message)
return(results$passed)
Expand Down Expand Up @@ -323,7 +348,7 @@ var_is_a <- function(class, var_name) {
if(exists(var_name, globalenv())){
val <- get(var_name, globalenv())
label <- val
results <- expectThat(val, is_a(class), label=label)
results <- expectThat(val, is_a_legacy(class), label=label)
if(is(e,"dev") && !results$passed)swirl_out(results$message)
return(results$passed)
} else {
Expand All @@ -349,7 +374,7 @@ expr_is_a <- function(class) {
class <- str_trim(class)
expr <- e$expr
label <- deparse(e$expr)
results <- expectThat(expr, is_a(class), label=label)
results <- expectThat(expr, is_a_legacy(class), label=label)
if(is(e,"dev") && !results$passed)swirl_out(results$message)
return(results$passed)
}
Expand Down Expand Up @@ -405,12 +430,12 @@ expr_creates_var <- function(correctName=NULL){
e$delta
}
if(is.null(correctName)){
results <- expectThat(length(delta), equals(1),
results <- expectThat(length(delta), equals_legacy(1),
label=paste(deparse(e$expr),
"does not create a variable."))
} else {
results <- expectThat(names(delta),
is_equivalent_to(correctName, label=correctName),
is_equivalent_to_legacy(correctName, label=correctName),
label=paste(deparse(e$expr),
"does not create a variable named",
correctName))
Expand Down Expand Up @@ -445,7 +470,7 @@ val_has_length <- function(len){
stop(message=paste("BUG: specified length", len,
"is not an integer."))
}
results <- expectThat(length(e$val), equals(n, label=n),
results <- expectThat(length(e$val), equals_legacy(n, label=n),
label=paste0("length(c(", toString(e$val), "))"))
if( is(e, "dev") && !results$passed)swirl_out(results$message)
return(results$passed)
Expand Down Expand Up @@ -474,7 +499,7 @@ func_of_newvar_equals <- function(correct_expression){
correctExpr <- gsub("newVar", e$newVarName, correct_expression)
ans <- eval(parse(text=correctExpr), e1)
results <- expectThat(e$val,
equals(ans,
equals_legacy(ans,
label=correctExpr),
label=deparse(e$expr))
if(is(e, "dev") && !results$passed)swirl_out(results$message)
Expand Down
2 changes: 0 additions & 2 deletions R/swirl.R
Original file line number Diff line number Diff line change
Expand Up @@ -36,8 +36,6 @@
#' @export
#' @importFrom stringr str_c str_trim str_split str_length
#' @importFrom stringr str_detect str_locate fixed str_split_fixed
#' @importFrom testthat expectation equals is_equivalent_to
#' @importFrom testthat is_identical_to is_a matches
#' @import utils
#' @importFrom methods is
#' @examples
Expand Down
109 changes: 109 additions & 0 deletions R/testthat_legacy.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,109 @@
# The versions of the functions below have been graciously borrowed
# from version 0.11.0 of the testthat package by
# Hadley Wickham and others at RStudio. These APIs
# were broken in later versions of testthat and we know the
# old version works for our purposes.

expectation_legacy <- function(passed, failure_msg,
success_msg = "unknown",
srcref = NULL) {
structure(
list(
passed = passed,
error = FALSE,
skipped = FALSE,
failure_msg = failure_msg,
success_msg = success_msg,
srcref = srcref
),
class = "expectation"
)
}

#' @importFrom testthat compare
equals_legacy <- function(expected, label = NULL, ...) {
if (is.null(label)) {
label <- findExpr("expected")
} else if (!is.character(label) || length(label) != 1) {
label <- deparse(label)
}

function(actual) {
same <- compare(actual, expected, ...)

expectation_legacy(
same$equal,
paste0("not equal to ", label, "\n", same$message),
paste0("equals ", label)
)
}
}

is_a_legacy <- function(class) {
function(x) {
actual_s <- paste0(class(x), collapse = ", ")
class_s <- paste(class, collapse = ", ")
expectation_legacy(
inherits(x, class),
paste0("inherits from ", actual_s, " not ", class_s),
paste0("inherits from ", class_s)
)
}
}

is_equivalent_to_legacy <- function(expected, label = NULL) {
if (is.null(label)) {
label <- findExpr("expected")
} else if (!is.character(label) || length(label) != 1) {
label <- deparse(label)
}
function(actual) {
equals_legacy(expected, check.attributes = FALSE)(actual)
}
}

is_identical_to_legacy <- function(expected, label = NULL) {
if (is.null(label)) {
label <- findExpr("expected")
} else if (!is.character(label) || length(label) != 1) {
label <- deparse(label)
}

function(actual) {
if (identical(actual, expected)) {
diff <- ""
} else {
same <- all.equal(expected, actual)
if (isTRUE(same)) {
diff <- "Objects equal but not identical"
} else {
diff <- paste0(same, collapse = "\n")
}
}

expectation_legacy(
identical(actual, expected),
paste0("is not identical to ", label, ". Differences: \n", diff),
paste0("is identical to ", label)
)
}
}

matches_legacy <- function(regexp, all = TRUE, ...) {
stopifnot(is.character(regexp), length(regexp) == 1)
function(char) {
matches <- grepl(regexp, char, ...)
if (length(char) > 1) {
values <- paste0("Actual values:\n",
paste0("* ", encodeString(char), collapse = "\n"))
} else {
values <- paste0("Actual value: \"", encodeString(char), "\"")
}

expectation_legacy(
length(matches) > 0 && if (all) all(matches) else any(matches),
paste0("does not match '", encodeString(regexp), "'. ", values),
paste0("matches '", encodeString(regexp), "'")
)
}
}
Loading

0 comments on commit 06dd821

Please sign in to comment.