[Rcpp-commits] r1797 - in pkg/Rcpp/inst: include/Rcpp/vector unitTests

[noreply at r-forge.r-project.org]

Author: romain
Date: 2010-07-07 11:03:15 +0200 (Wed, 07 Jul 2010)
New Revision: 1797

Modified:
   pkg/Rcpp/inst/include/Rcpp/vector/Vector.h
   pkg/Rcpp/inst/unitTests/runTests.R
   pkg/Rcpp/inst/unitTests/runit.sugar.R
Log:
trying to get more information in the 13 lines window

Modified: pkg/Rcpp/inst/include/Rcpp/vector/Vector.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/vector/Vector.h	2010-07-07 07:50:48 UTC (rev 1796)
+++ pkg/Rcpp/inst/include/Rcpp/vector/Vector.h	2010-07-07 09:03:15 UTC (rev 1797)
@@ -88,7 +88,7 @@
     template <bool __NA__, typename __VEC__>
     Vector( const VectorBase<RTYPE,__NA__,__VEC__>& other ) : RObject() {
     	int n = other.size() ;
-    	RObject::setSEXP( Rf_allocVector( RTYPE, other.size() ) ) ;
+    	RObject::setSEXP( Rf_allocVector( RTYPE, n ) ) ;
     	import_expression<__NA__,__VEC__>( other, n ) ;
 	}
     

Modified: pkg/Rcpp/inst/unitTests/runTests.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runTests.R	2010-07-07 07:50:48 UTC (rev 1796)
+++ pkg/Rcpp/inst/unitTests/runTests.R	2010-07-07 09:03:15 UTC (rev 1797)
@@ -48,7 +48,7 @@
 
     ## Define tests
     testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), dirs = path
-                                        # , testFileRegexp = "runit.Argument.R"
+                                    #   , testFileRegexp = "Vector"
                                  )
 
     ## this is crass but as we time out on Windows we have no choice
@@ -134,7 +134,27 @@
         ## This will cause R CMD check to return error and stop
         err <- getErrors(tests)
         if( (err$nFail + err$nErr) > 0) {
-            stop( sprintf( "unit test problems: %d failures, %d errors", err$nFail, err$nErr) )
+        	data <- Filter( 
+        		function(x) any( sapply(x, function(.) .[["kind"]] ) %in% c("error","failure") ) , 
+        		tests[[1]]$sourceFileResults )
+        	err_msg <- sapply( data, 
+        	function(x) {
+        		raw.msg <- paste( 
+        			sapply( Filter( function(.) .[["kind"]] %in% c("error","failure"), x ), "[[", "msg" ), 
+        			collapse = " // "
+        			)
+        		raw.msg <- gsub( "Error in compileCode(f, code, language = language, verbose = verbose) : \n", "", raw.msg, fixed = TRUE )
+        		raw.msg <- gsub( "\n", "", raw.msg, fixed = TRUE )
+        		raw.msg
+        		}
+        	)
+        	
+        	msg <- sprintf( sprintf( "unit test problems: %d failures, %d errors\n%s",
+        		err$nFail, err$nErr, 
+        		paste( err_msg, collapse = "\n" )
+        		) 
+           
+        	stop( msg )
         } else{
             success <- err$nTestFunc - err$nFail - err$nErr - err$nDeactivated
             cat( sprintf( "%d / %d\n", success, err$nTestFunc ) )

Modified: pkg/Rcpp/inst/unitTests/runit.sugar.R
===================================================================
--- pkg/Rcpp/inst/unitTests/runit.sugar.R	2010-07-07 07:50:48 UTC (rev 1796)
+++ pkg/Rcpp/inst/unitTests/runit.sugar.R	2010-07-07 09:03:15 UTC (rev 1797)
@@ -530,9 +530,7 @@
 }
 
 test.sugar.all.one.less <- function( ){
-
 	fx <- .rcpp.sugar$runit_all_one_less
-	
 	checkTrue( fx( 1 ) )
 	checkTrue( ! fx( 1:10 ) )
 	checkTrue( is.na( fx( NA ) ) )
@@ -542,7 +540,6 @@
 }
 
 test.sugar.all.one.greater <- function( ){
-
 	fx <- .rcpp.sugar$runit_all_one_greater
 	checkTrue( ! fx( 1 ) )
 	checkTrue( ! fx( 1:10 ) )
@@ -553,7 +550,6 @@
 
 
 test.sugar.all.one.less.or.equal <- function( ){
-
 	fx <- .rcpp.sugar$runit_all_one_less_or_equal
 	checkTrue( fx( 1 ) )
 	checkTrue( ! fx( 1:10 ) )
@@ -587,7 +583,6 @@
 }
 
 test.sugar.all.one.not.equal <- function( ){
-
 	fx <- .rcpp.sugar$runit_all_not_equal_one
 	checkTrue( fx( 1 ) )
 	checkTrue( fx( 1:2 ) )