[spcopula-commits] r164 - in pkg: . R man tests/Examples

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Tue Feb 28 14:45:36 CET 2017


Author: ben_graeler
Date: 2017-02-28 14:45:36 +0100 (Tue, 28 Feb 2017)
New Revision: 164

Added:
   pkg/R/trunCopula.R
   pkg/man/trunCopula-class.Rd
   pkg/man/trunCopula.Rd
Modified:
   pkg/DESCRIPTION
   pkg/NAMESPACE
   pkg/R/hkCopula.R
   pkg/R/returnPeriods.R
   pkg/man/asCopula-class.Rd
   pkg/man/cqsCopula-class.Rd
   pkg/man/mixtureCopula-class.Rd
   pkg/man/spVineCopula-class.Rd
   pkg/man/stVineCopula-class.Rd
   pkg/tests/Examples/spcopula-Ex.Rout.save
Log:
- adds truncated copula

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/DESCRIPTION	2017-02-28 13:45:36 UTC (rev 164)
@@ -1,8 +1,8 @@
 Package: spcopula
 Type: Package
 Title: Copula Driven Analysis - Multivariate, Spatial, Spatio-Temporal
-Version: 0.2-2
-Date: 2017-02-08
+Version: 0.2-4
+Date: 2017-02-28
 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"),
                     email = "b.graeler at 52north.org"),
              person("Marius", "Appel",role = "ctb"))
@@ -36,4 +36,5 @@
   tailDependenceFunctions.R
   KendallDistribution.R
   hkCopula.R
+  trunCopula.R
   zzz.R

Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/NAMESPACE	2017-02-28 13:45:36 UTC (rev 164)
@@ -47,6 +47,7 @@
 export(empiricalCopula, genEmpCop, empSurCopula, genEmpSurCop)
 export(mixtureCopula)
 export(hkCopula)
+export(trunCopula)
 
 # general functions
 export(rankTransform, dependencePlot, unitScatter, univScatter)
@@ -84,4 +85,5 @@
 exportClasses(spCopula, stCopula, spVineCopula, stVineCopula)
 exportClasses(stCoVarVineCopula)
 exportClasses(mixtureCopula)
-exportClasses(hkCopula)
\ No newline at end of file
+exportClasses(hkCopula)
+exportClasses(trunCopula)
\ No newline at end of file

Modified: pkg/R/hkCopula.R
===================================================================
--- pkg/R/hkCopula.R	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/R/hkCopula.R	2017-02-28 13:45:36 UTC (rev 164)
@@ -159,11 +159,6 @@
       smpl[boolLower,] <- qCopula_u(copula, rep(y, sum(boolLower)), appConPoint[boolLower, 1])
       smpl[!boolLower,] <- qCopula_v(copula, rep(y, sum(!boolLower)), appConPoint[!boolLower, 2])
     }
-    
-    # plot(uv, type="l", xlim=c(uv[dSeqInt+c(0,1)]+c(-1,1)/1000), asp=1)
-    # points(uv[dSeqInt+c(0,1),], col=c("red", "purple"))
-    # points(matrix(appConPoint, nrow = 1), col="green")
-    # points(matrix(smpl, nrow = 1), col="green", pch=2)
   }
 
   return(smpl)  

Modified: pkg/R/returnPeriods.R
===================================================================
--- pkg/R/returnPeriods.R	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/R/returnPeriods.R	2017-02-28 13:45:36 UTC (rev 164)
@@ -99,72 +99,77 @@
         })
 }
 
