[spcopula-commits] r83 - / pkg pkg/R pkg/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 7 17:16:33 CET 2013
Author: ben_graeler
Date: 2013-02-07 17:16:33 +0100 (Thu, 07 Feb 2013)
New Revision: 83
Added:
pkg/R/spVineCopula.R
pkg/man/copulaFromFamilyIndex.Rd
pkg/man/spVineCopula-class.Rd
pkg/man/spVineCopula.Rd
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/Classes.R
pkg/R/cqsCopula.R
pkg/R/linkingVineCopula.R
pkg/R/spCopula.R
pkg/R/spatialPreparation.R
pkg/R/utilities.R
pkg/R/vineCopulas.R
pkg/R/wrappingCFunctions.R
pkg/man/dduCopula-methods.Rd
pkg/man/ddvCopula-methods.Rd
pkg/man/spCopula-class.Rd
pkg/man/stCopula-class.Rd
pkg/man/vineCopula-class.Rd
pkg/man/vineCopula.Rd
spcopula_0.1-1.tar.gz
spcopula_0.1-1.zip
Log:
- new class spVineCopula
- adaptions to the VineCopula package
- spatial vine copulas may now use RVines instead of only C and D vines
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/DESCRIPTION 2013-02-07 16:16:33 UTC (rev 83)
@@ -2,7 +2,7 @@
Type: Package
Title: copula driven spatial analysis
Version: 0.1-1
-Date: 2013-01-30
+Date: 2013-02-07
Author: Benedikt Graeler
Maintainer: Benedikt Graeler <ben.graeler at uni-muenster.de>
Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of the spacetime package. Additionally, support for calculating different multivariate return periods is implemented.
@@ -29,5 +29,6 @@
joeBiCopula.R
ClaytonGumbelCopula.R
vineCopulas.R
+ spVineCopula.R
utilities.R
returnPeriods.R
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/NAMESPACE 2013-02-07 16:16:33 UTC (rev 83)
@@ -9,12 +9,12 @@
export(joeBiCopula, surJoeBiCopula, r90JoeBiCopula, r270JoeBiCopula)
export(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula)
export(surGumbelCopula, r90GumbelCopula, r270GumbelCopula)
-export(vineCopula)
+export(vineCopula, spVineCopula)
export(neighbourhood)
export(empiricalCopula, genEmpCop)
# general functions
-export(rankTransform, dependencePlot, unitScatter, univScatter)
+export(rankTransform, dependencePlot, unitScatter, univScatter, copulaFromFamilyIndex)
export(fitCopula)
export(dduCopula,ddvCopula)
export(invdduCopula, invddvCopula)
@@ -38,6 +38,7 @@
## classes
exportClasses(asCopula, cqsCopula, neighbourhood, empiricalCopula)
+exportClasses(vineCopula, spCopula, stCopula, spVineCopula)
# wrappers to CDVine
exportClasses(BB1Copula, surBB1Copula, r90BB1Copula, r270BB1Copula)
@@ -48,6 +49,4 @@
exportClasses(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula)
exportClasses(surGumbelCopula, r90GumbelCopula, r270GumbelCopula)
-exportClasses(vineCopula, spCopula, stCopula)
-
useDynLib("spcopula")
\ No newline at end of file
Modified: pkg/R/Classes.R
===================================================================
--- pkg/R/Classes.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/Classes.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -132,8 +132,39 @@
t.res="character"),
validity = validStCopula, contains = list("copula"))
+####################
+## vine copulas ##
+####################
+validVineCopula = function(object) {
+ dim <- object at dimension
+ if( dim <= 2)
+ return("Number of dimension too small (>2).")
+ if(length(object at copulas)!=(dim*(dim-1)/2))
+ return("Number of provided copulas does not match given dimension.")
+ if(!any(unlist(lapply(object at copulas,function(x) is(x,"copula")))))
+ return("Not all provided copulas in your list are indeed copulas.")
+ else return (TRUE)
+}
+setClass("vineCopula",
+ representation = representation(copulas="list", dimension="integer",
+ RVM="list"),
+ validity = validVineCopula,
+ contains = list("copula")
+)
+
+#########################
+## Spatial Vine Copula ##
+#########################
+
+validSpVineCopula <- function(object) {
+ return(validObject(object at spCop)&validObject(object at vineCop))
+}
+
+setClass("spVineCopula", representation("copula",spCop="spCopula",vineCop="vineCopula"),
+ validity = validSpVineCopula, contains=list("copula"))
+
########################################
## spatial classes providing the data ##
########################################
@@ -160,7 +191,7 @@
if (sizeN > sizeLim) return("The limting size of the neighbourhood is exceeded. Increase the constant sizeLim if needed.")
if (nrow(object at data) != nrow(object at distances)) return("Data and distances have unequal number of rows.")
if (ncol(object at data) %% sizeN != 0) return("Data and distances have non matching number of columns.")
- if (nrow(object at data) != nrow(object at coords) ) return("Data and sp at coordinates have unequal number of rows.")
+# if (nrow(object at data) != nrow(object at coords) ) return("Data and sp at coordinates have unequal number of rows.")
if (nrow(object at data) != nrow(object at index)) return("Data and index have unequal number of rows.")
if (sizeN != ncol(object at index)) return("Data and index have unequal number of columns.")
if (ncol(object at data) != sizeN * nVars) return(paste("Number of columns in data does not equal the product of the neighbourhood's size (",sizeN,") with number of variables (",nVars,").",sep=""))
Modified: pkg/R/cqsCopula.R
===================================================================
--- pkg/R/cqsCopula.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/cqsCopula.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -208,7 +208,7 @@
ml=fitCQSec.ml(copula, data, start, lower, upper, optim.control, optim.method),
itau=fitCQSec.itau(copula, data, estimate.variance),
irho=fitCQSec.irho(copula, data, estimate.variance),
- stop("Implemented methods for copulas in the spCopula package are: ml, itau, and irho."))
+ stop("Implemented methods for copulas in the spcopula package are: ml, itau, and irho."))
return(fit)
}
@@ -226,8 +226,9 @@
# method
# one of kendall or spearman according to the calculation of moa
-fitCQSec.itau <- function(copula, data, estimate.variance) {
-tau <- cor(data,method="kendall")[1,2]
+fitCQSec.itau <- function(copula, data, estimate.variance, tau=NULL) {
+if(is.null(tau))
+ tau <- VineCopula:::fasttau(data[,1],data[,2])
esti <- fitCQSec.moa(tau, data, method="itau")
copula <- cqsCopula(esti)
return(new("fitCopula",
Modified: pkg/R/linkingVineCopula.R
===================================================================
--- pkg/R/linkingVineCopula.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/linkingVineCopula.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -124,27 +124,27 @@
return(matrix(tmp, ncol = 2))
}
-## transform a fit from CDVine to a list of copula objects
-castCDvine <- function(cdvEst) {
- copulas <- NULL
- for(i in 1: length(cdvEst$family)) {
- par1 <- cdvEst$par[i]
- par2 <- cdvEst$par2[i]
- cop <- switch(paste("fam",cdvEst$family[i],sep=""), fam0=indepCopula(dim=2), fam1=normalCopula(par1), fam2=tCopula(par1,df=par2),
- fam3=claytonCopula(par1), fam4=gumbelCopula(par1), fam5=frankCopula(par1), fam6=joeBiCopula(par1),
- fam7=BB1Copula(c(par1,par2)), fam8=BB6Copula(c(par1,par2)), fam9=BB7Copula(c(par1,par2)), fam10=BB8Copula(c(par1,par2)),
- fam13=surClaytonCopula(par1), fam14=surGumbelCopula(par1), fam16=surJoeBiCopula(par1),
- fam17=surBB1Copula(c(par1,par2)), fam18=surBB6Copula(c(par1,par2)), fam19=surBB7Copula(c(par1,par2)), fam20=surBB8Copula(c(par1,par2)),
- fam23=r90ClaytonCopula(par1), fam24=r90GumbelCopula(par1), fam26=r90JoeBiCopula(par1),
- fam27=r90BB1Copula(c(par1,par2)), fam28=r90BB6Copula(c(par1,par2)), fam29=r90BB7Copula(c(par1,par2)), fam30=r90BB8Copula(c(par1,par2)),
- fam33=r270ClaytonCopula(par1), fam34=r270GumbelCopula(par1), fam36=r270JoeBiCopula(par1),
- fam37=r270BB1Copula(c(par1,par2)),fam38=r270BB6Copula(c(par1,par2)),fam39=r270BB7Copula(c(par1,par2)),fam40=r270BB8Copula(c(par1,par2)))
-
- copulas <- append(copulas, cop)
- }
- if(length(copulas) ==1) copulas <- copulas[[1]]
- return(copulas)
-}
+# ## transform a fit from CDVine to a list of copula objects
+# castCDvine <- function(cdvEst) {
+# copulas <- NULL
+# for(i in 1: length(cdvEst$family)) {
+# par1 <- cdvEst$par[i]
+# par2 <- cdvEst$par2[i]
+# cop <- switch(paste("fam",cdvEst$family[i],sep=""), fam0=indepCopula(dim=2), fam1=normalCopula(par1), fam2=tCopula(par1,df=par2),
+# fam3=claytonCopula(par1), fam4=gumbelCopula(par1), fam5=frankCopula(par1), fam6=joeBiCopula(par1),
+# fam7=BB1Copula(c(par1,par2)), fam8=BB6Copula(c(par1,par2)), fam9=BB7Copula(c(par1,par2)), fam10=BB8Copula(c(par1,par2)),
+# fam13=surClaytonCopula(par1), fam14=surGumbelCopula(par1), fam16=surJoeBiCopula(par1),
+# fam17=surBB1Copula(c(par1,par2)), fam18=surBB6Copula(c(par1,par2)), fam19=surBB7Copula(c(par1,par2)), fam20=surBB8Copula(c(par1,par2)),
+# fam23=r90ClaytonCopula(par1), fam24=r90GumbelCopula(par1), fam26=r90JoeBiCopula(par1),
+# fam27=r90BB1Copula(c(par1,par2)), fam28=r90BB6Copula(c(par1,par2)), fam29=r90BB7Copula(c(par1,par2)), fam30=r90BB8Copula(c(par1,par2)),
+# fam33=r270ClaytonCopula(par1), fam34=r270GumbelCopula(par1), fam36=r270JoeBiCopula(par1),
+# fam37=r270BB1Copula(c(par1,par2)),fam38=r270BB6Copula(c(par1,par2)),fam39=r270BB7Copula(c(par1,par2)),fam40=r270BB8Copula(c(par1,par2)))
+#
+# copulas <- append(copulas, cop)
+# }
+# if(length(copulas) ==1) copulas <- copulas[[1]]
+# return(copulas)
+# }
## Kendall's tau
linkVineCop.tau <- function(copula) {
Modified: pkg/R/spCopula.R
===================================================================
--- pkg/R/spCopula.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/spCopula.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -199,7 +199,7 @@
res <- numeric(nrow(pairs))
sel <- which(h < dists[1])
if(sum(sel)>0) {
- res[sel] <- fun(pairs[sel,,drop=FALSE],copula at components[[1]],...)
+ res[sel] <- fun(pairs[sel,,drop=FALSE],copula at components[[1]], ...)
}
if (n.dists >= 2) {
@@ -302,11 +302,10 @@
}
if(is.null(copula at calibMoa(normalCopula(0),0))){
- res <- spConCop(dCopula, copula, u, rep(h, length.out=nrow(pairs)),
+ res <- spConCop(dCopula, copula, u, rep(h, length.out=n),
do.logs=log, log=log)
}
else {
- cat("Yes \n")
if(length(h)>1) {
if (block == 1){
ordering <- order(h)
@@ -344,34 +343,28 @@
## dduSpCopula
###############
-dduSpCopula <- function (u, copula) {
- if (!is.list(u) || !length(u)>=2) stop("Point pairs need to be provided with their separating distance as a list.")
+dduSpCopula <- function (u, copula, h, block=1) {
+ if (missing(h)) stop("Point pairs need to be provided with their separating distance h.")
- pairs <- u[[1]]
- n <- nrow(pairs)
+ n <- nrow(u)
- if(length(u)==3) {
- block <- u[[3]]
- if (n%%block != 0) stop("The block size is not a multiple of the data length:",n)
- } else block <- 1
-
- h <- u[[2]]
- if(length(h)>1 && length(h)!=nrow(u[[1]])) {
+ if(length(h)>1 && length(h)!=n) {
stop("The distance vector must either be of the same length as rows in the data pairs or a single value.")
}
- if(is.null(copula at calibMoa(normalCopula(0),0))) res <- spConCop(dduCopula, copula, pairs,
- rep(h,length.out=nrow(pairs)))
+ if(is.null(copula at calibMoa(normalCopula(0),0)))
+ res <- spConCop(dduCopula, copula, u, rep(h, length.out=n))
+
else {
if(length(h)>1) {
if (block == 1){
ordering <- order(h)
# ascending sorted pairs allow for easy evaluation
- pairs <- pairs[ordering,,drop=FALSE]
+ u <- u[ordering,,drop=FALSE]
h <- h[ordering]
- res <- spDepFunCop(dduCopula, copula, pairs, h)
+ res <- spDepFunCop(dduCopula, copula, u, h)
# reordering the values
res <- res[order(ordering)]
@@ -379,52 +372,48 @@
res <- NULL
for(i in 1:(n%/%block)) {
res <- c(res, spDepFunCopSnglDist(dduCopula, copula,
- pairs[((i-1)*block+1):(i*block),],
+ u[((i-1)*block+1):(i*block),],
h[i*block]))
}
}
} else {
- res <- spDepFunCopSnglDist(dduCopula, copula, pairs, h)
+ res <- spDepFunCopSnglDist(dduCopula, copula, u, h)
}
}
return(res)
}
-setMethod("dduCopula", signature("list","spCopula"), dduSpCopula)
+setMethod("dduCopula", signature("matrix","spCopula"), dduSpCopula)
+setMethod("dduCopula", signature("numeric","spCopula"),
+ function(u, copula, ...) dduSpCopula(matrix(u,ncol=copula at dimension),copula, ...) )
## ddvSpCopula
###############
-ddvSpCopula <- function (u, copula) {
- if (!is.list(u) || !length(u)>=2) stop("Point pairs need to be provided with their separating distance as a list.")
+
+ddvSpCopula <- function (u, copula, h, block=1) {
+ if (missing(h)) stop("Point pairs need to be provided with their separating distance h.")
- pairs <- u[[1]]
- n <- nrow(pairs)
+ n <- nrow(u)
- if(length(u)==3) {
- block <- u[[3]]
- if (n%%block != 0) stop("The block size is not a multiple of the data length:",n)
- } else block <- 1
-
- h <- u[[2]]
- if(length(h)>1 && length(h)!=nrow(u[[1]])) {
+ if(length(h)>1 && length(h)!=n) {
stop("The distance vector must either be of the same length as rows in the data pairs or a single value.")
}
+ if(is.null(copula at calibMoa(normalCopula(0),0)))
+ res <- spConCop(dduCopula, copula, u, rep(h, length.out=n))
- if(is.null(copula at calibMoa(normalCopula(0),0))) res <- spConCop(ddvCopula, copula, pairs,
- rep(h,length.out=nrow(pairs)))
else {
if(length(h)>1) {
if (block == 1){
ordering <- order(h)
# ascending sorted pairs allow for easy evaluation
- pairs <- pairs[ordering,,drop=FALSE]
+ u <- u[ordering,,drop=FALSE]
h <- h[ordering]
- res <- spDepFunCop(ddvCopula, copula, pairs, h)
+ res <- spDepFunCop(ddvCopula, copula, u, h)
# reordering the values
res <- res[order(ordering)]
@@ -432,19 +421,21 @@
res <- NULL
for(i in 1:(n%/%block)) {
res <- c(res, spDepFunCopSnglDist(ddvCopula, copula,
- pairs[((i-1)*block+1):(i*block),],
+ u[((i-1)*block+1):(i*block),],
h[i*block]))
}
}
} else {
- res <- spDepFunCopSnglDist(ddvCopula, copula, pairs, h)
+ res <- spDepFunCopSnglDist(ddvCopula, copula, u, h)
}
}
return(res)
}
-setMethod("ddvCopula", signature("list","spCopula"), ddvSpCopula)
+setMethod("ddvCopula", signature("matrix","spCopula"), ddvSpCopula)
+setMethod("ddvCopula", signature("numeric","spCopula"),
+ function(u, copula, ...) ddvSpCopula(matrix(u,ncol=copula at dimension),copula, ...) )
#############
Added: pkg/R/spVineCopula.R
===================================================================
--- pkg/R/spVineCopula.R (rev 0)
+++ pkg/R/spVineCopula.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -0,0 +1,48 @@
+#########################################
+## methods for the spatial vine copula ##
+#########################################
+
+# constructor
+spVineCopula <- function(spCop, vineCop) {
+ new("spVineCopula", dimension = as.integer(vineCop at dimension+1), parameters=numeric(),
+ param.names = character(), param.lowbnd = numeric(),
+ param.upbnd = numeric(), fullname = "Spatial vine copula family.",
+ spCop=spCop, vineCop=vineCop)
+}
+
+# show
+showSpVineCopula <- function(object) {
+ dim <- object at dimension
+ cat(object at fullname, "\n")
+ cat("Dimension: ", dim, "\n")
+}
+
+setMethod("show", signature("spVineCopula"), showSpVineCopula)
+
+# density
+dspVine <- function(u, spCop, vine, log, h) {
+ l0 <- rep(0,nrow(u)) # level 0 (spatial) density
+ u0 <- NULL # level 0 conditional data
+
+ if(!is.matrix(h)) h <- matrix(h, ncol=length(h))
+
+ for(i in 1:(ncol(u)-1)) { # i <- 1
+ l0 <- l0+dCopula(as.matrix(u[,c(1,i+1)]), spCop, h=h[,i], log=T)
+ u0 <- cbind(u0, dduCopula(as.matrix(u[,c(1,i+1)]), spCop, h=h[,i]))
+ }
+
+ l1 <- dCopula(u0, vine, log=T)
+ if(log)
+ return(l0+l1)
+ else(exp(l0+l1))
+}
+
+setMethod("dCopula",signature=signature("matrix","spVineCopula"),
+ function(u, copula, ...) {
+ dspVine(u, copula at spCop, copula at vineCop, ...)
+ })
+
+setMethod("dCopula",signature=signature("numeric","spVineCopula"),
+ function(u, copula, ...) {
+ dspVine(matrix(u,ncol=copula at dimension), copula at spCop, copula at vineCop, ...)
+ })
\ No newline at end of file
Property changes on: pkg/R/spVineCopula.R
___________________________________________________________________
Added: svn:eol-style
+ LF
Modified: pkg/R/spatialPreparation.R
===================================================================
--- pkg/R/spatialPreparation.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/spatialPreparation.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -60,7 +60,7 @@
if(is.null(dep) & !is.null(indep)) dep <- 1:nLocs[-indep]
if(!is.null(dep) & is.null(indep)) indep <- 1:nLocs[-dep]
if(!is.null(dep) & !is.null(indep)) {
- cat("Reduced distance matrix is used: (",dep,") x (",indep,")",sep="")
+ cat("Reduced distance matrix is used: (",paste(dep,collapse=", "),") x (",paste(indep,collapse=", "),")",sep="")
} else {
dep <- 1:nLocs
indep <- 1:nLocs
Modified: pkg/R/utilities.R
===================================================================
--- pkg/R/utilities.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/utilities.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -58,4 +58,25 @@
univScatter <- function(formula=NULL, smpl) {
.Deprecated("unitScatter")
unitScatter(formula, smpl)
+}
+
+copulaFromFamilyIndex <- function(family, par, par2=0) {
+ constr <- switch(family+1, function(par) indepCopula(),
+ function(par) normalCopula(par[1]), function(par) tCopula(par[1],df=par[2]),
+ function(par) claytonCopula(par[1]), function(par) gumbelCopula(par[1]),
+ function(par) frankCopula(par[1]), function(par) joeBiCopula(par[1]),
+ BB1Copula, BB6Copula, BB7Copula, BB8Copula,
+ NULL, NULL,
+ function(par) surClaytonCopula(par[1]), function(par) surGumbelCopula(par[1]),
+ NULL, function(par) surJoeBiCopula(par[1]),
+ surBB1Copula, surBB6Copula, surBB7Copula, surBB8Copula,
+ NULL, NULL,
+ function(par) r90ClaytonCopula(par[1]), function(par) r90GumbelCopula(par[1]),
+ NULL, function(par) r90JoeBiCopula(par[1]),
+ r90BB1Copula, r90BB6Copula, r90BB7Copula, r90BB8Copula,
+ NULL, NULL,
+ function(par) r270ClaytonCopula(par[1]), function(par) r270GumbelCopula(par[1]),
+ NULL, function(par) r270JoeBiCopula(par[1]),
+ r270BB1Copula, r270BB6Copula, r270BB7Copula, r270BB8Copula)
+ constr(c(par,par2))
}
\ No newline at end of file
Modified: pkg/R/vineCopulas.R
===================================================================
--- pkg/R/vineCopulas.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/vineCopulas.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -4,39 +4,26 @@
## ##
####################
-validVineCopula = function(object) {
- dim <- object at dimension
- if( dim <= 2)
- return("Number of dimension too small (>2).")
- if(length(object at copulas)!=(dim*(dim-1)/2))
- return("Number of provided copulas does not match given dimension.")
- if(!any(unlist(lapply(object at copulas,function(x) is(x,"copula")))))
- return("Not all provided copulas in your list are indeed copulas.")
- if(!(object at type == "c-vine" | object at type == "d-vine"))
- return("Only c-vines and d-vines are implemented.")
- else return (TRUE)
-}
-
-setClass("vineCopula",
- representation = representation(copulas="list", dimension="integer",
- type="character"),
- validity = validVineCopula,
- contains = list("copula")
-)
-
# constructor
-vineCopula <- function (copulas, dim, type) {
- new("vineCopula", copulas=copulas, dimension = as.integer(dim), parameters = numeric(),
+vineCopula <- function (RVM) {
+ if(class(RVM)=="RVineMatrix") # handling non S4-class as subelement in a S4-class
+ class(RVM) <- "list"
+ ltr <- lower.tri(RVM$Matrix)
+ copDef <- cbind(RVM$family[ltr], RVM$par[ltr], RVM$par2[ltr])
+ copulas <- apply(copDef,1, function(x) copulaFromFamilyIndex(x[1],x[2],x[3]))
+
+ new("vineCopula", copulas=copulas, dimension = as.integer(nrow(RVM$Matrix)),
+ RVM=RVM, parameters = numeric(),
param.names = character(), param.lowbnd = numeric(),
- param.upbnd = numeric(), type=type,
- fullname = paste(type, "copula family."))
+ param.upbnd = numeric(), fullname = paste("RVine copula family."))
}
showVineCopula <- function(object) {
+ dim <- object at dimension
cat(object at fullname, "\n")
- cat("Dimension: ", object at dimension, "\n")
- cat("Copulas:\n")
- for (i in (1:length(object at copulas))) {
+ cat("Dimension: ", dim, "\n")
+ cat("Represented by the following",dim*(dim-1)/2, "copulas:\n")
+ for (i in 1:length(object at copulas)) {
cat(" ", class(object at copulas[[i]]), "with parameter(s)",
object at copulas[[i]]@parameters, "\n")
}
@@ -44,120 +31,124 @@
setMethod("show", signature("vineCopula"), showVineCopula)
-## num type
-
-getNumType <- function(copula) {
- if (copula at type == "c-vine") return(1)
- else return(2)
-}
-
## density ##
-## d-vine structure
-
-# copula <- vineFit
-# u <- empVine
-# empCopVine
-
-# dDvine(vineFit, empVine,log=T)
-
-dDvine <- function(copula, u, log=FALSE){
- dim <- copula at dimension
- tmp <- u
- u <- NULL
- u[[1]] <- matrix(tmp,ncol=dim)
-
- den <- rep(1,nrow(u[[1]]))
-
- newU <- NULL
- for (i in 1:(dim-1)) {
- tmpCop <- copula at copulas[[i]]
- tmpU <- u[[1]][,i:(i+1)]
- if(log)
- den <- den + dCopula(tmpU, tmpCop,log=T)
- else
- den <- den*dCopula(tmpU,tmpCop,log=F)
- if (i == 1) {
- newU <- cbind(newU, ddvCopula(tmpU, tmpCop))
- } else {
- newU <- cbind(newU, dduCopula(tmpU, tmpCop))
- }
- if (1<i & i<(dim-1)) {
- newU <- cbind(newU, ddvCopula(tmpU, tmpCop))
- }
- }
- u[[2]] <- newU
-
- used <- dim-1
- for (l in 2:(dim-1)) {
- newU <- NULL
- for (i in 1:(dim-l)) {
-# cat(used+i,"\n")
- tmpCop <- copula at copulas[[used+i]]
- tmpU <- u[[l]][,(i*2-1):(i*2)]
- if(log)
- den <- den + dCopula(tmpU, tmpCop,log=T)
- else
- den <- den*dCopula(tmpU, tmpCop, log=F)
- if (l < dim-1) {
- if (i == 1) {
- newU <- cbind(newU,ddvCopula(tmpU, tmpCop))
- } else {
- newU <- cbind(newU,dduCopula(tmpU, tmpCop))
- }
- if (1<i & i<(dim-1)) {
- newU <- cbind(newU,ddvCopula(tmpU, tmpCop))
- }
- }
- }
- u[[l+1]] <- newU
- used <- used + dim - l
- }
-
- return(den)
+dRVine <- function(u, copula, log=F) {
+ RVM <- copula at RVM
+ class(RVM) <- "RVineMatrix"
+ vineLoglik <- RVineLogLik(u, RVM, separate=T)$loglik
+ if(log)
+ return(vineLoglik)
+ else
+ return(exp(vineLoglik))
}
-## c-vine structure
+setMethod("dCopula", signature("numeric","vineCopula"),
+ function(u, copula, ...) dRVine(matrix(u, ncol=copula at dimension), copula, ...))
+setMethod("dCopula", signature("matrix","vineCopula"), dRVine)
-dCvine <- function(copula, u) {
-# cat("c-vine \n")
- dim <- copula at dimension
- tmp <- u
- u <- NULL
- u[[1]] <- matrix(tmp,ncol=dim)
-
- den <- rep(1,nrow(u[[1]]))
+# ## d-vine structure
+#
+# # copula <- vineFit
+# # u <- empVine
+# # empCopVine
+#
+# # dDvine(vineFit, empVine,log=T)
+#
+# dDvine <- function(copula, u, log=FALSE){
+# dim <- copula at dimension
+# tmp <- u
+# u <- NULL
+# u[[1]] <- matrix(tmp,ncol=dim)
+#
+# den <- rep(1,nrow(u[[1]]))
+#
+# newU <- NULL
+# for (i in 1:(dim-1)) {
+# tmpCop <- copula at copulas[[i]]
+# tmpU <- u[[1]][,i:(i+1)]
+# if(log)
+# den <- den + dCopula(tmpU, tmpCop,log=T)
+# else
+# den <- den*dCopula(tmpU,tmpCop,log=F)
+# if (i == 1) {
+# newU <- cbind(newU, ddvCopula(tmpU, tmpCop))
+# } else {
+# newU <- cbind(newU, dduCopula(tmpU, tmpCop))
+# }
+# if (1<i & i<(dim-1)) {
+# newU <- cbind(newU, ddvCopula(tmpU, tmpCop))
+# }
+# }
+# u[[2]] <- newU
+#
+# used <- dim-1
+# for (l in 2:(dim-1)) {
+# newU <- NULL
+# for (i in 1:(dim-l)) {
+# # cat(used+i,"\n")
+# tmpCop <- copula at copulas[[used+i]]
+# tmpU <- u[[l]][,(i*2-1):(i*2)]
+# if(log)
+# den <- den + dCopula(tmpU, tmpCop,log=T)
+# else
+# den <- den*dCopula(tmpU, tmpCop, log=F)
+# if (l < dim-1) {
+# if (i == 1) {
+# newU <- cbind(newU,ddvCopula(tmpU, tmpCop))
+# } else {
+# newU <- cbind(newU,dduCopula(tmpU, tmpCop))
+# }
+# if (1<i & i<(dim-1)) {
+# newU <- cbind(newU,ddvCopula(tmpU, tmpCop))
+# }
+# }
+# }
+# u[[l+1]] <- newU
+# used <- used + dim - l
+# }
+#
+# return(den)
+# }
+#
+# ## c-vine structure
+#
+# dCvine <- function(copula, u) {
+# # cat("c-vine \n")
+# dim <- copula at dimension
+# tmp <- u
+# u <- NULL
+# u[[1]] <- matrix(tmp,ncol=dim)
+#
+# den <- rep(1,nrow(u[[1]]))
+#
+# used <- 0 # already used copulas
+#
+# for (l in 1:(dim-1)) {
+# newU <- NULL
+# for (i in 1:(dim-l)) {
+# # cat(used+i,"\n")
+# tmpCop <- copula at copulas[[used+i]]
+# tmpU <- u[[l]][,c(1,(i+1))]
+# den <- den*dCopula(tmpU, tmpCop)
+# if(l < (dim-1)) newU <- cbind(newU,dduCopula(tmpU, tmpCop))
+# }
+# if(l < (dim-1)) {
+# u[[l+1]] <- newU
+# used <- used + dim - l
+# }
+# }
+#
+# return(den)
+# }
+#
+# ##
+#
+# dvineCopula <- function(u, copula, log=F) {
+# den <- switch(getNumType(copula),dCvine ,dDvine)
+# return(den(copula, u, log))
+# }
- used <- 0 # already used copulas
-
- for (l in 1:(dim-1)) {
- newU <- NULL
- for (i in 1:(dim-l)) {
-# cat(used+i,"\n")
- tmpCop <- copula at copulas[[used+i]]
- tmpU <- u[[l]][,c(1,(i+1))]
- den <- den*dCopula(tmpU, tmpCop)
- if(l < (dim-1)) newU <- cbind(newU,dduCopula(tmpU, tmpCop))
- }
- if(l < (dim-1)) {
- u[[l+1]] <- newU
- used <- used + dim - l
- }
- }
-
- return(den)
-}
-
-##
-
-dvineCopula <- function(u, copula, log=F) {
- den <- switch(getNumType(copula),dCvine ,dDvine)
- return(den(copula, u, log))
-}
-
-setMethod("dCopula", signature("numeric","vineCopula"), dvineCopula)
-setMethod("dCopula", signature("matrix","vineCopula"), dvineCopula)
-
## jcdf ##
pvineCopula <- function(u, copula) {
empCop <- genEmpCop(copula,1e5)
@@ -170,25 +161,31 @@
## random numbers
-linkVineCopSim <- function(n, copula) {
- numType <- getNumType(copula)
+# linkVineCopSim <- function(n, copula) {
+# numType <- getNumType(copula)
+#
+# getFamily <- function(copula) {
+# if("family" %in% slotNames(copula)) numFam <- copula at family
+# else {
+# numFam <- switch(class(copula)[1], normalCopula=1, tCopula=2, claytonCopula=3, gumbelCopula=4, frankCopula=5)
+# }
+# }
+#
+# par1 <- unlist(lapply(copula at copulas,function(x) x at parameters[1]))
+# par2 <- unlist(lapply(copula at copulas,function(x) x at parameters[2]))
+# par2[is.na(par2)] <- 0
+# numFam <- unlist(lapply(copula at copulas,getFamily))
+# tcops <- which(numFam==2) #? length(which(5==3))
+# if(length(tcops)>0)
+# par2[tcops] <- unlist(lapply(copula at copulas[tcops], function(x) x at df))
+#
+# return(RVineSim(n, C2RVine(1:copula at dimension, numFam, par1, par2)))
+# }
- getFamily <- function(copula) {
- if("family" %in% slotNames(copula)) numFam <- copula at family
- else {
- numFam <- switch(class(copula)[1], normalCopula=1, tCopula=2, claytonCopula=3, gumbelCopula=4, frankCopula=5)
- }
- }
-
- par1 <- unlist(lapply(copula at copulas,function(x) x at parameters[1]))
- par2 <- unlist(lapply(copula at copulas,function(x) x at parameters[2]))
- par2[is.na(par2)] <- 0
- numFam <- unlist(lapply(copula at copulas,getFamily))
- tcops <- which(numFam==2) #? length(which(5==3))
- if(length(tcops)>0)
- par2[tcops] <- unlist(lapply(copula at copulas[tcops], function(x) x at df))
-
- return(RVineSim(n, C2RVine(1:copula at dimension, numFam, par1, par2)))
+rRVine <- function(n, copula) {
+ RVM <- copula at RVM
+ class(RVM) <- "RVineMatrix"
+ RVineSim(n, RVM)
}
-setMethod("rCopula", signature("numeric","vineCopula"), linkVineCopSim)
\ No newline at end of file
+setMethod("rCopula", signature("numeric","vineCopula"), rRVine)
\ No newline at end of file
Modified: pkg/R/wrappingCFunctions.R
===================================================================
--- pkg/R/wrappingCFunctions.R 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/R/wrappingCFunctions.R 2013-02-07 16:16:33 UTC (rev 83)
@@ -1,6 +1,8 @@
# wrapping C functions to be used in spcopula
RHfunc1 <- function(fam, n, u, param) {
+ if(is.na(param[2]))
+ param[2] <- 0
.C("Hfunc1", as.integer(fam), as.integer(n), as.double(u[,2]), as.double(u[,1]),
as.double(param[1]), as.double(param[2]), as.double(rep(0, n)),
PACKAGE = "spcopula")
Added: pkg/man/copulaFromFamilyIndex.Rd
===================================================================
--- pkg/man/copulaFromFamilyIndex.Rd (rev 0)
+++ pkg/man/copulaFromFamilyIndex.Rd 2013-02-07 16:16:33 UTC (rev 83)
@@ -0,0 +1,35 @@
+\name{copulaFromFamilyIndex}
+\alias{copulaFromFamilyIndex}
+\title{
+Construct a copual object from a VineCopula family index
+}
+\description{
+A \code{\linkS4class{copula}} object is constructed from the family index used in the package \code{\link{VineCopula-package}} for the provided parameters.
+}
+\usage{
+copulaFromFamilyIndex (family, par, par2 = 0)
+}
+\arguments{
+ \item{family}{
+The number identifying the desired copula family.
+}
+ \item{par}{
+the first parameter as used in \code{\link{VineCopula-package}}
+}
+ \item{par2}{
+the second parameter as used in \code{\link{VineCopula-package}}. The default is \code{par2=0} for single parameter families.
+}
+}
+\value{
+A \code{\linkS4class{copula}} object of the desired family with the provided parameters.
+}
+
+\author{
+Benedikt Graeler
+}
+\examples{
+# the survival Joe Copula
+cop <- copulaFromFamilyIndex(16, 3)
+class(cop)
+}
+\keyword{ function}
\ No newline at end of file
Property changes on: pkg/man/copulaFromFamilyIndex.Rd
___________________________________________________________________
Added: svn:eol-style
+ LF
Modified: pkg/man/dduCopula-methods.Rd
===================================================================
--- pkg/man/dduCopula-methods.Rd 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/man/dduCopula-methods.Rd 2013-02-07 16:16:33 UTC (rev 83)
@@ -15,7 +15,7 @@
\alias{dduCopula,numeric,normalCopula-method}
\alias{dduCopula,numeric,tCopula-method}
\alias{dduCopula,numeric,leafCopula-method}
-\alias{dduCopula,list,stCopula-method}
+
\title{Methods for Function \code{dduCopula} in Package \pkg{spcopula}}
\description{
Methods for function \code{dduCopula} in package \pkg{spcopula}
Modified: pkg/man/ddvCopula-methods.Rd
===================================================================
--- pkg/man/ddvCopula-methods.Rd 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/man/ddvCopula-methods.Rd 2013-02-07 16:16:33 UTC (rev 83)
@@ -1,6 +1,7 @@
\name{ddvCopula-methods}
\docType{methods}
\alias{ddvCopula-methods}
+
\alias{ddvCopula,matrix,claytonCopula-method}
\alias{ddvCopula,matrix,frankCopula-method}
\alias{ddvCopula,matrix,gumbelCopula-method}
@@ -8,6 +9,7 @@
\alias{ddvCopula,matrix,normalCopula-method}
\alias{ddvCopula,matrix,tCopula-method}
\alias{ddvCopula,matrix,leafCopula-method}
+
\alias{ddvCopula,numeric,claytonCopula-method}
\alias{ddvCopula,numeric,frankCopula-method}
\alias{ddvCopula,numeric,gumbelCopula-method}
@@ -15,7 +17,6 @@
\alias{ddvCopula,numeric,normalCopula-method}
\alias{ddvCopula,numeric,tCopula-method}
\alias{ddvCopula,numeric,leafCopula-method}
-\alias{ddvCopula,list,stCopula-method}
\title{Methods for Function \code{ddvCopula} in Package \pkg{spcopula}}
\description{
Modified: pkg/man/spCopula-class.Rd
===================================================================
--- pkg/man/spCopula-class.Rd 2013-01-30 10:54:43 UTC (rev 82)
+++ pkg/man/spCopula-class.Rd 2013-02-07 16:16:33 UTC (rev 83)
@@ -2,8 +2,10 @@
\Rdversion{1.1}
\docType{class}
\alias{spCopula-class}
-\alias{dduCopula,list,spCopula-method}
-\alias{ddvCopula,list,spCopula-method}
+\alias{dduCopula,matrix,spCopula-method}
+\alias{ddvCopula,matrix,spCopula-method}
+\alias{dduCopula,numeric,spCopula-method}
+\alias{ddvCopula,numeric,spCopula-method}
\title{Class \code{"spCopula"}}
\description{
@@ -51,4 +53,4 @@
}
\keyword{classes}
\keyword{spcopula}
-\keyword{copula}
\ No newline at end of file
+\keyword{copula}
Added: pkg/man/spVineCopula-class.Rd
===================================================================
--- pkg/man/spVineCopula-class.Rd (rev 0)
+++ pkg/man/spVineCopula-class.Rd 2013-02-07 16:16:33 UTC (rev 83)
@@ -0,0 +1,45 @@
+\name{spVineCopula-class}
+\Rdversion{1.1}
+\docType{class}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/spcopula -r 83
More information about the spcopula-commits
mailing list