1 2## Copyright (C) 2010 - 2019 Dirk Eddelbuettel and Romain Francois 3## 4## This file is part of Rcpp. 5## 6## Rcpp is free software: you can redistribute it and/or modify it 7## under the terms of the GNU General Public License as published by 8## the Free Software Foundation, either version 2 of the License, or 9## (at your option) any later version. 10## 11## Rcpp is distributed in the hope that it will be useful, but 12## WITHOUT ANY WARRANTY; without even the implied warranty of 13## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14## GNU General Public License for more details. 15## 16## You should have received a copy of the GNU General Public License 17## along with Rcpp. If not, see <http://www.gnu.org/licenses/>. 18 19if (Sys.getenv("RunAllRcppTests") != "yes") exit_file("Set 'RunAllRcppTests' to 'yes' to run.") 20 21Rcpp::sourceCpp("cpp/Function.cpp") 22 23# test.Function <- function(){ 24expect_equal( function_( rnorm ), rnorm, info = "Function( CLOSXP )" ) 25expect_equal( function_( is.function ), is.function, info = "Pairlist( BUILTINSXP )" ) 26 27expect_error( function_(1:10), info = "Function( INTSXP) " ) 28expect_error( function_(TRUE), info = "Function( LGLSXP )" ) 29expect_error( function_(1.3), info = "Function( REALSXP) " ) 30expect_error( function_(as.raw(1) ), info = "Function( RAWSXP)" ) 31expect_error( function_(new.env()), info = "Function not compatible with environment" ) 32 33# test.Function.variadic <- function(){ 34expect_equal( function_variadic( sort, sample(1:20) ), 20:1, info = "calling function" ) 35expect_error( function_variadic(sort, sort), info = "Function, R error -> exception" ) 36 37# test.Function.env <- function(){ 38expect_equal( function_env(rnorm), asNamespace("stats" ), info = "Function::environment" ) 39expect_error( function_env(is.function), 40 info = "Function::environment( builtin) : exception" ) 41expect_error( function_env(`~`), 42 info = "Function::environment( special) : exception" ) 43 44# test.Function.unary.call <- function(){ 45expect_equal(function_unarycall( lapply( 1:10, function(n) seq(from=n, to = 0 ) ) ), 46 2:11 , info = "unary_call(Function)" ) 47 48# test.Function.binary.call <- function(){ 49data <- lapply( 1:10, function(n) seq(from=n, to = 0 ) ) 50res <- function_binarycall( data , rep(5L,10) ) 51expected <- lapply( data, pmin, 5 ) 52expect_equal( res, expected, info = "binary_call(Function)" ) 53 54# test.Function.namespace.env <- function() { 55exportedfunc <- function_namespace_env() 56expect_equal( stats:::.asSparse, exportedfunc, info = "namespace_env(Function)" ) 57 58# test.Function.cons.env <- function() { 59parent_env <- new.env() 60parent_env$fun_parent <- rbinom 61child_env <- new.env(parent = parent_env) 62child_env$fun_child <- rnorm 63 64expect_equal(rnorm, function_cons_env("fun_child", child_env), info = "env-lookup constructor") 65expect_equal(rbinom, function_cons_env("fun_parent", child_env), 66 info = "env-lookup constructor: search function in parent environments") 67expect_error(function_cons_env("fun_child", parent_env), 68 info = "env-lookup constructor: fail when function not found") 69 70# test.Function.cons.ns <- function() { 71expect_equal(Rcpp::sourceCpp, function_cons_ns("sourceCpp", "Rcpp"), 72 info = "namespace-lookup constructor") 73expect_error(function_cons_ns("sourceCpp", "Rcppp"), 74 info = "namespace-lookup constructor: fail when ns does not exist") 75expect_error(function_cons_ns("sourceCppp", "Rcpp"), 76 info = "namespace-lookup constructor: fail when function not found") 77 78# test.Function.eval <- function() { 79expect_error(exec(stop)) 80## should not throw exception 81exec(function() try(silent = TRUE, exec(stop))) 82 83## also check function is found in parent env 84