[Vinecopula-commits] r142 - / tests

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

Author: ulf
Date: 2015-09-21 18:16:45 +0200 (Mon, 21 Sep 2015)
New Revision: 142

Added:
   tests/
   tests/testCheck.r
   tests/testMain.r
   tests/testRun.r
Log:
New directory (not in the package) for systematic unit tests.
Started with BiCopPar2Tau and BiCopPar2Beta.Rd
Further tests and checks in the same style may follow.

Added: tests/testCheck.r
===================================================================
--- tests/testCheck.r	                        (rev 0)
+++ tests/testCheck.r	2015-09-21 16:16:45 UTC (rev 142)
@@ -0,0 +1,32 @@
+##' Testsuite - Check
+##' 
+##' Run several tests for the BiCop-functions of the VineCopula-package
+##' 
+##' @author Dr. Ulf Schepsmeier
+##' @param results list of results returned from testRun*
+
+testCheck <- function(results){
+  ## length of results
+  n <- length(results)
+  
+  check <- rep(TRUE, n)
+  
+  for(i in 1:n){
+    ## Check 1: is.na
+    if(any(is.na(results[[i]]))) check[i] <- FALSE
+    ## Check 2: is.nan
+    if(any(is.nan(results[[i]]))) check[i] <- FALSE
+    ## Check 3: is.infinite
+    if(any(is.infinite(results[[i]]))) check[i] <- FALSE
+    ## Check 4: in range
+    if(names(results)[i] %in% c(1:10,13,14,16:20,104,114,204,214)){
+      if(any( results[[i]] < 0 || results[[i]] > 1 ) ) check[i] <- FALSE
+    } else {
+      if(any( results[[i]] > 0 || results[[i]] < -1 ) ) check[i] <- FALSE
+    }
+    ## check for jumps
+    ## TODO
+  }
+  
+  return(check)
+}
\ No newline at end of file

Added: tests/testMain.r
===================================================================
--- tests/testMain.r	                        (rev 0)
+++ tests/testMain.r	2015-09-21 16:16:45 UTC (rev 142)
@@ -0,0 +1,35 @@
+##' Testsuite
+##' 
+##' Tests for the VineCopula package
+##' 
+##' @author Dr. Ulf Schepsmeier
+##' 
+
+## Main function
+
+library(VineCopula)
+
+source("../tests/testRun.r")
+source("../tests/testCheck.r")
+
+# BiCopPar2Tau
+results_BiCopPar2Tau <- testRunBiCopPar("BiCopPar2Tau")
+check_BiCopPar2Tau <- testCheck(results_BiCopPar2Tau)
+if(!all(check_BiCopPar2Tau)){
+  print(check_BiCopPar2Tau)
+} else {
+  rm(results_BiCopPar2Tau)
+  gc()
+}
+
+# BiCopPar2Beta
+results_BiCopPar2Beta <- testRunBiCopPar("BiCopPar2Beta")
+check_BiCopPar2Beta <- testCheck(results_BiCopPar2Beta)
+if(!all(check_BiCopPar2Beta)){
+  print(check_BiCopPar2Beta)
+} else {
+  rm(results_BiCopPar2Beta)
+  gc()
+}
+
+

Added: tests/testRun.r
===================================================================
--- tests/testRun.r	                        (rev 0)
+++ tests/testRun.r	2015-09-21 16:16:45 UTC (rev 142)
@@ -0,0 +1,100 @@
+##' Testsuite - Run
+##' 
+##' Run several tests for the BiCop-functions of the VineCopula-package
+##' 
+##' @author Dr. Ulf Schepsmeier
+##' @param FUN function name
+##' @return results list of results for each family
+
+
+## testRun for BiCopPar2Tau, BiCopPar2Beta
+## BiCopPar2TailDep geht so leider noch nicht, da lower und upper als return
+
+testRunBiCopPar <- function(FUN){
+  ## familyset
+  familyset <- c(1:10,13:20,23:30,33:40,104,114,124,134,204,214,224,234)
+  #familyset <- c(1:10,13:20,23:30)
+  familyset <- familyset[-which(familyset %in% c(15,25,35,36))]
+  
+  if(FUN == "BiCopPar2Beta") familyset <- familyset[-which(familyset == 2)]
+  
+  ## parameter sets
+  parset3 <- seq(0, 0.999, 0.001)
+  parset3a <- seq(1, 1.999, 0.001)
+  parset1 <- c(parset3, seq(1, 10, 0.01))
+  parset2 <- c(parset3a, seq(2, 10, 0.01))
+  parset4 <- seq(0, 50, 1)
+  
+  ## return the results in a list
+  results <- list()
+  
+  k <- 1
+  for(fam in familyset){  # run over all families
+    ## set the correct parameter set
+    if(fam == 1){
+      res <- rep(0, length(parset3))
+      par <- parset3
+    } else if(fam == 2){
+      res <- matrix(0, length(parset3), length(parset4))
+      par <- parset3
+      par2 <- parset4
+    } else if(fam %in% c(3, 13, 23, 33)){
+      res <- rep(0,length(parset1)-1)
+      par <- parset1[-1]
+    } else if(fam %in% c(4, 14, 24, 34)){
+      res <- rep(0,length(parset2))
+      par <- parset2
+    } else if(fam %in% c(6, 16, 26, 36)){
+      res <- rep(0,length(parset2)-1)
+      par <- parset2[-1]
+    } else if(fam %in% c(7, 17, 27, 37, 8, 18, 28, 38)){
+      res <- matrix(0, length(parset1)-1, length(parset2))
+      par <- parset1[-1]
+      par2 <- parset2
+    } else if(fam %in% c(9, 19, 29, 39)){
+      res <- matrix(0, length(parset2), length(parset1)-1)
+      par <- parset2
+      par2 <- parset1[-1]
+    } else if(fam %in% c(10, 20, 30, 40)){
+      res <- matrix(0, length(parset2), length(parset3)-1)
+      par <- parset2
+      par2 <- parset3[-1]
+    } else if(fam > 100){
+      res <- matrix(0, length(parset2), length(parset3))
+      par <- parset2
+      par2 <- parset3
+    }
+    
+    ## length of results (depending on the parameter set)
+    n1 <- ifelse(is.null(dim(res)), length(res), nrow(res))
+    n2 <- ifelse(is.null(dim(res)), 0, ncol(res))
+    
+    ## for rotated copulas switch sign
+    if(fam > 20 && fam < 100){
+      par <- -par
+      par2 <- -par2
+    } else if(fam %in% c(124,134,224,234)){
+      par <- -par
+    }
+    
+    for(i in 1:n1){
+      if(n2 == 0){
+        res[i] <- do.call(what=FUN, args=list(family=fam, par=par[i], par2=0))
+      } else {
+        for(j in n2){
+          res[i,j] <- do.call(what=FUN, args=list(family=fam, par=par[i], par2=par2[j]))
+        }
+      }
+    }
+    
+    ## save the results and give it the name of teh family
+    results[[k]] <- res
+    names(results)[[k]] <- as.character(fam)
+    
+    k <- k+1
+    
+  } # end familyset
+  
+  return(results)
+}
+