Merge pull request #131 from datacamp/support-inner-fun-def

Support multiple function definitions in a body

R/utils-pd.R

@@ -89,15 +89,18 @@ extract_function_definition <- function(pd, name) {
   sub_pds <- extract_assignments(pd, name)
   if(length(sub_pds) == 1) {
     pd <- sub_pds[[1]]
-    function_parent <- pd$parent[pd$token == "FUNCTION"]
-    if (length(function_parent) == 1) {
+    function_parents <- pd$parent[pd$token == "FUNCTION"]
+    if (length(function_parents) == 0) {
+      return(NULL)
+    }
+    fundefs <- lapply(function_parents, function(function_parent) {
       last_brother <- tail(pd$id[pd$parent == function_parent], 1)
       code <- getParseText(pd, last_brother)
       sub_pd <- get_sub_pd(pd, last_brother)
       return(list(code = code, pd = sub_pd))
-    } else {
-      return(NULL)
-    }
+    })
+    # only the first parent (if there are embbedded definitions)
+    return(fundefs[[1]])
   } else {
     return(NULL)
   }

tests/testthat/test-check-fun-def.R

@@ -9,7 +9,7 @@ test_that("check_fun_def - step by step", {
                  fundef %>% check_call(x = 2, y = 3) %>% check_result() %>% check_equal()
                  fundef %>% check_call(x = 2, y = 3L) %>% check_output() %>% check_equal()
                  fundef %>% check_call(x = 2L, y = 3L) %>% check_error() %>% check_equal()"
-  
+
   lst$DC_CODE <- ""
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you define the function")
@@ -43,27 +43,27 @@ test_that("check_fun_def - step by step", {
   fb_contains(output, "Did you correctly define the function <code>my_fun()</code>")
   fb_contains(output, "Running <code>my_fun(x = 2, y = 3)</code> didn&#39;t give the correct result. ")
   fb_contains(output, "The result has length 2, while it should have length 1")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); stopifnot(is.double(y)); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Running .*? generated an error")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Running .*? correct output\\. Expected <code>\\[1\\] 5</code>, but got <code>\\[1\\] &quot;a&quot;</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print(x + y); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "generate an error, but it should\\.")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print(x + y); if (!is.double(x)) { stop('blabla') }; return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "generate the correct error\\. Expected the error <code>is.double\\(x\\) is not TRUE</code>, but instead got the error <code>blabla</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { stopifnot(is.double(x)); print(x + y); return(x + y) }"
   capture.output(output <- test_it(lst))
   passes(output)
@@ -82,27 +82,27 @@ test_that("check_fun_def - step by step - custom", {
   lst$DC_CODE <- ""
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Notdefined")
-  
+
   lst$DC_CODE <- "my_fun <- 123"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Nofundef")
-  
+
   lst$DC_CODE <- "my_fun <- function(x) { return(x) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Incorrectnumargs")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Check the body")
   fails(output, mess_patt = "Have you called <code>print\\(\\)</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); stop('test') }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Error1")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); return(x + c(y, y)) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
@@ -113,24 +113,24 @@ test_that("check_fun_def - step by step - custom", {
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Error2")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "generate the correct output")
   fails(output, mess_patt = "Incorr2")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print(x + y); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Error3")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print(x + y); if (!is.double(x)) { stop('blabla') }; return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "generate the correct error")
   fails(output, mess_patt = "Incorr3")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { stopifnot(is.double(x)); print(x + y); return(x + y) }"
   capture.output(output <- test_it(lst))
   passes(output)
@@ -148,49 +148,49 @@ test_that("check_fun_def - backwards compatibility", {
                                           body_test = {
                                             test_function('print', 'x', eval = FALSE)
                                           })"
-  
+
   lst$DC_CODE <- ""
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you define the function")
-  
+
   lst$DC_CODE <- "my_fun <- 123"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Are you sure that .*? is a function")
-  
+
   lst$DC_CODE <- "my_fun <- function(x) { return(x) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Did you specify the correct number of arguments")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
   fails(output, mess_patt = "Check the body.*?Have you called <code>print\\(\\)</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); stop('test') }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); return(x + c(y, y)) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); stopifnot(is.double(y)); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print('a'); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "Did you correctly define the function <code>my_fun\\(\\)</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print(x + y); return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "generate an error, but it should\\.")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { print(x + y); if (!is.double(x)) { stop('blabla') }; return(x + y) }"
   capture.output(output <- test_it(lst))
   fails(output, mess_patt = "generate the correct error\\. Expected the error <code>is.double\\(x\\) is not TRUE</code>, but instead got the error <code>blabla</code>")
-  
+
   lst$DC_CODE <- "my_fun <- function(x, y) { stopifnot(is.double(x)); print(x + y); return(x + y) }"
   capture.output(output <- test_it(lst))
   passes(output)
@@ -208,6 +208,27 @@ test_that("check_fun_def - errs appropriately", {
   # TODO
 })
 
+test_that("embedded check_fun_def - outer function", {
+  lst <- list()
+  lst$DC_SOLUTION <- "my_fun <- function(x) { twice <- function(a) { a * 2 }; twice(x) }"
+  lst$DC_SCT <- "ex() %>% check_fun_def('my_fun') %>% check_body()"
+  lst$DC_CODE <- lst$DC_SOLUTION
+  capture.output(output <- test_it(lst))
+  passes(output)
+})
+
+test_that("check_fun_def - function instead of function def", {
+  lst <- list()
+  lst$DC_SOLUTION <- "my_fun <- function(x) { x + 2 }"
+  lst$DC_SCT <- "ex() %>% check_fun_def('my_fun') %>% check_body()"
+  lst$DC_CODE <- "my_fun <- mean"
+  capture.output(output <- test_it(lst))
+  fails(output, mess_patt = "Did you correctly define")
+})
+
+test_that("embedded check_fun_def - inner function", {
+  # TODO not supported yet
+})
 
 context("test_function_definition (old)")
 
@@ -376,4 +397,3 @@ test_that("test_function_definition works with control structure in there", {
   capture.output(output <- test_it(lst))
   passes(output)
 })
-

tests/testthat/test-content-examples.R

@@ -1,6 +1,6 @@
 context("content_examples")
 
-test_that("exercise intermediate R", {
+test_that("exercise intermediate r (1)", {
   lst <- list()
   lst$DC_CODE <- "today <- Sys.Date()\nday1 <- today - 11"
   lst$DC_SOLUTION <- "today <- Sys.Date()\nday1 <- today - 11"
@@ -9,7 +9,7 @@ test_that("exercise intermediate R", {
   passes(output)
 })
 
-test_that("exercise intermediate r", {
+test_that("exercise intermediate r (2)", {
   lst <- list()
   lst$DC_PEC <- "linkedin <- c(16, 9, 13, 5, 2, 17, 14)"
   lst$DC_SOLUTION <- "for (li in linkedin) { print(li) }"
@@ -23,16 +23,6 @@ test_that("exercise intermediate r", {
   passes(output)
 })
 
-test_that("exercise intermediate r - 2", {
-  lst <- list()
-  lst$DC_PEC <- 'load(url("http://s3.amazonaws.com/assets.datacamp.com/production/course_753/datasets/chapter2.RData"))'
-  lst$DC_CODE <- 'str(logs)\nlogs[[11]]$detaidls\nclass(logs[[1]]$timestamp)'
-  lst$DC_SOLUTION <- lst$DC_CODE
-  lst$DC_SCT <- 'test_function("class", "x", incorrect_msg = "Have you passed the `timestamp` component of `logs[[1]]` to `class()`?")'
-  output <- test_it(lst)
-  passes(output)
-})
-
 test_that("exercise ggplot2 - v1", {
   lst <- list()
   lst$DC_PEC <- "library(ggplot2)"
@@ -67,116 +57,17 @@ test_that("exercise ggplot2 - v2", {
   test_function_v2('qplot', c('data', 'x', 'y'), eval = c(T, F, F), index = 2)
   test_function_v2('qplot', c('data', 'x', 'y','geom'), eval = c(T, F, F, F), index = 3)
   test_error()
-  success_msg('Good job!')
   "
   lst$DC_SOLUTION <- "
-  # qplot() with x only
   qplot(factor(cyl), data = mtcars)
-
-  # qplot() with x and y
   qplot(factor(cyl), factor(vs), data = mtcars)
-
-  # qplot() with geom set to jitter manually
   qplot(factor(cyl), factor(vs), data = mtcars, geom = 'jitter')
   "
   lst$DC_CODE <- lst$DC_SOLUTION
   output <- test_it(lst)
   passes(output)
 })
 
-test_that("R for sas, spss, stata", {
-  lst <- list()
-  lst$DC_PEC <- "
-load(url(\"http://s3.amazonaws.com/assets.datacamp.com/course/Bob/mydata100.RData\"))
-pretest <- mydata100$pretest
-gender <- mydata100$gender
-  "
-  lst$DC_SOLUTION <- "
-by(pretest,
-   gender,
-   function(x){ c(mean(x, na.rm = TRUE),
-                sd(x, na.rm = TRUE),
-                median(x = x, na.rm = TRUE)) })
-  "
-  lst$DC_CODE <- lst$DC_SOLUTION
-  lst$DC_SCT <- '
-test_error()
-test_function("by", "data",
-  incorrect_msg = "There is something wrong with your data argument in the <code>by()</code> function.",
-  not_called_msg = "Use the <code>by()</code> function with the data specified as first argument.")
-  test_function("by", "INDICES",
-  incorrect_msg = "There is something wrong with the grouping of your <code>by()</code> function.",
-  not_called_msg = "Use the <code>by()</code> function with <code>gender</code> as grouping factor.")
-  test_function("by", "FUN",
-  incorrect_msg = "There is something wrong with the anonymous function in the <code>by()</code> function.",
-  not_called_msg = "Use the <code>by()</code> function with the anonymous that needs to be applied.")
-  '
-  output <- test_it(lst)
-  passes(output)
-})
-
-test_that("intermediate r practice", {
-  lst <- list()
-  lst$DC_PEC <- 'load(url("http://s3.amazonaws.com/assets.datacamp.com/production/course_753/datasets/chapter2.RData"))'
-  lst$DC_SCT <- '
-test_function("str", "object")
-#test_output_contains("logs[[11]]$details")
-#test_function("class", "x")
-success_msg("AWESOME!")
-  '
-  lst$DC_SOLUTION <- "
-str(logs)
-logs[[11]]$details
-class(logs[[1]])
-  "
-  lst$DC_CODE <- "
-print(logs)
-print(logs[[11]])
-print(str(logs[[1]]$timestamp))
-  "
-  output <- test_it(lst)
-  fails(output)
-})
-
-test_that("exercise eda", {
-  lst <- list()
-  lst$DC_PEC <- 'source("http://s3.amazonaws.com/assets.datacamp.com/production/course_1414/datasets/shared.R")
-votes_joined <- read_dataset("votes_joined")'
-  lst$DC_CODE <- '# Load the tidyr package
-library(tidyr)
-
-  # Gather the six mu/nu/di/hr/co/ec columns
-  votes_joined %>%
-  gather(topic, has_topic, me:ec)
-
-  # Perform gather again, then filter
-  votes_gathered <- votes_joined %>%
-  gather(topic, has_topic, me:ec) %>%
-  filter(has_topic == 1)'
-  lst$DC_SOLUTION <- lst$DC_CODE
-  lst$DC_SCT <- '
-test_library_function("tidyr")
-
-test_function("gather", args = c("data", "key", "value"), eval = c(T, F, F))
-
-test_correct({
-test_data_frame("votes_gathered", incorrect_msg = "Did you gather the six columns (`mu`, `nu`, `di`, `hr`, `co`, and `ec`) and filter such that `has_topic == 1`?")
-}, {
-test_function("gather", args = c("data", "key", "value"), eval = c(T, F, F))
-test_function("filter")
-})
-
-test_error()
-success_msg("Awesome job!")
-  '
-
-  output <- test_it(lst)
-  passes(output)
-  output <- test_it(lst)
-  passes(output)
-
-})
-
 # # NOT FIXED!
 # test_that("exercise cleaning data", {
 #   lst <- list()