[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