-
-setGeneric("qCopula_u",function(copula,p,u,...) {standardGeneric("qCopula_u")})
-
-qCopula_u.def <- function(copula,p,u, tol=.Machine$double.eps^.5) { # sample=NULL
-  dim <- copula at dimension
-  if(length(p) != length(u)) stop("Length of p and u differ!")
+qCopula_u.def <- function(copula, p, u, tol=.Machine$double.eps^.5) { # sample=NULL
+  copDim <- dim(copula)
+  stopifnot(length(p) == length(u)) 
   
-  params <- NULL
-  for(i in 1:length(p)) { # i <- 1
-    if (u[i] < p[i]) {
-      params <- rbind(params,rep(NA,dim-1))
-    } else {
-      if (dim == 2) {
-        params <- rbind(params, 
-                        optimize(function(v) abs(pCopula(cbind(rep(u[i],length(v)),v),copula)-p[i]),
-                                 c(p,1), tol=tol)$minimum)
+  if (copDim == 2) {
+    res <- sapply(1:length(p), 
+                  function(ind) {
+                    if (u[ind] < p[ind]) 
+                      return(NA)
+                    if (u[ind] == 1)
+                      return(p[ind])
+                    optimise(function(v) abs(pCopula(cbind(u[ind], v), copula) - p[ind]),
+                             c(p[ind], 1 + p[ind] - u[ind]), tol=tol)$minimum
+                  })
+  } else {
+  res < NULL
+    for(i in 1:length(p)) { # i <- 1
+      if (u[i] < p[i]) {
+        res <- rbind(res, rep(NA,dim-1))
       } else {
         opt <- optim(par=rep(p[i],dim-1), 
                      function(vw) abs(pCopula(c(u[i],vw), copula)-p[i]), 
                      lower=rep(p[i],dim-1), upper=rep(1,dim-1), method="L-BFGS-B")
-        params <- rbind(params, opt$par)
+        res <- rbind(res, opt$par)
       }
     }
   }
   
-  return(cbind(u,params))
+  return(cbind(u, res))
 }
 
+setGeneric("qCopula_u", function(copula, p, u, ...) standardGeneric("qCopula_u"))
 setMethod("qCopula_u", signature("copula"), qCopula_u.def)
 
 
-setGeneric("qCopula_v",function(copula,p,v,...) {standardGeneric("qCopula_v")})
-
-qCopula_v.def <- function(copula,p,v, tol=.Machine$double.eps^.5) { # sample=NULL
-  dim <- copula at dimension
-  if(length(p) != length(v)) stop("Length of p and v differ!")
+qCopula_v.def <- function(copula, p, v, tol=.Machine$double.eps^.5) {
+  copDim <- dim(copula)
+  if(length(p) != length(v)) 
+    stop("Length of p and u differ!")
   
-  params <- NULL
-  for(i in 1:length(p)) { # i <- 1
-    if (v[i] < p[i]) {
-      params <- rbind(params,rep(NA,dim-1))
-    } else {
-      if (dim == 2) {
-        params <- rbind(params, 
-                        optimize(function(u) abs(pCopula(cbind(u, rep(v[i],length(u))),copula)-p[i]),
-                                 c(p,1), tol=tol)$minimum)
+  if (copDim == 2) {
+    res <- sapply(1:length(p), 
+                  function(ind) {
+                    if (v[ind] < p[ind]) 
+                      return(NA)
+                    if (v[ind] == 1)
+                      return(p[ind])
+                    optimise(function(u) abs(pCopula(cbind(u, v[ind]), copula) - p[ind]),
+                             c(p[ind], 1 + p[ind] - v[ind]), tol=tol)$minimum
+                  })
+    res <- cbind(res, v)
+  } else {
+    res < NULL
+    for(i in 1:length(p)) { # i <- 1
+      if (v[i] < p[i]) {
+        res <- rbind(res,rep(NA,dim-1))
       } else {
         opt <- optim(par=rep(p[i],dim-1), 
-                     function(uw) abs(pCopula(c(uw[1],v[i],uw[2]), copula)-p[i]), 
+                     function(uw) abs(pCopula(c(uw[1], v[i], uw[2]), copula)-p[i]), 
                      lower=rep(p[i],dim-1), upper=rep(1,dim-1), method="L-BFGS-B")
-        params <- rbind(params, opt$par)
+        res <- rbind(res, opt$par)
       }
     }
+    
+    res <- cbind(res[,1], v, res[,2])
   }
   
-  if (dim == 2) {
-    return(cbind(params,v))
-  } else {
-    if (is.matrix(params))
-      return(cbind(params[,1], v, params[,2]))
-    else
-      return(cbind(params[1], v, params[2]))
-  }
-  
+  return(res)
 }
 
+setGeneric("qCopula_v", function(copula, p, v, ...) standardGeneric("qCopula_v"))
 setMethod("qCopula_v", signature("copula"), qCopula_v.def)
 
 

Added: pkg/R/trunCopula.R
===================================================================
--- pkg/R/trunCopula.R	                        (rev 0)
+++ pkg/R/trunCopula.R	2017-02-28 13:45:36 UTC (rev 164)
@@ -0,0 +1,295 @@
+## Truncated copulas exhibting a crisp boundary, often induced by lower bounds.
+## Points below the boundary are shifted "upwards" onto the boundary. Hence, 
+## considerable mass is concentrated on the boundary yielding a mixed density 
+## analougously to mixed discrete continuous distributions in the univariate 
+## case.
+
+# class truncated copula
+validTrunCop <- function(object) {
+  if(any(object at trunFamily@parameters != object at parameters[-c(length(object at parameters)-(1:0))])) {
+    warning("Missmatch of parameters between the parameter slot and the parameter slot of the \"trunFamily\".")
+  }
+  
+  ifelse(object at dimension == 2, TRUE, FALSE)
+}
+
+# Slots:
+#   
+#   Name:    trunFamily      contPar       .tools    dimension   parameters  param.names param.lowbnd  param.upbnd
+# Class:       copula      numeric         list      integer      numeric    character      numeric      numeric
+# 
+# Name:      fullname
+# Class:    character
+
+setClass("trunCopula", 
+         list("copula", trunFamily = "copula", contPar = "numeric", .tools = "list"),
+         validity = validTrunCop,
+         contains = list("copula"))
+
+trunCopula <- function(copula, contPar, approx.u=1:1000/1000) {
+  
+  # setting helper functions
+  contFun <- function(x) x^contPar
+  invContFun <- function(x) x^(1/contPar)
+  
+  trunFun <- approxfun(c(0, approx.u), 
+                       c(0, qCopula_u(copula, contFun(approx.u), approx.u)[,2]))
+
+  invTrunFun <- approxfun(trunFun(c(0, approx.u)), c(0, approx.u))
+  
+  CDF <-  approxfun(c(0, approx.u), 
+                    c(0, pCopula(cbind(invTrunFun(approx.u), approx.u), copula)))
+  invCDF <- approxfun(CDF(c(0, approx.u)), c(0, approx.u))
+
+  # calculate density along the contour line
+  dCont <- function(u) {
+    v <- trunFun(u)
+    (dduCopula(cbind(u,v), copula) - dduCopula(cbind(u,0), copula))
+  }
+  
+  new("trunCopula", 
+      dimension = dim(copula),
+      parameters = c(copula at parameters, contPar),
+      param.names = c(copula at param.names, "truncation"),
+      param.lowbnd = c(copula at param.lowbnd, -Inf),
+      param.upbnd = c(copula at param.upbnd, Inf),
+      fullname = "truncated copula",
+      trunFamily = copula,
+      contPar = contPar, 
+      .tools = list(trunFun = trunFun,
+                    invTrunFun = invTrunFun,
+                    CDF = CDF,
+                    invCDF = invCDF,
+                    contFun = contFun,
+                    invContFun = invContFun,
+                    dCont = dCont))
+}
+
+## console printing
+setMethod("describeCop", c("trunCopula", "character"),
+          function(x, kind = c("short", "very short", "long"), prefix = "", ...) {
+            kind <- match.arg(kind)
+            if(kind == "very short") # e.g. for show() which has more parts
+              return(paste0(prefix, "truncated copula"))
+            
+            name <- paste("truncated", describeCop(x at trunFamily, "very short"))
+            d <- dim(x)
+            ch <- paste0(prefix, name, ", dim. d = ", d)
+            switch(kind <- match.arg(kind),
+                   short = ch,
+                   long = paste0(ch, "\n", prefix, " param.: ",
+                                 capture.output(str(x at parameters,
+                                                    give.head=FALSE))),
+                   stop("invalid 'kind': ", kind))
+          })
+
+## density
+
+dTrunCop <- function(u, copula, log=FALSE, ..., tol=1e-3) {
+  if (log) {
+    res <- rep(NA, nrow(u))
+  } else {
+    res <- rep(0, nrow(u))
+  }
+  
+  contVals <- copula at .tools$contFun(u[,1])
+  diffContVals <- u[,2] - contVals
+  
+  # split in above and on contour
+  boolAbove <- diffContVals >= tol
+  boolContour <- abs(diffContVals) < tol
+  
+  # shift back
+  u[,2] <- sapply(u[,2], function(v) copula at .tools$invCDF(v))
+  
+  res[boolAbove] <- dCopula(u[boolAbove,], copula at trunFamily, log, ...)
+  
+  if (any(boolContour)) {
+    res[boolContour] <- copula at .tools$dCont(u[boolContour,1])
+    if (log)
+      res[boolContour] <- log(res[boolContour])
+  }
+  
+  return(res)
+}
+
+# setMethod(dCopula, c("matrix", "trunCopula"), dTrunCop)
+# 
+# setMethod(dCopula, c("numeric", "trunCopula"), 
+#           function(u, copula, log, ...) {
+#             dTrunCop(matrix(u, ncol=2), copula, log, ...)
+#           })
+
+## sampling from the trunCopula
+
+rTrunCop <- function(n, copula, ...) {
+  smpl <- rCopula(n, copula at trunFamily, ...)
+  smpl[,2] <- pmax(copula at .tools$CDF(smpl[,2]),
+                   copula at .tools$contFun(smpl[,1]))
+  
+  return(smpl)
+}
+
+setMethod(rCopula, c("numeric", "trunCopula"), rTrunCop)
+
+## CDF of the trunCopula
+
+pTrunCop <- function(u, copula, ...) {
+  res <- u[,1]
+  boolu11 <- u[,1] == 1
+  res[boolu11] <- u[boolu11,2]
+  
+  boolu21 <- u[,2] == 1
+  res[boolu21] <- u[boolu21,1]
+  
+  contVals <- copula at .tools$contFun(u[,1])
+  boolBelow <- u[,2] < contVals
+
+  u[boolBelow, 1] <- copula at .tools$invContFun(u[boolBelow,2])
+  
+  u[,2] <- copula at .tools$invCDF(u[,2])
+  
+  res[!(boolu11 | boolu21)] <- pCopula(u[!(boolu11 | boolu21),], copula at trunFamily)# , ...)
+  return(res)
+}
+
+setMethod(pCopula, c("numeric", "trunCopula"), 
+          function(u, copula, ...) pTrunCop(matrix(u, ncol = dim(copula)), copula, ...))
+
+setMethod(pCopula, c("matrix", "trunCopula"), pTrunCop)
+
+### CDF version ###
+fitTrunCop <- function(copula, data, ..., method, lower, upper, tol=1e-3) {
+  if (missing(method))
+    method <- ifelse(length(copula at trunFamily@parameters) > 1, "Nelder-Mead", "Brent")
+  if (missing(lower))
+    lower <- ifelse(is.infinite(copula at trunFamily@param.lowbnd), -1e3, copula at trunFamily@param.lowbnd)
+  if (missing(upper))
+    upper <- ifelse(is.infinite(copula at trunFamily@param.upbnd), 1e3, copula at trunFamily@param.upbnd)
+  
+  pEmpCop <- pCopula(data, empiricalCopula(data))
+  
+  optFun <- function(par) {
+    cat(par, "\n")
+    innerCop <- copula at trunFamily
+    innerCop at parameters <- par
+    cop <- trunCopula(innerCop, copula at contPar)
+    
+    mae <- mean(abs(pCopula(data, cop) - pEmpCop))
+    cat(mae, "\n")
+    mae
+  }
+  
+  optOut <- optim(copula at trunFamily@parameters, optFun, 
+                  method = method, lower = lower, upper = upper, ...)
+  
+  innerCop <- copula at trunFamily
+  innerCop at parameters <- optOut$par
+  cop <- trunCopula(innerCop, copula at contPar)
+  
+  new("fitCopula", 
+      copula=cop, 
+      estimate = c(optOut$par, copula at contPar),
+      var.est = matrix(NA),
+      loglik = sum(dCopula(data, cop, log=T, tol=tol)),
+      nsample = as.integer(nrow(data)),
+      method = "Copula CDF optimisation with fixed boundary.",
+      call = match.call(),
+      fitting.stats = optOut)
+}
+
+setMethod("fitCopula", c("trunCopula", "matrix"), fitTrunCop)
+
+# ## sample along contour
+rTrunCop_y <- function(y, copula, n=1, n.disc = 1000) {
+  stopifnot(copula at dimension == 2)
+  n.y <- length(y)
+  stopifnot(n.y == 1 | n == 1)
+  
+  uIntSec <- copula at .tools$invContFun(y)
+
+  smpl <- matrix(NA, n.y*n, 2)
+  
+  for (i in 1:n.y) { # i <- 1 i <- i+1
+    condVals <- seq(y[i], 1-(1-y[i])/n.disc^2, length.out = n.disc)
+    uv <- qCopula_v(copula, rep(y[i], n.disc-1), condVals[-1])
+    uv <- rbind(uv, qCopula_u(copula, rep(y[i], sum(condVals < uIntSec[i])),
+                              condVals[condVals < uIntSec[i]]))
+    uv <- uv[order(uv[,1]),]
+    
+    dSeq <- cumsum(c(0, apply((uv[-nrow(uv),]-uv[-1,])^2, 1, function (x) sqrt(sum(x)))))
+    probs <- dTrunCop(uv, copula)
+    
+    apFun <- approxfun(dSeq, probs, rule = 2)
+    probLine <- copula at .tools$dCont(uIntSec[i])
+    probCont <- integrate(apFun, 0, max(dSeq))$value
+    
+    rContour <- runif(n, 0, probCont + probLine)
+    
+    funAppConPoint <- function(rCont) {
+      invCDFContour <- function(x) {
+        abs(integrate(apFun, 0, x)$value - rCont)
+      } 
+      
+      lContour <- optimise(invCDFContour, c(0, max(dSeq)))$minimum
+      
+      dSeqInt <- findInterval(lContour, dSeq)
+      
+      lSeq <- sqrt(sum((uv[dSeqInt,]-uv[dSeqInt+1,])^2))
+      
+      uv[dSeqInt,] + (lContour - dSeq[dSeqInt])/lSeq * (uv[dSeqInt+1,]-uv[dSeqInt,])
+    }
+  
+    if (n == 1) {
+      if (rContour <= probLine) {
+        smpl[i,] <- c(uIntSec[i], y[i])
+        next;
+      }
+      rContour <- rContour - probLine
+      
+      appConPoint <- funAppConPoint(rContour)
+      
+      if (appConPoint[1] > appConPoint[2]) {
+        smpl[i,] <- qCopula_u(copula, y[i], appConPoint[1])
+      } else {
+        smpl[i,] <- qCopula_v(copula, y[i], appConPoint[2])
+      }
+    } else {
+      boolLine <- rContour <= probLine
+      smpl <- cbind(rep(uIntSec, n),
+                           rep(y, n))
+      rContour <- rContour - probLine
+      smpl[!boolLine,] <- t(sapply(rContour[!boolLine], funAppConPoint))
+      
+      boolLower <- smpl[,1] > smpl[,2]
+      if (any(boolLower & !boolLine))
+        smpl[boolLower & !boolLine,] <- qCopula_u(copula, rep(y[i], sum(boolLower & !boolLine)),
+                                                  smpl[boolLower & !boolLine, 1])
+      if (any(!boolLower & !boolLine))
+        smpl[!boolLower & !boolLine,] <- qCopula_v(copula, rep(y[i], sum(!boolLower & !boolLine)),
+                                                   smpl[!boolLower & !boolLine, 2])
+    }
+  }
+  
+  return(smpl)
+}
+
+setMethod(rCopula_y, signature = c("numeric", "trunCopula"), rTrunCop_y)
+
+## cond inverse
+
+qTrunCop_v <- function(copula, p, v, tol=.Machine$double.eps^.5) { # sample=NULL
+  stopifnot(length(p) == length(v)) 
+
+  cbind(sapply(1:length(p), 
+                function(ind) {
+                  if (v[ind] < p[ind]) 
+                    return(NA)
+                  if (v[ind] == 1)
+                    return(p[ind])
+                  optimise(function(u) abs(pCopula(cbind(u, v[ind]), copula) - p[ind]),
+                           c(p[ind], copula at .tools$invContFun(v[ind])), tol=tol)$minimum
+                }), v)
+}
+
+setMethod("qCopula_v", signature = c("trunCopula"), qTrunCop_v)

Modified: pkg/man/asCopula-class.Rd
===================================================================
--- pkg/man/asCopula-class.Rd	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/man/asCopula-class.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -6,7 +6,7 @@
 \alias{dduCopula,numeric,asCopula-method}
 \alias{ddvCopula,matrix,asCopula-method}
 \alias{ddvCopula,numeric,asCopula-method}
-\alias{fitCopula,asCopula-method}
+\alias{fitCopula,asCopula,ANY-method}
 \alias{invdduCopula,numeric,asCopula,numeric-method}
 \alias{invddvCopula,numeric,asCopula,numeric-method}
 

Modified: pkg/man/cqsCopula-class.Rd
===================================================================
--- pkg/man/cqsCopula-class.Rd	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/man/cqsCopula-class.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -6,7 +6,7 @@
 \alias{dduCopula,numeric,cqsCopula-method}
 \alias{ddvCopula,matrix,cqsCopula-method}
 \alias{ddvCopula,numeric,cqsCopula-method}
-\alias{fitCopula,cqsCopula-method}
+\alias{fitCopula,cqsCopula,ANY-method}
 \alias{invdduCopula,numeric,cqsCopula,numeric-method}
 \alias{invddvCopula,numeric,cqsCopula,numeric-method}
 

Modified: pkg/man/mixtureCopula-class.Rd
===================================================================
--- pkg/man/mixtureCopula-class.Rd	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/man/mixtureCopula-class.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -4,7 +4,7 @@
 \alias{mixtureCopula-class}
 \alias{dduCopula,ANY,mixtureCopula-method}
 \alias{ddvCopula,ANY,mixtureCopula-method}
-\alias{fitCopula,mixtureCopula-method}
+\alias{fitCopula,mixtureCopula,ANY-method}
 \alias{invdduCopula,numeric,mixtureCopula,numeric-method}
 \alias{invddvCopula,numeric,mixtureCopula,numeric-method}
 

Modified: pkg/man/spVineCopula-class.Rd
===================================================================
--- pkg/man/spVineCopula-class.Rd	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/man/spVineCopula-class.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -4,7 +4,7 @@
 \alias{spVineCopula-class}
 \alias{mixedSpVineCopula-class}
 \alias{pureSpVineCopula-class}
-\alias{fitCopula,spVineCopula-method}
+\alias{fitCopula,spVineCopula,ANY-method}
 
 \title{Class \code{"spVineCopula"}}
 \description{

Modified: pkg/man/stVineCopula-class.Rd
===================================================================
--- pkg/man/stVineCopula-class.Rd	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/man/stVineCopula-class.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -2,7 +2,7 @@
 \Rdversion{1.1}
 \docType{class}
 \alias{stVineCopula-class}
-\alias{fitCopula,stVineCopula-method}
+\alias{fitCopula,stVineCopula,ANY-method}
 
 \title{Class \code{"stVineCopula"}}
 \description{

Added: pkg/man/trunCopula-class.Rd
===================================================================
--- pkg/man/trunCopula-class.Rd	                        (rev 0)
+++ pkg/man/trunCopula-class.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -0,0 +1,49 @@
+\name{trunCopula-class}
+\Rdversion{1.1}
+\docType{class}
+\alias{trunCopula-class}
+\alias{fitCopula,trunCopula,matrix-method}
+\alias{qCopula_v,trunCopula-method}
+\alias{rCopula_y,numeric,trunCopula-method}
+
+\title{Class \code{"trunCopula"}}
+\description{
+A representation of a truncated copula where mass below a truncation boundary is pushed on to the the boundary.
+}
+\section{Objects from the Class}{
+Objects can be created by calls of the form \code{new("trunCopula", ...)}. Or via the simplified constructor \code{\link{trunCopula}}.
+}
+\section{Slots}{
+  \describe{
+    \item{\code{trunFamily}:}{Object of class \code{"copula"} of the underlying continuous copula.}
+    \item{\code{contPar}:}{Object of class \code{"numeric"} between 1 and infintiy defining the power 'p' of the truncation boundary 'u^p'.}
+    \item{\code{.tools}:}{Object of class \code{"list"} containing a couple of helper functions that are assigned via the constructor.}
+    \item{\code{dimension}:}{Object of class \code{"integer"} giving the dimesnion (currently only 2). }
+    \item{\code{parameters}:}{Object of class \code{"numeric"} representing the continuous copula parameters and the power 'p' as of 'contPar'.}
+    \item{\code{param.names}:}{Object of class \code{"character"} giving the parameter names. }
+    \item{\code{param.lowbnd}:}{Object of class \code{"numeric"} giving the parameter lower bounds.}
+    \item{\code{param.upbnd}:}{Object of class \code{"numeric"} giving the parameter upper bounds.}
+    \item{\code{fullname}:}{Object of class \code{"character"} <deprecated>. }
+  }
+}
+\section{Extends}{
+Class \code{"\linkS4class{copula}"}, directly.
+Class \code{"\linkS4class{parCopula}"}, by class "copula", distance 2.
+Class \code{"\linkS4class{Copula}"}, by class "copula", distance 3.
+}
+\section{Methods}{
+  \describe{
+    \item{fitCopula}{\code{signature(copula = "trunCopula", data = "matrix")}: ... }
+    \item{qCopula_v}{\code{signature(copula = "trunCopula", p = "numeric", v = "numeric")}: ... }
+    \item{rCopula_y}{\code{signature(y = "numeric", copula = "trunCopula")}: ... }
+	 }
+}
+\author{
+Benedikt Graeler
+}
+
+\examples{
+showClass("trunCopula")
+}
+
+\keyword{classes}

Added: pkg/man/trunCopula.Rd
===================================================================
--- pkg/man/trunCopula.Rd	                        (rev 0)
+++ pkg/man/trunCopula.Rd	2017-02-28 13:45:36 UTC (rev 164)
@@ -0,0 +1,39 @@
+\name{trunCopula}
+\alias{trunCopula}
+
+\title{
+Constructor of the truncated copula class.
+}
+\description{
+Returns a class \code{\linkS4class{trunCopula}} representing a truncated copula where mass of a continuous copula is concentrated in the boubndary curve. 
+}
+\usage{
+trunCopula(copula, contPar, approx.u = 1:1000/1000)
+}
+
+\arguments{
+  \item{copula}{the underlying continuous copula}
+  \item{contPar}{The power 'p' of the polynomial boundary 'x^p'.}
+  \item{approx.u}{a discretisation of the u-axis for numerical approximations}
+}
+\value{An object of \code{\linkS4class{trunCopula}}}
+\author{
+Benedikt Graeler}
+
+\examples{
+
+cop <- trunCopula(gumbelCopula(3), 1.2)
+cop
+
+smpl <- rCopula(100, cop)
+
+par(mfrow=c(2,2), mai=c(0.4,0.4,0.4,0.4))
+plot(smpl,asp=1, main="sample")
+
+contour(cop, pCopula, asp=1, main="CDF", n=201)
+points(rCopula_y(0.4, cop, 10), col="red")
+
+# too few points, but faster for package compilation
+kenCop <- getKendallDistr(cop, smpl)
+curve(kenCop, main="Kendall function", asp=1)
+}
\ No newline at end of file

Modified: pkg/tests/Examples/spcopula-Ex.Rout.save
===================================================================
--- pkg/tests/Examples/spcopula-Ex.Rout.save	2017-02-08 09:10:02 UTC (rev 163)
+++ pkg/tests/Examples/spcopula-Ex.Rout.save	2017-02-28 13:45:36 UTC (rev 164)
@@ -133,7 +133,7 @@
 > ### Title: Class '"asCopula"'
 > ### Aliases: asCopula-class dduCopula,matrix,asCopula-method
 > ###   dduCopula,numeric,asCopula-method ddvCopula,matrix,asCopula-method
-> ###   ddvCopula,numeric,asCopula-method fitCopula,asCopula-method
+> ###   ddvCopula,numeric,asCopula-method fitCopula,asCopula,ANY-method
 > ###   invdduCopula,numeric,asCopula,numeric-method
 > ###   invddvCopula,numeric,asCopula,numeric-method
 > ### Keywords: classes asymmetric copula copula
@@ -484,7 +484,7 @@
 > ### Title: Class '"cqsCopula"'
 > ### Aliases: cqsCopula-class dduCopula,matrix,cqsCopula-method
 > ###   dduCopula,numeric,cqsCopula-method ddvCopula,matrix,cqsCopula-method
-> ###   ddvCopula,numeric,cqsCopula-method fitCopula,cqsCopula-method
+> ###   ddvCopula,numeric,cqsCopula-method fitCopula,cqsCopula,ANY-method
 > ###   invdduCopula,numeric,cqsCopula,numeric-method
 > ###   invddvCopula,numeric,cqsCopula,numeric-method
 > ### Keywords: classes copula
@@ -1714,7 +1714,7 @@
 > ### Name: mixtureCopula-class
 > ### Title: Class '"mixtureCopula"'
 > ### Aliases: mixtureCopula-class dduCopula,ANY,mixtureCopula-method
-> ###   ddvCopula,ANY,mixtureCopula-method fitCopula,mixtureCopula-method
+> ###   ddvCopula,ANY,mixtureCopula-method fitCopula,mixtureCopula,ANY-method
 > ###   invdduCopula,numeric,mixtureCopula,numeric-method
 > ###   invddvCopula,numeric,mixtureCopula,numeric-method
 > ### Keywords: classes
@@ -1864,13 +1864,13 @@
 > 
 > uv <- qCopula_u(asCopula(c(-1,1)), p=rep(0.9,10), u=runif(10,0.9,1))
 > pCopula(uv,asCopula(c(-1,1)))-0.9
- [1] -5.285787e-09 -1.979502e-10  7.899040e-09 -5.241861e-09  2.531447e-09
- [6]  8.471355e-09 -6.502292e-09 -1.261782e-09  3.313125e-09  7.337630e-09
+ [1] -6.854504e-09 -2.410827e-09  7.820441e-09  4.006534e-09  1.189353e-09
+ [6]  7.326577e-09  2.424379e-09  5.285333e-09 -4.919274e-09 -2.558232e-09
 > 
 > uv <- qCopula_v(asCopula(c(-1,1)), p=rep(0.9,10), v=runif(10,0.9,1))
 > pCopula(uv,asCopula(c(-1,1)))-0.9
- [1] -1.033849e-09  4.513519e-09  8.776860e-09  2.134065e-09  3.399305e-09
- [6]  4.947090e-09  2.469908e-10  4.513539e-09  6.891024e-09 -3.606405e-09
+ [1]  1.414896e-08  2.142035e-09 -4.321133e-09  8.461797e-09 -7.768893e-09
+ [6] -1.606910e-08 -1.162496e-08 -3.348833e-10  1.726091e-09 -1.168865e-09
 > 
 > 
 > 
@@ -2648,7 +2648,7 @@
 > ### Name: spVineCopula-class
 > ### Title: Class '"spVineCopula"'
 > ### Aliases: spVineCopula-class mixedSpVineCopula-class
-> ###   pureSpVineCopula-class fitCopula,spVineCopula-method
+> ###   pureSpVineCopula-class fitCopula,spVineCopula,ANY-method
 > ### Keywords: classes
 > 
 > ### ** Examples
@@ -2997,7 +2997,7 @@
 > 
 > ### Name: stVineCopula-class
 > ### Title: Class '"stVineCopula"'
-> ### Aliases: stVineCopula-class fitCopula,stVineCopula-method
+> ### Aliases: stVineCopula-class fitCopula,stVineCopula,ANY-method
 > ### Keywords: classes
 > 
 > ### ** Examples
@@ -3118,6 +3118,74 @@
 > 
 > 
 > cleanEx()
+> nameEx("trunCopula-class")
+> ### * trunCopula-class
+> 
+> flush(stderr()); flush(stdout())
+> 
+> ### Name: trunCopula-class
+> ### Title: Class '"trunCopula"'
+> ### Aliases: trunCopula-class fitCopula,trunCopula,matrix-method
+> ###   qCopula_v,trunCopula-method rCopula_y,numeric,trunCopula-method
+> ### Keywords: classes
+> 
+> ### ** Examples
+> 
+> showClass("trunCopula")
+Class "trunCopula" [package "spcopula"]
+
+Slots:
+                                                                       
+Name:    trunFamily      contPar       .tools    dimension   parameters
+Class:       copula      numeric         list      integer      numeric
+                                                          
+Name:   param.names param.lowbnd  param.upbnd     fullname
+Class:    character      numeric      numeric    character
+
+Extends: 
+Class "copula", directly
+Class "parCopula", by class "copula", distance 2
+Class "Copula", by class "copula", distance 3
+> 
+> 
+> 
+> cleanEx()
+> nameEx("trunCopula")
+> ### * trunCopula
+> 
+> flush(stderr()); flush(stdout())
+> 
+> ### Name: trunCopula
+> ### Title: Constructor of the truncated copula class.
+> ### Aliases: trunCopula
+> 
+> ### ** Examples
+> 
+> 
+> cop <- trunCopula(gumbelCopula(3), 1.2)
+> cop
+truncated Gumbel copula, dim. d = 2 
+Dimension:  2 
+Parameters:
+  param        = 3.0
+  truncation   = 1.2
+> 
+> smpl <- rCopula(100, cop)
+> 
+> par(mfrow=c(2,2), mai=c(0.4,0.4,0.4,0.4))
+> plot(smpl,asp=1, main="sample")
+> 
+> contour(cop, pCopula, asp=1, main="CDF", n=201)
+> points(rCopula_y(0.4, cop, 10), col="red")
+> 
+> # too few points, but faster for package compilation
+> kenCop <- getKendallDistr(cop, smpl)
+> curve(kenCop, main="Kendall function", asp=1)
+> 
+> 
+> 
+> graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+> cleanEx()
 > nameEx("unitScatter")
 > ### * unitScatter
 > 
@@ -3140,7 +3208,7 @@
 > ###
 > options(digits = 7L)
 > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed:  12.88 0.41 14.08 NA NA 
+Time elapsed:  13.34 0.31 14.62 NA NA 
 > grDevices::dev.off()
 null device 
           1 



More information about the spcopula-commits mailing list