From noreply at r-forge.r-project.org Thu Feb 7 17:16:33 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 7 Feb 2013 17:16:33 +0100 (CET) Subject: [spcopula-commits] r83 - / pkg pkg/R pkg/man Message-ID: <20130207161633.AB5E0184780@r-forge.r-project.org> 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 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 (10) +# 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 From noreply at r-forge.r-project.org Thu Feb 7 18:44:42 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 7 Feb 2013 18:44:42 +0100 (CET) Subject: [spcopula-commits] r84 - / pkg/R Message-ID: <20130207174442.3C0AE181132@r-forge.r-project.org> Author: ben_graeler Date: 2013-02-07 18:44:41 +0100 (Thu, 07 Feb 2013) New Revision: 84 Modified: pkg/R/spCopula.R pkg/R/spVineCopula.R spcopula_0.1-1.tar.gz spcopula_0.1-1.zip Log: - the log parameter was not pushed through ot the real density function in some cases Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2013-02-07 16:16:33 UTC (rev 83) +++ pkg/R/spCopula.R 2013-02-07 17:44:41 UTC (rev 84) @@ -290,7 +290,7 @@ # u # three column matrix providing the transformed pairs and their respective # separation distances -dSpCopula <- function (u, copula, log=F, h, block=1) { +dSpCopula <- function (u, copula, log, h, block=1) { if (missing(h)) stop("Point pairs need to be provided with their separating distance \"h\".") n <- nrow(u) @@ -335,7 +335,7 @@ } setMethod(dCopula, signature("numeric","spCopula"), - function(u, copula, ...) dSpCopula(matrix(u,ncol=2), copula, ...)) + function(u, copula, log, ...) dSpCopula(matrix(u,ncol=2), copula, log=log, ...)) setMethod(dCopula, signature("matrix","spCopula"), dSpCopula) ## partial derivatives ## Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2013-02-07 16:16:33 UTC (rev 83) +++ pkg/R/spVineCopula.R 2013-02-07 17:44:41 UTC (rev 84) @@ -38,11 +38,11 @@ } setMethod("dCopula",signature=signature("matrix","spVineCopula"), - function(u, copula, ...) { - dspVine(u, copula at spCop, copula at vineCop, ...) + function(u, copula, log, ...) { + dspVine(u, copula at spCop, copula at vineCop, log=log, ...) }) setMethod("dCopula",signature=signature("numeric","spVineCopula"), - function(u, copula, ...) { - dspVine(matrix(u,ncol=copula at dimension), copula at spCop, copula at vineCop, ...) + function(u, copula, log, ...) { + dspVine(matrix(u,ncol=copula at dimension), copula at spCop, copula at vineCop, log=log, ...) }) \ No newline at end of file Modified: spcopula_0.1-1.tar.gz =================================================================== (Binary files differ) Modified: spcopula_0.1-1.zip =================================================================== (Binary files differ) From noreply at r-forge.r-project.org Fri Feb 8 09:38:15 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 8 Feb 2013 09:38:15 +0100 (CET) Subject: [spcopula-commits] r85 - / pkg pkg/R Message-ID: <20130208083815.C8D0D18445B@r-forge.r-project.org> Author: ben_graeler Date: 2013-02-08 09:38:15 +0100 (Fri, 08 Feb 2013) New Revision: 85 Removed: pkg/src/ Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/wrappingCFunctions.R spcopula_0.1-1.tar.gz spcopula_0.1-1.zip Log: - removed C-code and point to R-wrappers in VineCopula instead Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2013-02-07 17:44:41 UTC (rev 84) +++ pkg/DESCRIPTION 2013-02-08 08:38:15 UTC (rev 85) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.1-1 -Date: 2013-02-07 +Date: 2013-02-08 Author: Benedikt Graeler Maintainer: Benedikt Graeler 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. Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2013-02-07 17:44:41 UTC (rev 84) +++ pkg/NAMESPACE 2013-02-08 08:38:15 UTC (rev 85) @@ -49,4 +49,4 @@ exportClasses(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula) exportClasses(surGumbelCopula, r90GumbelCopula, r270GumbelCopula) -useDynLib("spcopula") \ No newline at end of file +# useDynLib("spcopula") \ No newline at end of file Modified: pkg/R/wrappingCFunctions.R =================================================================== --- pkg/R/wrappingCFunctions.R 2013-02-07 17:44:41 UTC (rev 84) +++ pkg/R/wrappingCFunctions.R 2013-02-08 08:38:15 UTC (rev 85) @@ -1,32 +1,45 @@ # wrapping C functions to be used in spcopula -RHfunc1 <- function(fam, n, u, param) { +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") + VineCopula:::RHfunc1(fam, n, u, param) +# .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") } -RHfunc2 <- function(fam, n, u, param) { - .C("Hfunc2", as.integer(fam), as.integer(n), as.double(u[,1]), as.double(u[,2]), - as.double(param[1]), as.double(param[2]), as.double(rep(0, n)), - PACKAGE = "spcopula") +RHfunc2 <- function(fam, n, u, param) { + if(is.na(param[2])) + param[2] <- 0 + VineCopula:::RHfunc2(fam, n, u, param) +# .C("Hfunc2", as.integer(fam), as.integer(n), as.double(u[,1]), as.double(u[,2]), +# as.double(param[1]), as.double(param[2]), as.double(rep(0, n)), +# PACKAGE = "spcopula") } -RLL_mod_separate <- function(fam, n, u, param) { - .C("LL_mod_seperate", as.integer(fam), as.integer(n), as.double(u[,1]), - as.double(u[,2]), as.double(param[1]), as.double(param[2]), - as.double(rep(0, n)), PACKAGE = "spcopula") +RLL_mod_separate <- function(fam, n, u, param) { + if(is.na(param[2])) + param[2] <- 0 + VineCopula:::RLL_mod_separate(fam, n, u, param) +# .C("LL_mod_seperate", as.integer(fam), as.integer(n), as.double(u[,1]), +# as.double(u[,2]), as.double(param[1]), as.double(param[2]), +# as.double(rep(0, n)), PACKAGE = "spcopula") } RarchCDF <- function(fam, n, u, param) { - .C("archCDF", as.double(u[,1]), as.double(u[,2]), as.integer(n), as.double(param), - as.integer(fam), as.double(rep(0, n)), PACKAGE = "spcopula") + if(is.na(param[2])) + param[2] <- 0 + VineCopula:::RarchCDF(fam, n, u, param) +# .C("archCDF", as.double(u[,1]), as.double(u[,2]), as.integer(n), as.double(param), +# as.integer(fam), as.double(rep(0, n)), PACKAGE = "spcopula") } Rpcc <- function(fam, n, param) { - .C("pcc", as.integer(n), as.integer(2), as.integer(fam), as.integer(1), - as.double(param[1]), as.double(param[2]), as.double(rep(0, n * 2)), - PACKAGE = "spcopula") + if(is.na(param[2])) + param[2] <- 0 + VineCopula:::Rpcc(fam, n, param) +# .C("pcc", as.integer(n), as.integer(2), as.integer(fam), as.integer(1), +# as.double(param[1]), as.double(param[2]), as.double(rep(0, n * 2)), +# PACKAGE = "spcopula") } \ No newline at end of file Modified: spcopula_0.1-1.tar.gz =================================================================== (Binary files differ) Modified: spcopula_0.1-1.zip =================================================================== (Binary files differ) From noreply at r-forge.r-project.org Fri Feb 8 09:48:54 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 8 Feb 2013 09:48:54 +0100 (CET) Subject: [spcopula-commits] r86 - / pkg/data pkg/man Message-ID: <20130208084855.11960184241@r-forge.r-project.org> Author: ben_graeler Date: 2013-02-08 09:48:54 +0100 (Fri, 08 Feb 2013) New Revision: 86 Modified: pkg/data/spCopDemo.RData pkg/man/spCopula-class.Rd spcopula_0.1-1.tar.gz spcopula_0.1-1.zip Log: - removed spCop from spCopDemo.RData to avoid circular dependencies Modified: pkg/data/spCopDemo.RData =================================================================== (Binary files differ) Modified: pkg/man/spCopula-class.Rd =================================================================== --- pkg/man/spCopula-class.Rd 2013-02-08 08:38:15 UTC (rev 85) +++ pkg/man/spCopula-class.Rd 2013-02-08 08:48:54 UTC (rev 86) @@ -47,8 +47,16 @@ } \examples{ -data(spCopDemo) # data from demo(spcopula_estimation) -# dCopula(u=matrix(c(.3,.3,.7,.7),ncol=2),spCop,h=c(200,400)) +# data from demo(spcopula_estimation) +data(spCopDemo) + +spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"), + frankCopula(1), normalCopula(0), claytonCopula(0), + claytonCopula(0), claytonCopula(0), claytonCopula(0), + claytonCopula(0), indepCopula()), + distances=bins$meanDists, + spDepFun=calcKTauPol, unit="m") +dCopula(u=matrix(c(.3,.3,.7,.7),ncol=2),spCop,h=c(200,400)) pCopula(u=matrix(c(.3,.3,.7,.7),ncol=2),spCop,h=c(200,400)) } \keyword{classes} Modified: spcopula_0.1-1.tar.gz =================================================================== (Binary files differ) Modified: spcopula_0.1-1.zip =================================================================== (Binary files differ) From noreply at r-forge.r-project.org Wed Feb 20 12:22:14 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 Feb 2013 12:22:14 +0100 (CET) Subject: [spcopula-commits] r87 - in pkg: . R demo man Message-ID: <20130220112214.27025184717@r-forge.r-project.org> Author: ben_graeler Date: 2013-02-20 12:22:13 +0100 (Wed, 20 Feb 2013) New Revision: 87 Modified: pkg/DESCRIPTION pkg/R/spCopula.R pkg/R/spVineCopula.R pkg/R/vineCopulas.R pkg/demo/spCopula_estimation.R pkg/man/vineCopula.Rd Log: - vineCopula class, automated spatial vine copual fitting Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2013-02-08 08:48:54 UTC (rev 86) +++ pkg/DESCRIPTION 2013-02-20 11:22:13 UTC (rev 87) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.1-1 -Date: 2013-02-08 +Date: 2013-02-20 Author: Benedikt Graeler Maintainer: Benedikt Graeler 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. Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2013-02-08 08:48:54 UTC (rev 86) +++ pkg/R/spCopula.R 2013-02-20 11:22:13 UTC (rev 87) @@ -175,7 +175,7 @@ if(do.logs) res <- log(res) } else { - if(class(tmpCop) != "indepCopula") + if(class(lowerCop) != "indepCopula") lowerCop at parameters <- calibPar(lowerCop, h) res <- fun(pairs, lowerCop, ...) } Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2013-02-08 08:48:54 UTC (rev 86) +++ pkg/R/spVineCopula.R 2013-02-20 11:22:13 UTC (rev 87) @@ -3,7 +3,7 @@ ######################################### # constructor -spVineCopula <- function(spCop, vineCop) { +spVineCopula <- function(spCop, vineCop=vineCopula()) { 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.", @@ -45,4 +45,24 @@ setMethod("dCopula",signature=signature("numeric","spVineCopula"), function(u, copula, log, ...) { dspVine(matrix(u,ncol=copula at dimension), copula at spCop, copula at vineCop, log=log, ...) - }) \ No newline at end of file + }) + +# fiiting the spatial vine for a given spatial copula + +fitSpVine <- function(copula, data) { + stopifnot(class(data)=="neighbourhood") + stopifnot(copula at dimension == ncol(data at data)) + + secLevel <- NULL + for (i in 1:(copula at dimension-1)) { # i <- 1 + secLevel <- cbind(secLevel, + dduCopula(u=as.matrix(data at data[,c(1,i+1)]), + copula=copula at spCop, h=data at distances[,i])) + } + + vineCop <- fitCopula(copula at vineCop, secLevel) + + return(spVineCopula(spCop, vineCop)) +} + +setMethod("fitCopula",signature=signature("spVineCopula"),fitSpVine) \ No newline at end of file Modified: pkg/R/vineCopulas.R =================================================================== --- pkg/R/vineCopulas.R 2013-02-08 08:48:54 UTC (rev 86) +++ pkg/R/vineCopulas.R 2013-02-20 11:22:13 UTC (rev 87) @@ -5,9 +5,19 @@ #################### # constructor -vineCopula <- function (RVM) { - if(class(RVM)=="RVineMatrix") # handling non S4-class as subelement in a S4-class +vineCopula <- function (RVM) { # RVM <- 4L + if (is.integer(RVM)) {# assuming dimension; i <- 1 + Matrix <- NULL + for (i in 1:RVM) { + Matrix <- cbind(Matrix,c(rep(0,i-1),(RVM-i+1):1)) + } + RVM <- RVineMatrix(Matrix) + } + + # handling non S4-class as sub-element in a S4-class + stopifnot(class(RVM)=="RVineMatrix") 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])) @@ -44,7 +54,7 @@ } setMethod("dCopula", signature("numeric","vineCopula"), - function(u, copula, ...) dRVine(matrix(u, ncol=copula at dimension), copula, ...)) + function(u, copula, log, ...) dRVine(matrix(u, ncol=copula at dimension), copula, log, ...)) setMethod("dCopula", signature("matrix","vineCopula"), dRVine) # ## d-vine structure @@ -151,7 +161,7 @@ ## jcdf ## pvineCopula <- function(u, copula) { - empCop <- genEmpCop(copula,1e5) + empCop <- genEmpCop(copula, 1e5) return(pCopula(u, empCop)) } @@ -188,4 +198,14 @@ RVineSim(n, RVM) } -setMethod("rCopula", signature("numeric","vineCopula"), rRVine) \ No newline at end of file +setMethod("rCopula", signature("numeric","vineCopula"), rRVine) + +# fitting using RVine +fitVineCop <- function(copula, data, method) { + if("StructureSelect" %in% method) + vineCopula(RVineStructureSelect(data, indeptest="indeptest" %in% method)) + else + vineCopula(RVineCopSelect(data, Matrix=copula at RVM$Matrix, indeptest="indeptest" %in% method)) +} + +setMethod("fitCopula", signature=signature("vineCopula"), fitVineCop) \ No newline at end of file Modified: pkg/demo/spCopula_estimation.R =================================================================== --- pkg/demo/spCopula_estimation.R 2013-02-08 08:48:54 UTC (rev 86) +++ pkg/demo/spCopula_estimation.R 2013-02-20 11:22:13 UTC (rev 87) @@ -1,4 +1,5 @@ ## librarys ## +library(spcopula) library(evd) ## dataset - spatial poionts data.frame ## @@ -12,17 +13,22 @@ hist(dataSet[["zinc"]],freq=F,n=30,ylim=c(0,0.0035), main="Histogram of zinc", xlab="zinc concentration") gevEsti <- fgev(dataSet[["zinc"]])$estimate -loc <- gevEsti[1] -scale <- gevEsti[2] -shape <- gevEsti[3] -meanLog <- mean(log(meuse[["zinc"]])) -sdLog <- sd(log(meuse[["zinc"]])) -curve(dgev(x,loc,scale,shape),add=T,col="red") +meanLog <- mean(log(dataSet[["zinc"]])) +sdLog <- sd(log(dataSet[["zinc"]])) +curve(dgev(x,gevEsti[1], gevEsti[2], gevEsti[3]),add=T,col="red") curve(dlnorm(x,meanLog,sdLog),add=T,col="green") -ks.test(dataSet[["zinc"]],pgev,loc,scale,shape) # p: 0.07 +ks.test(dataSet[["zinc"]],pgev,gevEsti[1], gevEsti[2], gevEsti[3]) # p: 0.07 ks.test(dataSet[["zinc"]],plnorm,meanLog,sdLog) # p: 0.03 +pMar <- function(q) plnorm(q, meanLog, sdLog) +qMar <- function(p) qlnorm(p, meanLog, sdLog) +dMar <- function(x) dlnorm(x, meanLog, sdLog) + +# pMar <- function(q) pgev(q, gevEsti[1], gevEsti[2], gevEsti[3]) +# qMar <- function(p) qgev(p, gevEsti[1], gevEsti[2], gevEsti[3]) +# dMar <- function(x) dgev(x, gevEsti[1], gevEsti[2], gevEsti[3]) + ## lag classes ## bins <- calcBins(dataSet,var="zinc",nbins=10,cutoff=800) @@ -44,13 +50,15 @@ claytonCopula(0), frankCopula(1), gumbelCopula(1), joeBiCopula(1.5), indepCopula())) -bestFitTau <- apply(apply(loglikTau, 1, rank, na.last=T), 2, function(x) which(x==7)) +bestFitTau <- apply(apply(loglikTau, 1, rank, na.last=T), 2, + function(x) which(x==7)) bestFitTau ## set-up a spatial Copula ## spCop <- spCopula(components=list(normalCopula(0), tCopula(0), - frankCopula(1), normalCopula(0), claytonCopula(0), - claytonCopula(0), claytonCopula(0), claytonCopula(0), + frankCopula(1), normalCopula(0), + claytonCopula(0), claytonCopula(0), + claytonCopula(0), claytonCopula(0), claytonCopula(0), indepCopula()), distances=bins$meanDists, spDepFun=calcKTauPol, unit="m") @@ -66,6 +74,77 @@ plot(spLoglik, ylab="log-likelihood", xlim=c(1,11)) points(loglikTau[cbind(1:10,bestFitTau)], col="green", pch=16) points(loglikTau[,1], col="red", pch=5) -legend(6, 50,c("Spatial Copula", "best copula per lag", "Gaussian Copula","number of pairs"), +legend(6, 50,c("Spatial Copula", "best copula per lag", "Gaussian Copula", + "number of pairs"), pch=c(1,16,5,50), col=c("black", "green", "red")) -text(x=(1:10+0.5),y=spLoglik,lapply(bins$lagData,length)) \ No newline at end of file +text(x=(1:10+0.5),y=spLoglik,lapply(bins$lagData,length)) + +## +# spatial vine +vineDim <- 5L +meuseNeigh <- getNeighbours(dataSet,"zinc",vineDim) +meuseNeigh at data <- rankTransform(meuseNeigh at data) + +meuseSpVine <- fitCopula(spVineCopula(spCop, vineCopula(as.integer(vineDim-1))), + meuseNeigh) + +meuseSpVine at vineCop + +## +# leave-one-out x-validation + +condVine <- function(condVar, dists, n=100) { + rat <- 0.2/(1:(n/2))-(0.1/((n+1)/2)) + xVals <- unique(sort(c(rat,1-rat,1:(n-1)/(n)))) + xLength <- length(xVals) + repCondVar <- matrix(condVar, ncol=length(condVar), nrow=xLength, byrow=T) + density <- dCopula(cbind(xVals, repCondVar), meuseSpVine, h=dists) + + linAppr <- approxfun(c(0,xVals,1), density[c(1,1:xLength,xLength)] ,yleft=0, yright=0) + int <- integrate(linAppr,lower=0, upper=1)$value + + return(function(u) linAppr(u)/int) +} + +time <- proc.time() # ~30 s +predMedian <- NULL +predMean <- NULL +for(loc in 1:nrow(meuseNeigh at data)) { # loc <- 429 predNeigh$data[loc,1] + cat("Location:",loc,"\n") + condSecVine <- condVine(condVar=as.numeric(meuseNeigh at data[loc,-1]), + dists=meuseNeigh at distances[loc,,drop=F]) + + predMedian <- c(predMedian, qMar(optimise(function(x) abs(integrate(condSecVine,0,x)$value-0.5),c(0,1))$minimum)) + + condExp <- function(x) { + condSecVine(pMar(x))*dMar(x)*x + } + + predMean <- c(predMean, integrate(condExp,0,3000,subdivisions=1e6)$value) +} +proc.time()-time + +mean(abs(predMean-dataSet$zinc)) +mean(predMean-dataSet$zinc) +sqrt(mean((predMean-dataSet$zinc)^2)) + +mean(abs(predMedian-dataSet$zinc)) +mean(predMedian-dataSet$zinc) +sqrt(mean((predMedian-dataSet$zinc)^2)) + +plot(predMean,dataSet$zinc) +abline(0,1) + +plot(predMedian,dataSet$zinc) +abline(0,1) + +## kriging results: +# same neighbourhood size: +# MAE: 158.61 +# BIAS: -4.24 +# RMSE: 239.85 +# +# global kriging: +# MAE: 148.85 +# BIAS: -3.05 +# RMSE: 226.15 \ No newline at end of file Modified: pkg/man/vineCopula.Rd =================================================================== --- pkg/man/vineCopula.Rd 2013-02-08 08:48:54 UTC (rev 86) +++ pkg/man/vineCopula.Rd 2013-02-20 11:22:13 UTC (rev 87) @@ -11,7 +11,7 @@ } \arguments{ \item{RVM}{ -An object of class \code{RVineMatrix} generated from \code{\link{RVineMatrix}} in the package \code{\link{VineCopula-package}}. +An object of class \code{RVineMatrix} generated from \code{\link{RVineMatrix}} in the package \code{\link{VineCopula-package}} or an integer (e.g. \code{4L}) defining the dimension (an independent C-vine of this dimension will be constructed). } } \value{