From noreply at r-forge.r-project.org Mon Feb 3 10:05:49 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 3 Feb 2014 10:05:49 +0100 (CET) Subject: [spcopula-commits] r120 - pkg/R Message-ID: <20140203090549.F3A34186B90@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-03 10:05:48 +0100 (Mon, 03 Feb 2014) New Revision: 120 Modified: pkg/R/spCopula.R pkg/R/spatialPreparation.R Log: - some Na handling in the binning - added progress bar Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2013-12-18 09:22:32 UTC (rev 119) +++ pkg/R/spCopula.R 2014-02-03 09:05:48 UTC (rev 120) @@ -490,6 +490,8 @@ cat(cop at fullname,"\n") tmploglik <- NULL tmpCop <- list() + + pb <- txtProgressBar(0, length(bins$meanDists), style=3) for(i in 1:length(bins$meanDists)) { if(class(cop)!="indepCopula") { if(class(cop) == "asCopula") { @@ -522,7 +524,9 @@ else tmploglik <- c(tmploglik, sum(dCopula(bins$lagData[[i]], cop, log=T))) tmpCop <- append(tmpCop, cop) + setTxtProgressBar(pb, i) } + close(pb) loglik <- cbind(loglik, tmploglik) copulas[[class(cop)]] <- tmpCop } @@ -576,6 +580,12 @@ claytonCopula(0), frankCopula(1), gumbelCopula(1)), calcCor) { + bins$lagData <- lapply(bins$lagData, + function(pairs) { + bool <- !is.na(pairs[,1]) & !is.na(pairs[,2]) + pairs[bool,] + }) + if(missing(calcCor)) return(loglikByCopulasLags.static(bins, families)) else Modified: pkg/R/spatialPreparation.R =================================================================== --- pkg/R/spatialPreparation.R 2013-12-18 09:22:32 UTC (rev 119) +++ pkg/R/spatialPreparation.R 2014-02-03 09:05:48 UTC (rev 120) @@ -299,6 +299,7 @@ else { tempIndices <- NULL for (t.lag in rev(t.lags)) { +# smplInd <- max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)) smplInd <- sample(x=max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)), size=min(instances,lengthTime-max(abs(t.lags)))) tempIndices <- cbind(smplInd+t.lag, tempIndices) @@ -329,7 +330,9 @@ calcTau <- function(binnedData) { cors <- NULL for(i in 1:(ncol(binnedData)/2)) { - cors <- c(cors, VineCopula:::fasttau(binnedData[,2*i-1], binnedData[,2*i])) + tmpData <- binnedData[,2*i+c(-1,0)] + tmpData <- tmpData[!apply(tmpData, 1, function(x) any(is.na(x))),] + cors <- c(cors, VineCopula:::fasttau(tmpData[,1], tmpData[,2])) } return(cors) } From noreply at r-forge.r-project.org Fri Feb 7 16:21:35 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 7 Feb 2014 16:21:35 +0100 (CET) Subject: [spcopula-commits] r121 - in pkg: . R inst man Message-ID: <20140207152135.1B845186C1F@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-07 16:21:34 +0100 (Fri, 07 Feb 2014) New Revision: 121 Added: pkg/inst/ pkg/inst/CITATION Removed: pkg/R/BB1copula.R pkg/R/BB6copula.R pkg/R/BB7copula.R pkg/R/BB8copula.R pkg/R/ClaytonGumbelCopula.R pkg/R/joeBiCopula.R pkg/R/linkingVineCopula.R pkg/R/tawnCopula.R pkg/R/vineCopulas.R pkg/R/wrappingCFunctions.R pkg/man/BB1Copula-class.Rd pkg/man/BB1Copula.Rd pkg/man/BB6Copula-class.Rd pkg/man/BB6Copula.Rd pkg/man/BB7Copula-class.Rd pkg/man/BB7Copula.Rd pkg/man/BB8Copula-class.Rd pkg/man/BB8Copula.Rd pkg/man/copulaFromFamilyIndex.Rd pkg/man/joeBiCopula-class.Rd pkg/man/joeBiCopula.Rd pkg/man/surClaytonCopula-class.Rd pkg/man/surClaytonCopula.Rd pkg/man/surGumbelCopula-class.Rd pkg/man/surGumbelCopula.Rd pkg/man/tawnT1Copula-class.Rd pkg/man/tawnT1Copula.Rd pkg/man/tawnT2Copula-class.Rd pkg/man/tawnT2Copula.Rd pkg/man/vineCopula-class.Rd pkg/man/vineCopula.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/Classes.R pkg/R/asCopula.R pkg/R/cqsCopula.R pkg/R/empiricalCopula.R pkg/R/partialDerivatives.R pkg/R/returnPeriods.R pkg/R/spatialPreparation.R pkg/R/tawn3pCopula.R pkg/man/calcBins.Rd pkg/man/getKendallDistr.Rd pkg/man/kendallDistribution.Rd Log: - version 0.2-0 starts here (all VineCopula wrapper classes have been moved to VineCopula, this required some re-ordering of functions across files (i.e. related to Kendall)) - CITATION file added - VineCopula:::fasttau is replaced by the exported function TauMatrix - fitCopula method for tawn3pCopula corrected with useful default values Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-02-03 09:05:48 UTC (rev 120) +++ pkg/DESCRIPTION 2014-02-07 15:21:34 UTC (rev 121) @@ -1,17 +1,17 @@ Package: spcopula Type: Package Title: copula driven spatial analysis -Version: 0.1-1 -Date: 2013-11-20 -Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = - "ben.graeler at uni-muenster.de"), person("Marius", "Appel", - role = "ctb")) +Version: 0.2-0 +Date: 2014-02-07 +Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), + email = "ben.graeler at uni-muenster.de"), + person("Marius", "Appel",role = "ctb")) Maintainer: Benedikt Graeler Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of sp and spacetime package respectively. Additionally, support for calculating different multivariate return periods is implemented. License: GPL-2 LazyLoad: yes -Depends: copula (>= 0.999-7), R (>= 2.15.0) -Imports: VineCopula (>= 1.1-2), sp, spacetime (>= 1.0-9), methods +Depends: copula (>= 0.999-7), VineCopula (>= 1.2-1), R (>= 2.15.0) +Imports: sp, spacetime (>= 1.0-9), methods URL: http://r-forge.r-project.org/projects/spcopula/ Collate: Classes.R @@ -24,21 +24,11 @@ stCopula.R spatialPreparation.R spatio-temporalPreparation.R - wrappingCFunctions.R - linkingVineCopula.R - BB1copula.R - BB6copula.R - BB7copula.R - BB8copula.R - joeBiCopula.R - ClaytonGumbelCopula.R - vineCopulas.R spVineCopula.R stVineCopula.R utilities.R returnPeriods.R spatialGaussianCopula.R - tawnCopula.R tawn3pCopula.R tailDependenceFunctions.R zzz.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2014-02-03 09:05:48 UTC (rev 120) +++ pkg/NAMESPACE 2014-02-07 15:21:34 UTC (rev 121) @@ -4,23 +4,14 @@ # constructor export(asCopula, cqsCopula) -export(BB1Copula, surBB1Copula, r90BB1Copula, r270BB1Copula) -export(BB6Copula, surBB6Copula, r90BB6Copula, r270BB6Copula) -export(BB7Copula, surBB7Copula, r90BB7Copula, r270BB7Copula) -export(BB8Copula, surBB8Copula, r90BB8Copula, r270BB8Copula) -export(joeBiCopula, surJoeBiCopula, r90JoeBiCopula, r270JoeBiCopula) -export(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula) -export(surGumbelCopula, r90GumbelCopula, r270GumbelCopula) -export(tawnT1Copula, surTawnT1Copula, r90TawnT1Copula, r270TawnT1Copula) -export(tawnT2Copula, surTawnT2Copula, r90TawnT2Copula, r270TawnT2Copula) export(tawn3pCopula) export(spCopula, stCopula) -export(vineCopula, spVineCopula, stVineCopula) +export(spVineCopula, stVineCopula) export(neighbourhood, stNeighbourhood) export(empiricalCopula, genEmpCop) # general functions -export(rankTransform, dependencePlot, unitScatter, univScatter, copulaFromFamilyIndex) +export(rankTransform, dependencePlot, unitScatter, univScatter) export(fitCopula) export(dduCopula,ddvCopula) export(invdduCopula, invddvCopula) @@ -48,14 +39,5 @@ export(criticalPair, criticalTriple) ## classes -exportClasses(asCopula, cqsCopula, neighbourhood, stNeighbourhood, empiricalCopula) -exportClasses(spCopula, stCopula, vineCopula, spVineCopula, stVineCopula) - -# wrappers to CDVine -exportClasses(BB1Copula, surBB1Copula, r90BB1Copula, r270BB1Copula) -exportClasses(BB6Copula, surBB6Copula, r90BB6Copula, r270BB6Copula) -exportClasses(BB7Copula, surBB7Copula, r90BB7Copula, r270BB7Copula) -exportClasses(BB8Copula, surBB8Copula, r90BB8Copula, r270BB8Copula) -exportClasses(joeBiCopula, surJoeBiCopula, r90JoeBiCopula, r270JoeBiCopula) -exportClasses(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula) -exportClasses(surGumbelCopula, r90GumbelCopula, r270GumbelCopula) \ No newline at end of file +exportClasses(asCopula, cqsCopula, tawn3pCopula, neighbourhood, stNeighbourhood, empiricalCopula) +exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) \ No newline at end of file Deleted: pkg/R/BB1copula.R =================================================================== --- pkg/R/BB1copula.R 2014-02-03 09:05:48 UTC (rev 120) +++ pkg/R/BB1copula.R 2014-02-07 15:21:34 UTC (rev 121) @@ -1,261 +0,0 @@ -##################### -## ## -## the BB1 copulas ## -## ## -##################### -# Joe, H., (1997). Multivariate Models and Dependence Concepts. Monogra. Stat. Appl. Probab. 73, London: Chapman and Hall. - -validBB1Copula = function(object) { - if (object at dimension != 2) - return("Only BB1 copulas of dimension 2 are supported.") - param <- object at parameters - upper <- object at param.upbnd - lower <- object at param.lowbnd - if (length(param) != length(upper)) - return("Parameter and upper bound have non-equal length") - if (length(param) != length(lower)) - return("Parameter and lower bound have non-equal length") - else return (TRUE) -} - -setClass("BB1Copula", - representation = representation("copula", family="numeric"), - validity = validBB1Copula, - contains = list("copula") -) - -# constructor -BB1Copula <- function (param=c(1,1)) { - if (any(is.na(param) | param >= c(Inf,Inf) | param[1] <= 0 | param[2] < 1)) - stop(paste("Parameter values out of bounds: theta: (0,Inf), delta: [1,Inf).")) - new("BB1Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(0, 1), param.upbnd = c(Inf, Inf), - family=7, fullname = "BB1 copula family. Number 7 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","BB1Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","BB1Copula"), - function(u, copula, log) linkVineCop.PDF(u, copula, log)) - -## jcdf ## -setMethod("pCopula", signature("numeric","BB1Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","BB1Copula"), linkVineCop.CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","BB1Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","BB1Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","BB1Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","BB1Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","BB1Copula"), linkVineCop.r) - -## kendall distribution/measure -kendall.BB1 <- function(copula, t){ - theta = copula at parameters[1] - delta = copula at parameters[2] - - kt <- rep(NA,length(t)) - kt <- t + 1/(theta * delta) * (t^(-theta) - 1)/(t^(-1 - theta)) - kt[t==1] <- 1 - kt[t==0] <- 0 - return(kt) -} - -setMethod("kendallDistribution", signature("BB1Copula"), kendall.BB1) - -setMethod("getKendallDistr", signature("BB1Copula"), function(copula) return(function(t) kendall.BB1(copula, t)) ) - -setMethod("tau",signature("BB1Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("BB1Copula"),linkVineCop.tailIndex) - -######################### -## BB1 survival copula ## -######################### - -setClass("surBB1Copula", - representation = representation("copula", family="numeric"), - validity = validBB1Copula, - contains = list("copula") -) - -# constructor -surBB1Copula <- function (param=c(1,1)) { - if (any(is.na(param) | param >= c(Inf,Inf) | param[1] <= 0 | param[2] < 1)) - stop(paste("Parameter values out of bounds: theta: (0,Inf), delta: [1,Inf).")) - new("surBB1Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(0, 1), param.upbnd = c(Inf, Inf), - family=17, fullname = "Survival BB1 copula family. Number 17 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","surBB1Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","surBB1Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","surBB1Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","surBB1Copula"), linkVineCop.surCDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","surBB1Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","surBB1Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","surBB1Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","surBB1Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","surBB1Copula"), linkVineCop.r) - -setMethod("tau",signature("surBB1Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("surBB1Copula"),linkVineCop.tailIndex) - -####################### -## BB1 copula 90 deg ## -####################### - -validRotBB1Copula = function(object) { - if (object at dimension != 2) - return("Only BB1 copulas of dimension 2 are supported.") - param <- object at parameters - upper <- object at param.upbnd - lower <- object at param.lowbnd - if (length(param) != length(upper)) - return("Parameter and upper bound have non-equal length") - if (length(param) != length(lower)) - return("Parameter and lower bound have non-equal length") - else return (TRUE) -} - -setClass("r90BB1Copula", - representation = representation("copula", family="numeric"), - validity = validRotBB1Copula, - contains = list("copula") -) - -# constructor -r90BB1Copula <- function (param=c(-1,-1)) { - if (any(is.na(param) | param[1] >= 0 | param[2] > -1 | param <= c(-Inf,-Inf))) - stop(paste("Parameter values out of bounds: theta: (-Inf,0), delta: (-Inf,-1].")) - new("r90BB1Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(0, -1), - family=27, fullname = "90 deg rotated BB1 copula family. Number 27 in VineCopula.") -} -BiCopCDF -## density ## -setMethod("dCopula", signature("numeric","r90BB1Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","r90BB1Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","r90BB1Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","r90BB1Copula"), linkVineCop.r90CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","r90BB1Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","r90BB1Copula"), linkVineCop.ddu) - -## ddv -setMethod("ddvCopula", signature("numeric","r90BB1Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","r90BB1Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","r90BB1Copula"), linkVineCop.r) - -setMethod("tau",signature("r90BB1Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("r90BB1Copula"),linkVineCop.tailIndex) - -######################## -## BB1 copula 270 deg ## -######################## - -setClass("r270BB1Copula", - representation = representation("copula", family="numeric"), - validity = validRotBB1Copula, - contains = list("copula") -) - -# constructor -r270BB1Copula <- function (param=c(-1,-1)) { - if (any(is.na(param) | param[1] >= 0 | param[2] > -1 | param <= c(-Inf,-Inf))) - stop(paste("Parameter values out of bounds: theta: (-Inf,0), delta: (-Inf,-1].")) - new("r270BB1Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(0, -1), - family=37, fullname = "270 deg rotated BB1 copula family. Number 37 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","r270BB1Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","r270BB1Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","r270BB1Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","r270BB1Copula"), linkVineCop.r270CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","r270BB1Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","r270BB1Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","r270BB1Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","r270BB1Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","r270BB1Copula"), linkVineCop.r) - -setMethod("tau",signature("r270BB1Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("r270BB1Copula"),linkVineCop.tailIndex) \ No newline at end of file Deleted: pkg/R/BB6copula.R =================================================================== --- pkg/R/BB6copula.R 2014-02-03 09:05:48 UTC (rev 120) +++ pkg/R/BB6copula.R 2014-02-07 15:21:34 UTC (rev 121) @@ -1,263 +0,0 @@ -##################### -## ## -## the BB6 copulas ## -## ## -##################### -# Joe, H., (1997). Multivariate Models and Dependence Concepts. Monogra. Stat. Appl. Probab. 73, London: Chapman and Hall. - -validBB6Copula = function(object) { - if (object at dimension != 2) - return("Only BB6 copulas of dimension 2 are supported.") - param <- object at parameters - upper <- object at param.upbnd - lower <- object at param.lowbnd - if (length(param) != length(upper)) - return("Parameter and upper bound have non-equal length") - if (length(param) != length(lower)) - return("Parameter and lower bound have non-equal length") - if (any(is.na(param) | param >= upper | param < lower)) - return("Parameter value out of bound.") - else return (TRUE) -} - -setClass("BB6Copula", - representation = representation("copula", family="numeric"), - validity = validBB6Copula, - contains = list("copula") -) - -# constructor -BB6Copula <- function (param=c(1,1)) { - if (any(is.na(param) | param >= c(Inf, Inf) | param < c(1,1))) - stop("Parameter value(s) out of bound(s): theta: [1,Inf), delta: [1,Inf).") - new("BB6Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(1, 1), param.upbnd = c(Inf, Inf), - family=8, fullname = "BB6 copula family. Number 8 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","BB6Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","BB6Copula"), function(u, copula, log) linkVineCop.PDF(u, copula, log)) - -## jcdf ## -setMethod("pCopula", signature("numeric","BB6Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","BB6Copula"), linkVineCop.CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","BB6Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","BB6Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","BB6Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","BB6Copula"), linkVineCop.ddv) - -## random number generater ?? -setMethod("rCopula", signature("numeric","BB6Copula"), linkVineCop.r) - -## kendall distribution/measure, taken from VineCopula:::obs.stat -kendall.BB6 <- function(copula, t){ - theta = copula at parameters[1] - delta = copula at parameters[2] - - kt <- rep(NA,length(t)) - kt <- t + log(-(1 - t)^theta + 1) * (1 - t - (1 - t)^(-theta) + (1 - t)^(-theta) * t)/(delta * theta) - kt[t==1] <- 1 - kt[t==0] <- 0 - return(kt) -} - -setMethod("kendallDistribution", signature("BB6Copula"), kendall.BB6) - -setMethod("getKendallDistr", signature("BB6Copula"), - function(copula) return(function(t) kendall.BB6(copula, t))) - -setMethod("tau",signature("BB6Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("BB6Copula"),linkVineCop.tailIndex) - -######################### -## BB6 survival copula ## -######################### - -setClass("surBB6Copula", - representation = representation("copula", family="numeric"), - validity = validBB6Copula, - contains = list("copula") -) - -# constructor -surBB6Copula <- function (param=c(1,1)) { - if (any(is.na(param) | param >= c(Inf, Inf) | param < c(1,1))) - stop("Parameter value(s) out of bound(s): theta: [1,Inf), delta: [1,Inf).") - new("surBB6Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(1, 1), param.upbnd = c(Inf, Inf), - family=18, fullname = "Survival BB6 copula family. Number 18 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","surBB6Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","surBB6Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","surBB6Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","surBB6Copula"), linkVineCop.surCDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","surBB6Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","surBB6Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","surBB6Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","surBB6Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","surBB6Copula"), linkVineCop.r) - -setMethod("tau",signature("surBB6Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("surBB6Copula"),linkVineCop.tailIndex) - -####################### -## BB6 copula 90 deg ## -####################### - -validRotBB6Copula = function(object) { - if (object at dimension != 2) - return("Only BB6 copulas of dimension 2 are supported.") - param <- object at parameters - upper <- object at param.upbnd - lower <- object at param.lowbnd - if (length(param) != length(upper)) - return("Parameter and upper bound have non-equal length") - if (length(param) != length(lower)) - return("Parameter and lower bound have non-equal length") - else return (TRUE) -} - -setClass("r90BB6Copula", - representation = representation("copula", family="numeric"), - validity = validRotBB6Copula, - contains = list("copula") -) - -# constructor -r90BB6Copula <- function (param=c(-1,-1)) { - if (any(is.na(param) | param > c(-1,-1) | param <= c(-Inf,-Inf))) - stop("Parameter value out of bound: theta: (-Inf,1], delta: (-Inf,1].") - new("r90BB6Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(-1, -1), - family=28, fullname = "90 deg rotated BB6 copula family. Number 28 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","r90BB6Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula,log) - }) -setMethod("dCopula", signature("matrix","r90BB6Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","r90BB6Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","r90BB6Copula"), linkVineCop.r90CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","r90BB6Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","r90BB6Copula"), linkVineCop.ddu) - -## ddv -setMethod("ddvCopula", signature("numeric","r90BB6Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","r90BB6Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","r90BB6Copula"), linkVineCop.r) - -setMethod("tau",signature("r90BB6Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("r90BB6Copula"),linkVineCop.tailIndex) - -########################### -## BB6 copula 270 degree ## -########################### - -setClass("r270BB6Copula", - representation = representation("copula", family="numeric"), - validity = validRotBB6Copula, - contains = list("copula") -) - -# constructor -r270BB6Copula <- function (param=c(-1,-1)) { - if (any(is.na(param) | param > c(-1,-1) | param <= c(-Inf,-Inf))) - stop("Parameter value out of bound: theta: (-Inf,1], delta: (-Inf,1].") - new("r270BB6Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(-1, -1), - family=38, fullname = "270 deg rotated BB6 copula family. Number 38 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","r270BB6Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension, log),copula) - }) -setMethod("dCopula", signature("matrix","r270BB6Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","r270BB6Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","r270BB6Copula"), linkVineCop.r270CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","r270BB6Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","r270BB6Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","r270BB6Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","r270BB6Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","r270BB6Copula"), linkVineCop.r) - -setMethod("tau",signature("r270BB6Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("r270BB6Copula"),linkVineCop.tailIndex) \ No newline at end of file Deleted: pkg/R/BB7copula.R =================================================================== --- pkg/R/BB7copula.R 2014-02-03 09:05:48 UTC (rev 120) +++ pkg/R/BB7copula.R 2014-02-07 15:21:34 UTC (rev 121) @@ -1,265 +0,0 @@ -##################### -## ## -## the BB7 copulas ## -## ## -##################### -# Joe, H., (1997). Multivariate Models and Dependence Concepts. Monogra. Stat. Appl. Probab. 73, London: Chapman and Hall. - -validBB7Copula = function(object) { - if (object at dimension != 2) - return("Only BB7 copulas of dimension 2 are supported.") - param <- object at parameters - upper <- object at param.upbnd - lower <- object at param.lowbnd - if (length(param) != length(upper)) - return("Parameter and upper bound have non-equal length") - if (length(param) != length(lower)) - return("Parameter and lower bound have non-equal length") - else return (TRUE) -} - -setClass("BB7Copula", - representation = representation("copula", family="numeric"), - validity = validBB7Copula, - contains = list("copula") -) - -# constructor -BB7Copula <- function (param=c(1,1)) { - if (any(is.na(param) | param >= c(Inf, Inf) | param[1] < 1 | param[2] <= 0)) - stop(paste("Parameter values out of bounds: theta: [1,Inf), delta: (0,Inf).")) - new("BB7Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(1, 0), param.upbnd = c(Inf, Inf), - family=9, fullname = "BB7 copula family. Number 9 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","BB7Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","BB7Copula"), function(u, copula, log) linkVineCop.PDF(u, copula, log)) - -## jcdf ## -setMethod("pCopula", signature("numeric","BB7Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","BB7Copula"), linkVineCop.CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","BB7Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","BB7Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","BB7Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","BB7Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","BB7Copula"), linkVineCop.r) - -## kendall distribution/measure, taken from VineCopula:::obs.stat -kendall.BB7 <- function(copula, t){ - theta = copula at parameters[1] - delta = copula at parameters[2] - - kt <- rep(NA,length(t)) - kt <- t + 1/(theta * delta) * ((1 - (1 - t)^theta)^(-delta) - 1)/ - ((1 - t)^(theta - 1) * (1 - (1 - t)^theta)^(-delta - 1)) - kt[t==1] <- 1 - kt[t==0] <- 0 - return(kt) -} - -setMethod("kendallDistribution", signature("BB7Copula"), kendall.BB7) - -setMethod("getKendallDistr", signature("BB7Copula"), - function(copula) return(function(t) kendall.BB7(copula, t))) - -setMethod("tau",signature("BB7Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("BB7Copula"),linkVineCop.tailIndex) - - -######################### -## BB7 survival copula ## -######################### - -setClass("surBB7Copula", - representation = representation("copula", family="numeric"), - validity = validBB7Copula, - contains = list("copula") -) - -# constructor -surBB7Copula <- function (param=c(1,1)) { - if (any(is.na(param) | param >= c(Inf, Inf) | param[1] < 1 | param[2] <= 0)) - stop(paste("Parameter values out of bounds: theta: [1,Inf), delta: (0,Inf).")) - new("surBB7Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(1, 0), param.upbnd = c(Inf, Inf), - family= 19, fullname = "Survival BB7 copula family. Number 19 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","surBB7Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension,),copula,log=log) - }) -setMethod("dCopula", signature("matrix","surBB7Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","surBB7Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","surBB7Copula"), linkVineCop.surCDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","surBB7Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","surBB7Copula"), linkVineCop.ddu) - -# ddv -setMethod("ddvCopula", signature("numeric","surBB7Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","surBB7Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","surBB7Copula"), linkVineCop.r) - -setMethod("tau",signature("surBB7Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("surBB7Copula"),linkVineCop.tailIndex) - -################### -## BB7 copula 90 ## -################### - -validRotBB7Copula = function(object) { - if (object at dimension != 2) - return("Only BB7 copulas of dimension 2 are supported.") - param <- object at parameters - upper <- object at param.upbnd - lower <- object at param.lowbnd - if (length(param) != length(upper)) - return("Parameter and upper bound have non-equal length") - if (length(param) != length(lower)) - return("Parameter and lower bound have non-equal length") - if (any(is.na(param) | param[1] > upper[1] | param[2] >= upper[2] | param <= lower)) - return("Parameter value out of bound") - else return (TRUE) -} - -setClass("r90BB7Copula", - representation = representation("copula", family="numeric"), - validity = validRotBB7Copula, - contains = list("copula") -) - -# constructor -r90BB7Copula <- function (param=c(-1,-1)) { - if (any(is.na(param) | param[1] > -1 | param[2] >= 0 | param <= c(-Inf,-Inf))) - stop(paste("Parameter values out of bounds: theta: (-Inf,-1], delta: (-Inf,0).")) - new("r90BB7Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(-1, 0), - family=29, fullname = "90 deg rotated BB7 copula family. Number 29 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","r90BB7Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","r90BB7Copula"), linkVineCop.PDF) - -## jcdf ## -setMethod("pCopula", signature("numeric","r90BB7Copula"), - function(u, copula, ...) { - linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("pCopula", signature("matrix","r90BB7Copula"), linkVineCop.r90CDF) - -## partial derivatives ## -# ddu -setMethod("dduCopula", signature("numeric","r90BB7Copula"), - function(u, copula, ...) { - linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("dduCopula", signature("matrix","r90BB7Copula"), linkVineCop.ddu) - -## ddv -setMethod("ddvCopula", signature("numeric","r90BB7Copula"), - function(u, copula, ...) { - linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) - }) -setMethod("ddvCopula", signature("matrix","r90BB7Copula"), linkVineCop.ddv) - -## random number generator -setMethod("rCopula", signature("numeric","r90BB7Copula"), linkVineCop.r) - -setMethod("tau",signature("r90BB7Copula"),linkVineCop.tau) -setMethod("tailIndex",signature("r90BB7Copula"),linkVineCop.tailIndex) - -######################## -## BB7 copula 270 deg ## -######################## - -setClass("r270BB7Copula", - representation = representation("copula", family="numeric"), - validity = validRotBB7Copula, - contains = list("copula") -) - -# constructor -r270BB7Copula <- function (param=c(-1,-1)) { - if (any(is.na(param) | param[1] > -1 | param[2] >= 0 | param <= c(-Inf,-Inf))) - stop(paste("Parameter values out of bounds: theta: (-Inf,-1], delta: (-Inf,0).")) - new("r270BB7Copula", dimension = as.integer(2), parameters = param, - param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -Inf), param.upbnd = c(-1, 0), - family=39, fullname = "270 deg rotated BB7 copula family. Number 39 in VineCopula.") -} - -## density ## -setMethod("dCopula", signature("numeric","r270BB7Copula"), - function(u, copula, log) { - linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) - }) -setMethod("dCopula", signature("matrix","r270BB7Copula"), linkVineCop.PDF) - -## jcdf ## [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 121 From noreply at r-forge.r-project.org Wed Feb 12 15:54:12 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 12 Feb 2014 15:54:12 +0100 (CET) Subject: [spcopula-commits] r122 - in pkg: . R man Message-ID: <20140212145413.0A17C1868A2@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-12 15:54:12 +0100 (Wed, 12 Feb 2014) New Revision: 122 Added: pkg/R/stCoVarVineCopula.R pkg/man/condStCoVarVine.Rd pkg/man/dropStTree.Rd pkg/man/reduceNeighbours.Rd pkg/man/stCoVarVineCopula-class.Rd pkg/man/stCoVarVineCopula.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/spCopula.R pkg/R/spatio-temporalPreparation.R pkg/man/dropSpTree.Rd pkg/man/fitSpCopula.Rd pkg/man/getStNeighbours.Rd pkg/man/stVineCopula.Rd Log: - first rudimental spatio-temporal covariate vine copula support Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/DESCRIPTION 2014-02-12 14:54:12 UTC (rev 122) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-02-07 +Date: 2014-02-12 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) @@ -26,6 +26,7 @@ spatio-temporalPreparation.R spVineCopula.R stVineCopula.R + stCoVarVineCopula.R utilities.R returnPeriods.R spatialGaussianCopula.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/NAMESPACE 2014-02-12 14:54:12 UTC (rev 122) @@ -7,6 +7,7 @@ export(tawn3pCopula) export(spCopula, stCopula) export(spVineCopula, stVineCopula) +export(stCoVarVineCopula) export(neighbourhood, stNeighbourhood) export(empiricalCopula, genEmpCop) @@ -18,6 +19,7 @@ export(qCopula_u) export(condSpVine,spCopPredict) export(condStVine,stCopPredict) +export(condStCoVarVine) export(spGaussCopPredict, spGaussLogLik) # tweaks @@ -26,7 +28,8 @@ # spatial export(getNeighbours, getStNeighbours) export(calcBins) -export(calcSpTreeDists, dropSpTree) +export(calcSpTreeDists, dropSpTree, dropStTree) +export(reduceNeighbours) # fitting export(fitCorFun, loglikByCopulasLags, fitSpCopula, composeSpCopula) @@ -40,4 +43,5 @@ ## classes exportClasses(asCopula, cqsCopula, tawn3pCopula, neighbourhood, stNeighbourhood, empiricalCopula) -exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) \ No newline at end of file +exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) +exportClasses(stCoVarVineCopula) \ No newline at end of file Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/R/spCopula.R 2014-02-12 14:54:12 UTC (rev 122) @@ -627,9 +627,9 @@ # bounds -> the bounds of the correlation function (typically c(0,1)) # method -> the measure of association, either "kendall" or "spearman" fitSpCopula <- function(bins, cutoff=NA, - families=c(normalCopula(0), - tCopula(0,dispstr="un"), claytonCopula(0), - frankCopula(1), gumbelCopula(1)), ...) { + families=c(normalCopula(), tCopula(), + claytonCopula(), frankCopula(), + gumbelCopula()), ...) { calcCor <- fitCorFun(bins, cutoff=cutoff, ...) loglik <- loglikByCopulasLags(bins, families, calcCor) Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/R/spatio-temporalPreparation.R 2014-02-12 14:54:12 UTC (rev 122) @@ -116,6 +116,43 @@ stInd, prediction, var)) } + +## reduction of a larger neigbopurhood based on correlation strengths +reduceNeighbours <- function(stNeigh, stDepFun, n) { + stopifnot(n>0) + + # transform distances into correlations to detect the strongest correlated ones + dimStNeigh <- dim(stNeigh at distances) + corMat <- matrix(NA, dimStNeigh[1], dimStNeigh[2]) + + for (i in 1:dimStNeigh[2]) { + boolNA <- is.na(stNeigh at data[[1]]) | is.na(stNeigh at data[[1+i]]) + stNeigh at distances[boolNA,i,] <- c(NA,NA) + tLag <- -1*stNeigh at distances[!boolNA,i,2][1]+1 + corMat[!boolNA,i] <- stDepFun(stNeigh at distances[!boolNA,i,1], tLag) + } + + highCorMat <- t(apply(corMat, 1, function(x) order(x, na.last=TRUE, decreasing=TRUE)[1:n])) + + stNeighDataRed <- matrix(NA, nrow=nrow(highCorMat), ncol=n+1) + stNeighDistRed <- array(NA, dim=c(nrow(highCorMat), n, 2)) + stNeighIndeRed <- array(NA, dim=c(nrow(highCorMat), n, 2)) + for (i in 1:nrow(highCorMat)) { + stNeighDataRed[i,] <- as.numeric(stNeigh at data[i,c(1,highCorMat[i,]+1)]) + stNeighDistRed[i,,] <- stNeigh at distances[i,highCorMat[i,],] + stNeighIndeRed[i,,] <- stNeigh at index[i,highCorMat[i,],] + } + + stNeighDataRed <- stNeighDataRed[!is.na(stNeigh at data[[1]]),] + stNeighDistRed <- stNeighDistRed[!is.na(stNeigh at data[[1]]),,] + stNeighIndeRed <- stNeighIndeRed[!is.na(stNeigh at data[[1]]),,] + + return(stNeighbourhood(stNeighDataRed,stNeighDistRed, stNeigh at dataLocs, + ST=stNeigh at dataLocs, stNeighIndeRed, prediction=F, + var=stNeigh at var)) +} + +## to be redone calcStNeighBins <- function(data, var="uniPM10", nbins=9, t.lags=-(0:2), boundaries=NA, cutoff=NA, cor.method="fasttau") { # dists <- data at distances[,,1] Added: pkg/R/stCoVarVineCopula.R =================================================================== --- pkg/R/stCoVarVineCopula.R (rev 0) +++ pkg/R/stCoVarVineCopula.R 2014-02-12 14:54:12 UTC (rev 122) @@ -0,0 +1,271 @@ +############################################ +## the spatial vine copula with covariate ## +############################################ + +validStCoVarVineCopula <- function(object) { + return(is.function(object at coVarCop) & validStCopula(object at stCop) & validObject(object at topCop)) +} + +setClass("stCoVarVineCopula", representation("copula", coVarCop="function", stCop="stCopula", topCop="copula"), + validity = validStCoVarVineCopula, contains=list("copula")) + +## constructor ## +################# + +stCoVarVineCopula <- function(coVarCop, stCop, topCop) { + stopifnot(is(stCop,"stCopula")) + + new("stCoVarVineCopula", dimension = as.integer(topCop at dimension+1), + parameters=numeric(), param.names = character(), param.lowbnd = numeric(), + param.upbnd = numeric(), + fullname = paste("Spatio-temporal covariate vine copula family with 1 spatio-temporal tree."), + coVarCop=coVarCop, stCop=stCop, topCop=topCop) +} + +## show ## +########## + +showStCoVarVineCopula <- function(object) { + dim <- object at dimension + cat(object at fullname, "\n") + cat("Dimension: ", dim, "\n") +} + +setMethod("show", signature("stCoVarVineCopula"), showStCoVarVineCopula) + +## density ## +############# + +dstCoVarVine <- function(u, coVarCop, stCop, topCop, log, h, stInd) { + stopifnot(nrow(u)==nrow(stInd)) + stopifnot(ncol(u)==2) + stopifnot(dim(h)==3) + + l0 <- rep(0,nrow(u)) # level 0 spatio-temporal density + dimDists <- dim(h) + + nrU <- nrow(u) + + u1 <- matrix(NA, nrU, ncol(u)-1) + for(i in 2:dimDists[2]) { # i <- 1 + l0 <- l0 + dCopula(u[,c(1,i+1)], stCop, h=matrix(h[,i,], ncol=2), log=T) + u1[,i] <- dduCopula(u[,c(1,i+1)], stCop, h=matrix(h[,i,], ncol=2)) + } + + uCoVar <- numeric(nrU) + for (i in 1:nrU) { + uCoVar[i] <- dduCopula(u[i,1:2], coVarCop(stInd[i,])) + } + + if(!is.null(topCop)) + l1 <- dCopula(cbind(uCoVar, u1), topCop, log=T) + else + l1 <- 0 + + if(log) + return(l0+l1) + else(exp(l0+l1)) +} + +setMethod("dCopula", signature=signature("matrix","stCoVarVineCopula"), + function(u, copula, log, ...) { + if("topCop" %in% slotNames(copula)) + dstCoVarVine(u, copula at coVarCop, copula at stCop, copula at topCop, log=log, ...) + else + dstCoVarVine(u, copula at coVarCop, copula at stCop, NULL, log=log, ...) + }) + +setMethod("dCopula",signature=signature("numeric","stCoVarVineCopula"), + function(u, copula, log, ...) { + if("topCop" %in% slotNames(copula)) + dstCoVarVine(matrix(u,ncol=copula at dimension), copula at coVarCop, copula at stCop, copula at topCop, log=log, ...) + else + dstCoVarVine(matrix(u,ncol=copula at dimension), copula at coVarCop, copula at stCop, NULL, log=log, ...) + }) + +setMethod("dCopula",signature=signature("data.frame","stCoVarVineCopula"), + function(u, copula, log, ...) { + if("topCop" %in% slotNames(copula)) + dstCoVarVine(as.matrix(u), copula at stCop, copula at coVarCop, copula at stCop, copula at topCop, log=log, ...) + else + dstCoVarVine(as.matrix(u), copula at coVarCop, copula at stCop, NULL, log=log, ...) + }) +# +# # fitting the spatial vine for a given list of spatial copulas +# fitStVine <- function(copula, data, method, estimate.variance=F) { +# stopifnot(class(data)=="stNeighbourhood") +# stopifnot(copula at dimension == ncol(data at data)) +# +# u0 <- as.matrix(data at data) # previous level's (conditional) data +# h0 <- data at distances # previous level's distances +# l0 <- rep(0,nrow(u0)) # spatial density +# u1 <- NULL # current level of conditional data +# cat("[Margin ") +# for(i in 1:dim(h0)[2]) { # i <- 1 +# l0 <- l0 + dCopula(u0[,c(1,i+1)], copula at stCop, h=h0[,i,], log=T) +# cat(i,", ", sep="") +# u1 <- cbind(u1, dduCopula(u0[,c(1,i+1)], copula at stCop, h=h0[,i,])) +# } +# u0 <- u1 +# cat("]\n") +# +# cat("[Estimating a",ncol(u0),"dimensional copula at the top.]\n") +# vineCopFit <- fitCopula(copula at topCop, u0, method, estimate.variance) +# +# stVineCop <- stVineCopula(copula at stCop, vineCopFit at copula) +# loglik <- vineCopFit at loglik +# +# return(new("fitCopula", estimate = stVineCop at parameters, var.est = matrix(NA), +# method = method, +# loglik = sum(l0)+loglik, +# fitting.stats=list(convergence = as.integer(NA)), +# nsample = nrow(data at data), copula=stVineCop)) +# } + +# setMethod("fitCopula",signature=signature("stVineCopula"),fitStVine) + +# conditional spatio-temporal covariate vine +condStCoVarVine <- function (condVar, dists, stCVVC, stInd, n = 1000) { + stopifnot(is.array(dists)) + + coVarCop <- stCVVC at coVarCop(stInd) + stBiCop <- stCVVC at stCop + topCop <- stCVVC at topCop + + # add some points in the tails + rat <- 50:1%x%c(1e-6,1e-5,1e-4,1e-3) + xVals <- unique(sort(c(rat, 1 - rat, 1:(n - 1)/n))) + nx <- length(xVals) + nbs <- dim(dists)[2] + + repCondVar <- matrix(condVar, ncol = length(condVar), nrow = nx, byrow = T) + dCoVar <- dCopula(cbind(xVals, repCondVar[,1]), coVarCop) + condCoVar <- dduCopula(cbind(xVals, repCondVar[,1]), coVarCop) + + u0 <- cbind(xVals,repCondVar[,-1]) # previous level's (conditional) data + condData <- matrix(NA, nx, nbs) # current level of conditional data + dStBiC <- 1 # current likelihood + + for(i in 1:nbs) { # i <- 1 + condData[,i] <- dduCopula(u0[,c(1,i+1)], stBiCop, h=matrix(dists[,i,],1)) + dStBiC <- dStBiC*dCopula(u0[,c(1,i+1)], stBiCop, h=matrix(dists[,i,],1)) + } + + dTopVi <- dCopula(cbind(condCoVar,condData), topCop) + + density <- dCoVar*dStBiC*dTopVi + # the 1-e6 corners linearily to [0,1], but ensure non-negative + density <- c(max(0,2*density[1]-density[2]), + density, max(0,2*density[nx]-density[nx-1])) + linAppr <- approxfun(c(0, xVals, 1), density) + + # sum up the denstiy to rescale + int <- sum(diff(c(0,xVals,1))*(0.5*diff(density)+density[-(nx+2)])) + condVineFun <- function(u) linAppr(u)/int + attr(condVineFun,"xVals") <- c(0,xVals,1) + return(condVineFun) +} + +## interpolation ## +################### +# +# stCopPredict.expectation <- function(predNeigh, stVine, margin, ..., stop.on.error=F) { +# stopifnot(is.function(margin$q)) +# dists <- predNeigh at distances +# +# predMean <- NULL +# for(i in 1:nrow(predNeigh at data)) { # i <-1 +# cat("[Predicting location ",i,".]\n", sep="") +# condSecVine <- condStVine(as.numeric(predNeigh at data[i,]), dists[i,], stVine) +# +# condExp <- function(x) { +# margin$q(x)*condSecVine(x) +# } +# +# ePred <- integrate(condExp,0,1,subdivisions=10000L,stop.on.error=stop.on.error, ...) +# if(ePred$abs.error > 0.01) +# warning("Numerical integration in predExpectation performed at a level of absolute error of only ", +# ePred$abs.error, " for location ",i,".") +# predMean <- c(predMean, ePred$value) +# } +# if ("data" %in% slotNames(predNeigh at locations)) { +# res <- predNeigh at locations +# res at data[["expect"]] <- predMean +# return(res) +# } else { +# predMean <- data.frame(predMean) +# colnames(predMean) <- "expect" +# return(addAttrToGeom(predNeigh at locations, predMean, match.ID=FALSE)) +# } +# } +# +# stCopPredict.quantile <- function(predNeigh, stVine, margin, p=0.5) { +# stopifnot(is.function(margin$q)) +# dists <- predNeigh at distances +# +# predQuantile <- NULL +# for(i in 1:nrow(predNeigh at data)) { # i <-1 +# cat("[Predicting location ",i,".]\n", sep="") +# condSecVine <- condStVine(as.numeric(predNeigh at data[i,]), dists[i,,,drop=F], stVine) +# +# xVals <- attr(condSecVine,"xVals") +# density <- condSecVine(xVals) +# nx <- length(xVals) +# int <- cumsum(c(0,diff(xVals)*(0.5*diff(density)+density[-nx]))) +# lower <- max(which(int <= p)) +# m <- (density[lower+1]-density[lower])/(xVals[lower+1]-xVals[lower]) +# b <- density[lower] +# xRes <- -b/m+sign(m)*sqrt(b^2/m^2+2*(p-int[lower])/m) +# +# predQuantile <- c(predQuantile, margin$q(xVals[lower]+xRes)) +# } +# +# if ("data" %in% slotNames(predNeigh at locations)) { +# res <- predNeigh at locations +# res at data[[paste("quantile.",p,sep="")]] <- predQuantile +# return(res) +# } else { +# predQuantile <- data.frame(predQuantile) +# colnames(predQuantile) <- paste("quantile.",p,sep="") +# return(addAttrToGeom(predNeigh at locations, predQuantile, match.ID=FALSE)) +# } +# } +# +# stCopPredict <- function(predNeigh, stVine, margin, method="quantile", p=0.5, ...) { +# switch(method, +# quantile=stCopPredict.quantile(predNeigh, stVine, margin, p), +# expectation=stCopPredict.expectation(predNeigh, stVine, margin, ...)) +# } +# +# dropStTree <- function(neigh, stCop) { +# stopifnot(class(neigh)=="stNeighbourhood") +# +# u0 <- as.matrix(neigh at data) # previous level's (conditional) data +# h0 <- neigh at distances # previous level's distances +# u1 <- NULL # current level of conditional data +# h1s <- NULL # upcoming distances +# h1t <- NULL # upcoming distances +# cat("[Margin ") +# for(i in 1:dim(h0)[2]) { # i <- 1 +# cat(i,", ") +# u1 <- cbind(u1, dduCopula(u0[,c(1,i+1)], stCop, h=h0[,i,])) +# if (i < ncol(neigh at distances)) { +# h1s <- cbind(h1s, apply(neigh at index[, c(1, i + 1),1], 1, +# function(x) spDists(neigh at locations@sp[x, ])[1, 2])) +# h1t <- cbind(h1t, apply(neigh at index[, c(1, i + 1),2], 1, +# function(x) diff(x))) +# } +# } +# h1 <- array(dim=c(dim(h1s),2)) +# h1[,,1] <- h1s +# h1[,,2] <- h1t +# +# varSplit <- strsplit(neigh at var, "|", fixed = TRUE)[[1]] +# cond <- suppressWarnings(as.numeric(varSplit[length(varSplit)])) +# if (is.na(cond)) +# cond <- paste(neigh at var, "|0", sep = "") +# else cond <- paste(neigh at var, cond + 1, sep = "") +# return(stNeighbourhood(data=u1, distances=h1, STxDF=neigh at locations, +# ST=neigh at dataLocs, index=neigh at index[, -1,], +# prediction=neigh at prediction, var=cond)) +# } \ No newline at end of file Added: pkg/man/condStCoVarVine.Rd =================================================================== --- pkg/man/condStCoVarVine.Rd (rev 0) +++ pkg/man/condStCoVarVine.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -0,0 +1,72 @@ +\name{condStCoVarVine} +\alias{condStCoVarVine} + +\title{ +conditional distribution function of spatio-temporal covariate vine copula +} +\description{ +Returns a conditional distribution function of spatio-temporal covariate vine copula +} +\usage{ +condStCoVarVine(condVar, dists, stCVVC, stInd, n = 1000) +} + +\arguments{ + \item{condVar}{ +the conditioning variables +} + \item{dists}{ +spatio-temporal distances to the conditioning variables +} + \item{stCVVC}{ +the spatio-temporal covariate vine copula of the model +} + \item{stInd}{ +spatio-temporal index pair to be used with covariate copula (which is in first place a function taking a pair of indices and returns a copula object) +} + \item{n}{ +number of approximation points +} +} +\value{ +a univariate distribution function over [0,1] +} +\author{ +Benedikt Graeler +} +\note{ +The distribution is linearly approximated at a limited number (\code{n}) of points. +} + +\seealso{ +\code{\link{condStVine}}, \code{\link{condSpVine}} +} + +\examples{ +spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), + claytonCopula(2), claytonCopula(1), + claytonCopula(0.5), indepCopula()), + distances=c(100,200,300,400,500,600), + unit="km") +spCopT1 <- spCopula(components=list(claytonCopula(4), claytonCopula(2), + claytonCopula(1), claytonCopula(0.5), + indepCopula()), + distances=c(100,200,300,400,500), + unit="km") +spCopT2 <- spCopula(components=list(claytonCopula(2), claytonCopula(1), + claytonCopula(0.5), indepCopula()), + distances=c(100,200,300,400), + unit="km") + +stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), + t.lags=-(0:2)) + +# only a constant copula ius used for the covariate +stCVVC <- stCoVarVineCopula(function(x) gumbelCopula(2), stCop, vineCopula(9L)) + +dists <- array(c(150, 250, 150, 250,0,0,-1,-1),dim=c(1,4,2)) +condVar <- c(0.15, 0.29, 0.55, 0.05, 0.41) + +condDensity <- condStCoVarVine(condVar, dists, stCVVC, c(1,1)) +curve(condDensity) +} \ No newline at end of file Modified: pkg/man/dropSpTree.Rd =================================================================== --- pkg/man/dropSpTree.Rd 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/man/dropSpTree.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -19,7 +19,7 @@ } \value{ -A conditioned \code{\linkS4class{neighbourhood}} of dimesnion 1 less. +A conditioned \code{\linkS4class{neighbourhood}} of dimension 1 less. } \author{ Added: pkg/man/dropStTree.Rd =================================================================== --- pkg/man/dropStTree.Rd (rev 0) +++ pkg/man/dropStTree.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -0,0 +1,33 @@ +\name{dropStTree} +\alias{dropStTree} + +\title{ +Drops a spatio-temporal tree +} +\description{ +A spatio-temporal tree is dropped in order to fit the following copula. +} +\usage{dropStTree(neigh, stCop)} + +\arguments{ + \item{neigh}{ +the current spatio-temporal \code{\linkS4class{stNeighbourhood}} +} + \item{stCop}{ +the current spatio-temporal copula performing the conditioning +} +} + +\value{ +A conditioned spatio-temporal \code{\linkS4class{stNeighbourhood}} of dimension 1 less. +} + +\author{ +Benedikt Graeler +} + +\seealso{ +\code{\linkS4class{stNeighbourhood}} +} + +\keyword{ spatio-temporal } \ No newline at end of file Modified: pkg/man/fitSpCopula.Rd =================================================================== --- pkg/man/fitSpCopula.Rd 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/man/fitSpCopula.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -8,8 +8,8 @@ A bivariate spatial copula is composed out of a set of bivariate copulas. These are combined using a convex linear combination with weights based on distances where for copulas with a 1-1 correspondence of Kendall's tau or Spearman's rho a dependence function providing measures of association based on distances might be used. This function estimates a spatial dependence function, evaluates the log-likelihood per family and lag class, selects the best fits and composes a spatial bivariate copula. } \usage{ -fitSpCopula(bins, cutoff = NA, families = c(normalCopula(0), tCopula(0, dispstr = "un"), - claytonCopula(0), frankCopula(1), gumbelCopula(1)), ...) +fitSpCopula(bins, cutoff = NA, families = c(normalCopula(), tCopula(), + claytonCopula(), frankCopula(), gumbelCopula()), ...) } \arguments{ \item{bins}{ @@ -43,9 +43,7 @@ } \examples{ data(spCopDemo) -fitSpCopula(bins=bins,cutoff=600,families=c(normalCopula(0), tCopula(0,dispstr = "un"), - claytonCopula(0), frankCopula(1), - gumbelCopula(1), joeBiCopula(1.5))) +fitSpCopula(bins, 600) } \keyword{ spatial } \keyword{ multivariate }% __ONLY ONE__ keyword per line Modified: pkg/man/getStNeighbours.Rd =================================================================== --- pkg/man/getStNeighbours.Rd 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/man/getStNeighbours.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -25,7 +25,7 @@ The spatial size of the neighbourhood including the location of interest (for fitting as well for prediction). } \item{t.lags}{The temporal lags to be used in the spatio-temporal neighbourhood.} -\item{timeSteps}{The number of tiem instances that should randomly be selected from \code{stData}. The defualt, \code{NA}, selects all locations.} +\item{timeSteps}{The number of time instances that should randomly be selected from \code{stData}. The default, \code{NA}, selects all locations.} \item{prediction}{whether the neighbourhood should be used for prediction (TRUE) or spatial/Spatio-temporal vine copula fitting.} \item{min.dist}{ the minimal distance for a location to be included. Must be larger than 0 for fitting purposes and might be 0 for prediction. Added: pkg/man/reduceNeighbours.Rd =================================================================== --- pkg/man/reduceNeighbours.Rd (rev 0) +++ pkg/man/reduceNeighbours.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -0,0 +1,49 @@ +\name{reduceNeighbours} +\alias{reduceNeighbours} + +\title{ +Selecting the strongest correlated neighbours +} +\description{ +A function selecting the strongest correlated neighbours from a larger set of neighbours +} +\usage{ +reduceNeighbours(stNeigh, stDepFun, n) +} + +\arguments{ + \item{stNeigh}{ +the proxy neighbourhood to be investigated +} + \item{stDepFun}{ +a spatio-temporal dependence function that return correlation estimates based on a spatial and temporal distance +} + \item{n}{ +the number of neighbours to be selected. +} +} +\value{A spatio-temporal neighbourhood \code{\linkS4class{stNeighbourhood}} with fewer neighbours.} + +\author{ +Benedikt Graeler +} + + +\seealso{ +\code{\link{getStNeighbours}} +} + +\examples{ +library(sp) +library(spacetime) + +sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) +time <- Sys.time()+60*60*24*c(0,1,2,3,4) +data <- data.frame(var1=runif(10)) + +stData <- STFDF(sp, time, data) + +stNeigh <- getStNeighbours(stData, spSize=2, t.lags=-(0:2)) + +reduceNeighbours(stNeigh, function(h,delta) return(1/h/delta), 2) +} \ No newline at end of file Added: pkg/man/stCoVarVineCopula-class.Rd =================================================================== --- pkg/man/stCoVarVineCopula-class.Rd (rev 0) +++ pkg/man/stCoVarVineCopula-class.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -0,0 +1,41 @@ +\name{stCoVarVineCopula-class} +\Rdversion{1.1} +\docType{class} +\alias{stCoVarVineCopula-class} + +\title{Class \code{"stCoVarVineCopula"}} +\description{ +A S4-class representing a spatio-temporal covariate vine copula +} +\section{Objects from the Class}{ +Objects can be created by calls of the form \code{new("stCoVarVineCopula", ...)} or by calls to the constructor \code{\link{stCoVarVineCopula}}. +} +\section{Slots}{ + \describe{ + \item{\code{coVarCop}:}{Object of class \code{"function"} returning a bivariate copula object for absolute pairs of spatio-temporal indices.} + \item{\code{stCop}:}{Object of class \code{"stCopula"} modelling the spatio-temporal dependence on the first tree.} + \item{\code{topCop}:}{Object of class \code{"copula"} joining the spatio-temporal tree with its additional covariate copula to a full vine copula.} + \item{\code{dimension}:}{Object of class \code{"integer"} denoting the dimension of the overall copula. } + \item{\code{parameters}:}{Object of class \code{"numeric"}, not used.} + \item{\code{param.names}:}{Object of class \code{"character"}, not used.} + \item{\code{param.lowbnd}:}{Object of class \code{"numeric"}, not used.} + \item{\code{param.upbnd}:}{Object of class \code{"numeric"}, not used.} + \item{\code{fullname}:}{Object of class \code{"character"} providing a textual short description of this class.} + } +} +\section{Extends}{ +Class \code{"\linkS4class{copula}"}, directly. +Class \code{"\linkS4class{Copula}"}, by class "copula", distance 2. +} +\section{Methods}{ +No methods defined with class "stCoVarVineCopula" in the signature. +} +\author{ +Benedikt Graeler +} + +\seealso{\code{\linkS4class{stVineCopula}}} +\examples{ +showClass("stCoVarVineCopula") +} +\keyword{classes} Added: pkg/man/stCoVarVineCopula.Rd =================================================================== --- pkg/man/stCoVarVineCopula.Rd (rev 0) +++ pkg/man/stCoVarVineCopula.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -0,0 +1,65 @@ +\name{stCoVarVineCopula} +\alias{stCoVarVineCopula} + +\title{ +Constructor for \code{\linkS4class{stCoVarVineCopula}} +} +\description{ +This function provides a more comfortable way of defining a \code{\linkS4class{stCoVarVineCopula}}. +} +\usage{ +stCoVarVineCopula(coVarCop, stCop, topCop) +} + +\arguments{ + \item{coVarCop}{ +A function returning a returning a bivariate copula object for absolute pairs of spatio-temporal indices +} + \item{stCop}{ +Object of class \code{"stCopula"} modelling the spatio-temporal dependence on the first tree +} + \item{topCop}{ +Object of class \code{"copula"} joining the spatio-temporal tree with its additional covariate copula to a full vine copula. +} +} +\details{ +For a spatio-temporal random field Z with covariate Y a c-vine is assumed with data sorted as (z_0, y_0, z_1, .., z_n). +} + +\value{An object of class \code{\linkS4class{stCoVarVineCopula}}.} + +\author{ +Benedikt Graeler +} + +\seealso{ +\code{\link{stVineCopula}}, \code{\linkS4class{stCoVarVineCopula}} +} + +\examples{ +# a spatio-temporal C-vine copula (with independent copulas in the upper vine) +spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), + claytonCopula(2), claytonCopula(1), + claytonCopula(0.5), indepCopula()), + distances=c(100,200,300,400,500,600), + unit="km") +spCopT1 <- spCopula(components=list(claytonCopula(4), claytonCopula(2), + claytonCopula(1), claytonCopula(0.5), + indepCopula()), + distances=c(100,200,300,400,500), + unit="km") +spCopT2 <- spCopula(components=list(claytonCopula(2), claytonCopula(1), + claytonCopula(0.5), indepCopula()), + distances=c(100,200,300,400), + unit="km") + +stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), + t.lags=-(0:2)) + +# only a constant copula ius used for the covariate +stCoVarVineCopula(function(x) gumbelCopula(2), stCop, vineCopula(9L)) +} +% Add one or more standard keywords, see file 'KEYWORDS' in the +% R documentation directory. +\keyword{ ~kwd1 } +\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line Modified: pkg/man/stVineCopula.Rd =================================================================== --- pkg/man/stVineCopula.Rd 2014-02-07 15:21:34 UTC (rev 121) +++ pkg/man/stVineCopula.Rd 2014-02-12 14:54:12 UTC (rev 122) @@ -21,7 +21,6 @@ } \examples{ # a spatio-temporal C-vine copula (with independent copulas in the upper vine) - spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), claytonCopula(2), claytonCopula(1), claytonCopula(0.5), indepCopula()), @@ -40,7 +39,6 @@ stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), t.lags=-(0:2)) -library(VineCopula) stVineCopula(stCop, vineCopula(9L)) } \keyword{ mulitvariate } From noreply at r-forge.r-project.org Thu Feb 13 10:38:55 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 13 Feb 2014 10:38:55 +0100 (CET) Subject: [spcopula-commits] r123 - in pkg: . man Message-ID: <20140213093855.D42E0186E65@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-13 10:38:55 +0100 (Thu, 13 Feb 2014) New Revision: 123 Modified: pkg/DESCRIPTION pkg/man/condStCoVarVine.Rd Log: - typo in example of condStCoVarVine Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-02-12 14:54:12 UTC (rev 122) +++ pkg/DESCRIPTION 2014-02-13 09:38:55 UTC (rev 123) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-02-12 +Date: 2014-02-13 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) Modified: pkg/man/condStCoVarVine.Rd =================================================================== --- pkg/man/condStCoVarVine.Rd 2014-02-12 14:54:12 UTC (rev 122) +++ pkg/man/condStCoVarVine.Rd 2014-02-13 09:38:55 UTC (rev 123) @@ -62,10 +62,10 @@ t.lags=-(0:2)) # only a constant copula ius used for the covariate -stCVVC <- stCoVarVineCopula(function(x) gumbelCopula(2), stCop, vineCopula(9L)) +stCVVC <- stCoVarVineCopula(function(x) gumbelCopula(7), stCop, vineCopula(5L)) dists <- array(c(150, 250, 150, 250,0,0,-1,-1),dim=c(1,4,2)) -condVar <- c(0.15, 0.29, 0.55, 0.05, 0.41) +condVar <- c(0.95, 0.29, 0.55, 0.05, 0.41) condDensity <- condStCoVarVine(condVar, dists, stCVVC, c(1,1)) curve(condDensity) From noreply at r-forge.r-project.org Thu Feb 13 21:05:43 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 13 Feb 2014 21:05:43 +0100 (CET) Subject: [spcopula-commits] r124 - in pkg: R demo man Message-ID: <20140213200543.98787186F1A@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-13 21:05:42 +0100 (Thu, 13 Feb 2014) New Revision: 124 Modified: pkg/R/Classes.R pkg/R/spCopula.R pkg/R/spVineCopula.R pkg/R/spatialGaussianCopula.R pkg/R/spatialPreparation.R pkg/R/spatio-temporalPreparation.R pkg/R/stVineCopula.R pkg/demo/spCopula.R pkg/man/calcSpTreeDists.Rd pkg/man/getNeighbours.Rd pkg/man/getStNeighbours.Rd pkg/man/neighbourhood-class.Rd pkg/man/neighbourhood.Rd pkg/man/spCopPredict.Rd pkg/man/spGaussCopPredict.Rd pkg/man/spGaussLogLik.Rd pkg/man/spVineCopula-class.Rd pkg/man/spVineCopula.Rd pkg/man/stCopPredict.Rd pkg/man/stNeighbourhood-class.Rd pkg/man/stNeighbourhood.Rd Log: - redesign of spatial and spatio-temporal neighbourhoods (make them lighter: skiped several slots) Modified: pkg/R/Classes.R =================================================================== --- pkg/R/Classes.R 2014-02-13 09:38:55 UTC (rev 123) +++ pkg/R/Classes.R 2014-02-13 20:05:42 UTC (rev 124) @@ -173,9 +173,9 @@ t.res="character"), validity = validStCopula, contains = list("copula")) -#################### -## vine copulas ## -#################### +############################################### +## vine copulas, happens now in VineCopula ## +############################################### # validVineCopula = function(object) { # dim <- object at dimension @@ -235,77 +235,58 @@ ## neighbourhood: -sizeLim <- 25 # a constant -# setSizeLim <- function(x) { -# env <- parent.env(environment()) -# unlockBinding("neighbourLim",env) -# assign("neighbourLim", x,envir=env) -# lockBinding("neighbourLim",env) -# } - -# a class combining two matrices holding the data and the corresponding -# distances as well a slot for the coordinates refernce system and an attribute -# if the data is already transformed to uniform on [0,1] distributed variables -# data: a list of data.frames holding the data per neighbour. each neighbour needs to have the same number of variables in the same order -# sp: an optional slot providing the coordinates of locations -# index: a matrix linking the data entries with the coordinates of the locations validNeighbourhood <- function(object) { if(length(var)>1) return("Only a single variable name is supported.") - if (object at prediction & is.null(object at predLocs)) - return("The prediction locations have to be provided for the prediction procedure.") # check for number of rows if (nrow(object at data) != nrow(object at distances)) return("Data and distances have unequal number of rows.") if (nrow(object at data) != nrow(object at index)) return("Data and index have unequal number of rows.") # check for columns - if (ncol(object at data) != ncol(object at distances)+1) + if (ncol(object at data) != ncol(object at distances) + 1 + length(object at coVar)) return("Data and distances have non matching number of columns.") - if (ncol(object at data) != ncol(object at index)) - return("Data and index have unequal number of columns.") + if (ncol(object at data) != ncol(object at index) + length(object at coVar)) + return("Data and index have non matching number of columns.") else return(TRUE) } -setClassUnion("optionalLocs",c("NULL","Spatial")) - setClass("neighbourhood", representation = representation(data = "data.frame", distances="matrix", index="matrix", - dataLocs="Spatial", - predLocs="optionalLocs", - prediction="logical", - var="character"), - validity = validNeighbourhood, contains = list("Spatial")) + var="character", + coVar="character", + prediction="logical"), + validity = validNeighbourhood) ## ST neighbourhood - validStNeighbourhood <- function(object) { - sizeN <- nrow(object at data) - if (object at prediction & is.null(object at dataLocs)) - return("The spatio-temporal locations of the data have to be provided for the estimation procedure.") dimDists <- dim(object at distances) + dimInd <- dim(object at index) + + stopifnot(length(dimDists)==3) + stopifnot(length(dimInd)==3) + stopifnot(dimDists[3] == dimInd[3]) + if (nrow(object at data) != dimDists[1]) return("Data and distances have unequal number of rows.") - dimInd <- dim(object at index) - if (nrow(object at data) != dimInd[1]) + if (nrow(object at data) != dimInd[1]) return("Data and index have unequal number of rows.") - if (dimDists[2] != dimInd[2]) - return("Data and index have unequal number of columns.") + if (ncol(object at data) + object at prediction != dimInd[2] + length(object at coVar)) + return("Data and index have non matching number of columns.") + if (dimDists[2]+1 != dimInd[2]) + return("Data and index have non matching number of columns.") else return(TRUE) } -setClassUnion("optionalST",c("NULL","ST")) - setClass("stNeighbourhood", representation = representation(data = "data.frame", distances="array", index="array", - locations="ST", - dataLocs="optionalST", var="character", + coVar="character", prediction="logical"), - validity = validStNeighbourhood, contains = list("ST")) \ No newline at end of file + validity = validStNeighbourhood) \ No newline at end of file Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2014-02-13 09:38:55 UTC (rev 123) +++ pkg/R/spCopula.R 2014-02-13 20:05:42 UTC (rev 124) @@ -657,15 +657,16 @@ cond <- suppressWarnings(as.numeric(varSplit[length(varSplit)])) if(is.na(cond)) { var <- paste(neigh at var,"|0",sep="") + coVar <- paste(neigh at coVar,"|0",sep="") colnames(u1) <- paste(paste("N", rep(1:(ncol(u1)), each=length(var)), sep=""), rep(var,ncol(u1)),sep=".") } else { var <- paste(neigh at var,cond+1,sep="") + coVar <- neigh at coVar colnames(u1) <- paste(paste("N", rep(cond:(ncol(u1)+cond-1)+2, each=length(var)), sep=""), rep(var,ncol(u1)),sep=".") } return(neighbourhood(data=u1, distances=h1, index=neigh at index[,-1], - dataLocs=neigh at dataLocs, predLocs=neigh at predLocs, - prediction=neigh at prediction, var=var)) + var=var, coVar=coVar, prediction=neigh at prediction)) } \ No newline at end of file Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2014-02-13 09:38:55 UTC (rev 123) +++ pkg/R/spVineCopula.R 2014-02-13 20:05:42 UTC (rev 124) @@ -86,13 +86,18 @@ dspVine(as.matrix(u), copula at spCop, NULL, log=log, ...) }) -# fiiting the spatial vine for a given list of spatial copulas -fitSpVine <- function(copula, data, method, estimate.variance=F) { - stopifnot(class(data)=="neighbourhood") - stopifnot(copula at dimension == ncol(data at data)) +# fitting the spatial vine for a given list of spatial copulas +fitSpVine <- function(copula, data, method, estimate.variance=FALSE) { + stopifnot(is.list(data)) + stopifnot(length(data)==2) + neigh <- data[[1]] + dataLocs <- data[[2]] - u0 <- as.matrix(data at data) # previous level's (contitional) data - h0 <- data at distances # previous level's distances + stopifnot(class(neigh)=="neighbourhood") + stopifnot(copula at dimension == ncol(neigh at data)) + + u0 <- as.matrix(neigh at data) # previous level's (contitional) data + h0 <- neigh at distances # previous level's distances l0 <- rep(0,nrow(u0)) # spatial density for(spTree in 1:length(copula at spCop)) { cat("[Dropping ", spTree, ". spatial tree.]\n",sep="") @@ -101,9 +106,9 @@ for(i in 1:ncol(h0)) { # i <- 1 l0 <- l0 + dCopula(u0[,c(1,i+1)], copula at spCop[[spTree]], h=h0[,i], log=T) u1 <- cbind(u1, dduCopula(u0[,c(1,i+1)], copula at spCop[[spTree]], h=h0[,i])) - if (i < ncol(h0)) { - h1 <- cbind(h1,apply(data at index[,c(spTree+1,spTree+i+1)],1, - function(x) spDists(data at dataLocs[x,])[1,2])) + if (i < ncol(h0) & spTree < length(copula at spCop)) { + h1 <- cbind(h1,apply(neigh at index[,c(spTree+1,spTree+i+1)],1, + function(x) spDists(dataLocs[x,])[1,2])) } } u0 <- u1 @@ -135,13 +140,13 @@ method = sapply(method,paste,collapse=", "), loglik = sum(l0)+loglik, fitting.stats=list(convergence = as.integer(NA)), - nsample = nrow(data at data), copula=spVineCop)) + nsample = nrow(neigh at data), copula=spVineCop)) } -setMethod("fitCopula",signature=signature("spVineCopula"),fitSpVine) +setMethod("fitCopula", signature=signature("spVineCopula"), fitSpVine) # deriving all spatial tree distances -calcSpTreeDists <- function(neigh, n.trees) { +calcSpTreeDists <- function(neigh, dataLocs, n.trees) { condDists <- list(n.trees) condDists[[1]] <- neigh at distances if(n.trees==1) @@ -150,7 +155,7 @@ h1 <- NULL for(i in 1:(ncol(neigh at distances)-spTree)) { h1 <- cbind(h1,apply(neigh at index[,c(spTree+1,spTree+i+1),drop=F],1, - function(x) spDists(neigh at dataLocs[x,])[1,2])) + function(x) spDists(dataLocs[x,])[1,2])) dimnames(h1) <- NULL } condDists[[spTree+1]] <- h1 @@ -185,11 +190,13 @@ # interpolation -spCopPredict.expectation <- function(predNeigh, spVine, margin, ..., stop.on.error=F) { +spCopPredict.expectation <- function(data, spVine, margin, ..., stop.on.error=F) { stopifnot(is.function(margin$q)) - dists <- calcSpTreeDists(predNeigh,length(spVine at spCop)) + predNeigh <- data[[1]] + dists <- calcSpTreeDists(predNeigh, data[[2]], length(spVine at spCop)) + predMean <- NULL pb <- txtProgressBar(0,nrow(predNeigh at data), 0, width=getOption("width")-10, style=3) @@ -210,21 +217,24 @@ } close(pb) - if ("data" %in% slotNames(predNeigh at predLocs)) { + predLocs <- data[[3]] + if ("data" %in% slotNames(predLocs)) { res <- predNeigh at predLocs res at data[["expect"]] <- predMean return(res) } else { predMean <- data.frame(predMean) colnames(predMean) <- "expect" - return(addAttrToGeom(predNeigh at predLocs, predMean, match.ID=FALSE)) + return(addAttrToGeom(predLocs, predMean, match.ID=FALSE)) } } -spCopPredict.quantile <- function(predNeigh, spVine, margin, p=0.5) { +spCopPredict.quantile <- function(data, spVine, margin, p=0.5) { stopifnot(is.function(margin$q)) - dists <- calcSpTreeDists(predNeigh,length(spVine at spCop)) + predNeigh <- data[[1]] + dists <- calcSpTreeDists(predNeigh, data[[2]], length(spVine at spCop)) + predQuantile <- NULL pb <- txtProgressBar(0, nrow(predNeigh at data), 0, width=getOption("width")-10, style=3) for(i in 1:nrow(predNeigh at data)) { # i <-1 @@ -241,31 +251,29 @@ b <- density[lower] xRes <- -b/m+sign(m)*sqrt(b^2/m^2+2*(p-int[lower])/m) -# pPred <- optimise(function(x) abs(integrate(condSecVine, 0, x, -# subdivisions=10000L, -# abs.tol=1e-6)$value-p), c(0,1)) -# if(pPred$objective > 1e-4) -# warning("Numerical evaluation in predQuantile achieved an objective of only ", -# pPred$objective, " where 0 has been sought for location ",i,".") predQuantile <- c(predQuantile, margin$q(xVals[lower]+xRes)) } close(pb) - if ("data" %in% slotNames(predNeigh at predLocs)) { - res <- predNeigh at predLocs + predLocs <- data[[3]] + if ("data" %in% slotNames(predLocs)) { + res <- predLocs res at data[[paste("quantile.",p,sep="")]] <- predQuantile return(res) } else { predQuantile <- data.frame(predQuantile) colnames(predQuantile) <- paste("quantile.",p,sep="") - return(addAttrToGeom(predNeigh at predLocs, predQuantile, match.ID=FALSE)) + return(addAttrToGeom(predLocs, predQuantile, match.ID=FALSE)) } } -spCopPredict <- function(predNeigh, spVine, margin, method="quantile", p=0.5, ...) { +spCopPredict <- function(data, spVine, margin, method="quantile", p=0.5, ...) { + stopifnot(is.list(data)) + stopifnot(length(data)==3) + switch(method, - quantile=spCopPredict.quantile(predNeigh, spVine, margin, p), - expectation=spCopPredict.expectation(predNeigh, spVine, margin, ...)) + quantile=spCopPredict.quantile(data, spVine, margin, p), + expectation=spCopPredict.expectation(data, spVine, margin, ...)) } # draw from a spatial vine Modified: pkg/R/spatialGaussianCopula.R =================================================================== --- pkg/R/spatialGaussianCopula.R 2014-02-13 09:38:55 UTC (rev 123) +++ pkg/R/spatialGaussianCopula.R 2014-02-13 20:05:42 UTC (rev 124) @@ -1,10 +1,10 @@ ## spatial Gaussian Copula # "density" evaluation -spGaussLogLik <- function(corFun, neigh, log=T) { +spGaussLogLik <- function(corFun, neigh, dataLocs, log=T) { neighDim <- ncol(neigh at data) - allDataDists <- spDists(neigh at dataLocs) + allDataDists <- spDists(dataLocs) pb <- txtProgressBar(0, nrow(neigh at data), 0, width = getOption("width") - 10, style = 3) @@ -29,12 +29,12 @@ } # interpolation based on a valid corelogram function -spGaussCopPredict <- function(corFun, predNeigh, margin, p=0.5, ..., n=1000) { +spGaussCopPredict <- function(corFun, predNeigh, dataLocs, predLocs, margin, p=0.5, ..., n=1000) { stopifnot(is.list(margin)) stopifnot(is(margin$q, "function")) neighDim <- ncol(predNeigh at data) - allDataDists <- spDists(predNeigh at dataLocs) + allDataDists <- spDists(dataLocs) pb <- txtProgressBar(0, nrow(predNeigh at data), 0, width = getOption("width") - 10, style = 3) @@ -73,15 +73,15 @@ } close(pb) - if ("data" %in% slotNames(predNeigh at predLocs)) { - res <- predNeigh at predLocs + if ("data" %in% slotNames(predLocs)) { + res <- predLocs res at data[[paste("quantile.", p, sep = "")]] <- predQuantile return(res) } else { predQuantile <- data.frame(predQuantile) colnames(predQuantile) <- paste("quantile.", p, sep = "") - return(addAttrToGeom(predNeigh at predLocs, predQuantile, + return(addAttrToGeom(predLocs, predQuantile, match.ID = FALSE)) } } Modified: pkg/R/spatialPreparation.R =================================================================== --- pkg/R/spatialPreparation.R 2014-02-13 09:38:55 UTC (rev 123) +++ pkg/R/spatialPreparation.R 2014-02-13 20:05:42 UTC (rev 124) @@ -7,110 +7,59 @@ ## spatial neighbourhood constructor #################################### -neighbourhood <- function(data, distances, index, dataLocs, predLocs=NULL, - prediction, var) { +neighbourhood <- function(data, distances, index, var, coVar=character(), prediction=FALSE) { sizeN <- ncol(distances)+1 data <- as.data.frame(data) if (anyDuplicated(rownames(data))>0) rownames <- 1:length(rownames) + new("neighbourhood", data=data, distances=distances, index=index, - dataLocs=dataLocs, predLocs=predLocs, prediction=prediction, var=var, - bbox=dataLocs at bbox, proj4string=dataLocs at proj4string) + var=var, coVar=coVar, prediction=prediction) } ## show showNeighbourhood <- function(object){ cat("A set of neighbourhoods consisting of", ncol(object at distances)+1, "locations each \n") - cat("with",nrow(object at data),"rows of observations for:\n") - cat(object at var,"\n") + if (length(object at var)>0) { + cat("with", nrow(object at data), "rows of observations for:\n") + cat(object at var, "\n") + } else { + cat("without data \n") + } + if(length(object at coVar)>0) + cat("with covariate", object at coVar, "\n") } -setMethod(show,signature("neighbourhood"),showNeighbourhood) +setMethod(show, signature("neighbourhood"), showNeighbourhood) ## names (from sp) -setMethod(names, signature("neighbourhood"), function(x) x at var) +setMethod(names, signature("neighbourhood"), function(x) c(x at var,x at coVar)) -## spplot ## -spplotNeighbourhood <- function(obj, zcol=names(obj), ..., column=0) { - stopifnot(all(column0 || prediction) -# -# if(missing(predLocs) && !prediction) -# predLocs=dataLocs -# -# stopifnot(is(predLocs,"Spatial")) -# -# if(any(is.na(match(var,names(dataLocs))))) -# stop("At least one of the variables is unkown or is not part of the data.") -# -# nLocs <- length(predLocs) -# size <- min(size, length(dataLocs)+prediction) -# -# allLocs <- matrix(NA,nLocs,size) -# allDists <- matrix(NA,nLocs,size-1) -# allData <- matrix(NA,nLocs,size) -# for (i in 1:nLocs) { -# tempDists <- spDists(dataLocs, predLocs[i, ]) -# tempDists[tempDists < min.dist] <- Inf -# spLocs <- order(tempDists)[1:(size - 1)] -# -# allLocs[i,] <- c(i, spLocs) -# allDists[i,] <- tempDists[spLocs] -# allData[i,(prediction+1):size] <- dataLocs[c(i[!prediction],spLocs), -# var, drop = F]@data[[1]] -# } -# -# if (!prediction) -# predLocs <- NULL -# colnames(allData) <- paste(paste("N", rep(0:(size-1), -# each=length(var)), sep=""), -# rep(var,size),sep=".") -# return(neighbourhood(allData, allDists, allLocs, dataLocs, -# predLocs, prediction, var)) -# } -# - - -getNeighbours <- function (dataLocs, predLocs, var = names(dataLocs)[1], size = 5, - prediction = FALSE, min.dist = 0.01) -{ - stopifnot((!prediction && missing(predLocs)) || (prediction && - !missing(predLocs))) +getNeighbours <- function (dataLocs, predLocs, size = 5, + var = names(dataLocs)[1], coVar=character(), + prediction = FALSE, min.dist = 0.01) { + stopifnot((!prediction && missing(predLocs)) || (prediction && !missing(predLocs))) stopifnot(min.dist > 0 || prediction) + if (missing(predLocs) && !prediction) predLocs = dataLocs + stopifnot(is(predLocs, "Spatial")) - if (any(is.na(match(var, names(dataLocs))))) - stop("At least one of the variables is unkown or is not part of the data.") + + if ("data" %in% slotNames(dataLocs)) { + if (any(is.na(match(var, names(dataLocs))))) + stop("The variables is not part of the data.") + } + nLocs <- length(predLocs) size <- min(size, length(dataLocs) + prediction) @@ -128,18 +77,25 @@ as.integer(prediction), PACKAGE="spcopula") - if (!prediction) allData <- matrix(dataLocs[result$allLocs, var, drop = F]@data[[1]], nLocs, size) - else allData <- matrix(c(rep(NA,nLocs),dataLocs[result$allLocs[(nLocs+1):(nLocs*size)], var, drop = F]@data[[1]]), nLocs, size) + if ("data" %in% slotNames(dataLocs)) { + if (!prediction) { + allData <- matrix(dataLocs[result$allLocs, var, drop = F]@data[[1]], + nLocs, size) + } else { + allData <- matrix(c(rep(NA,nLocs), + dataLocs[result$allLocs[(nLocs+1):(nLocs*size)], var, drop = F]@data[[1]]), + nLocs, size) + } + colnames(allData) <- paste(paste("N", rep(0:(size - 1), each = length(var)), sep = ""), + rep(var, size), sep = ".") + } else { + allData <- as.data.frame(matrix(NA, nLocs, size + length(coVar))) + var <- character() + } - if (!prediction) - predLocs <- NULL - - colnames(allData) <- paste(paste("N", rep(0:(size - 1), each = length(var)), - sep = ""), rep(var, size), sep = ".") - - - return(neighbourhood(allData, matrix(result$allDists,nLocs, size - 1), matrix(result$allLocs, nLocs, size), dataLocs, - predLocs, prediction, var)) + return(neighbourhood(data=allData, distances=matrix(result$allDists, nLocs, size - 1), + index=matrix(result$allLocs, nLocs, size), var=var, coVar=coVar, + prediction=prediction)) } ############# @@ -272,84 +228,4 @@ return(res) } -setMethod(calcBins, signature="neighbourhood", calcNeighBins) - -# instances: number -> number of randomly choosen temporal intances -# NA -> all observations -# other -> temporal indexing as in spacetime/xts, the parameter t.lags is set to 0 in this case. -# t.lags: numeric -> temporal shifts between obs -calcStBins <- function(data, var, nbins=15, boundaries=NA, cutoff=NA, - instances=NA, t.lags=-(0:2), ..., - cor.method="fasttau", plot=FALSE) { - if(is.na(cutoff)) - cutoff <- spDists(coordinates(t(data at sp@bbox)))[1,2]/3 - if(is.na(boundaries)) - boundaries <- ((1:nbins) * cutoff / nbins) - if(is.na(instances)) - instances=length(data at time) - - spIndices <- calcSpLagInd(data at sp, boundaries) - - mDists <- sapply(spIndices,function(x) mean(x[,3])) - - lengthTime <- length(data at time) - if (!is.numeric(instances) | !length(instances)==1) { - tempIndices <- cbind(instances, instances) - } - else { - tempIndices <- NULL - for (t.lag in rev(t.lags)) { -# smplInd <- max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)) - smplInd <- sample(x=max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)), - size=min(instances,lengthTime-max(abs(t.lags)))) - tempIndices <- cbind(smplInd+t.lag, tempIndices) - tempIndices <- cbind(smplInd, tempIndices) - } - } - - retrieveData <- function(spIndex, tempIndices) { - binnedData <- NULL - for (i in 1:(ncol(tempIndices)/2)) { - binnedData <- cbind(binnedData, - as.matrix((cbind(data[spIndex[,1], tempIndices[,2*i-1], var]@data, - data[spIndex[,2], tempIndices[,2*i], var]@data)))) - } - return(binnedData) - } - - lagData <- lapply(spIndices, retrieveData, tempIndices=tempIndices) - - calcStats <- function(binnedData) { - cors <- NULL - for(i in 1:(ncol(binnedData)/2)) { - cors <- c(cors, cor(binnedData[,2*i-1], binnedData[,2*i], method=cor.method, use="pairwise.complete.obs")) - } - return(cors) - } - - calcTau <- function(binnedData) { - cors <- NULL - for(i in 1:(ncol(binnedData)/2)) { - tmpData <- binnedData[,2*i+c(-1,0)] - tmpData <- tmpData[!apply(tmpData, 1, function(x) any(is.na(x))),] - cors <- c(cors, TauMatrix(tmpData)[1,2]) - } - return(cors) - } - - calcCor <- switch(cor.method, fasttau=calcTau, calcStats) - - lagCor <- sapply(lagData, calcCor) - - if(plot) { - plot(mDists, as.matrix(lagCor)[1,], xlab="distance",ylab=paste("correlation [",cor.method,"]",sep=""), - ylim=1.05*c(-abs(min(lagCor)),max(lagCor)), xlim=c(0,max(mDists))) - abline(h=c(-min(lagCor),0,min(lagCor)),col="grey") - } - - res <- list(meanDists = mDists, lagCor=lagCor, lagData=lagData, lags=list(sp=spIndices, time=tempIndices)) - attr(res,"cor.method") <- cor.method - return(res) -} - -setMethod(calcBins, signature(data="STFDF"), calcStBins) +setMethod(calcBins, signature="neighbourhood", calcNeighBins) \ No newline at end of file Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2014-02-13 09:38:55 UTC (rev 123) +++ pkg/R/spatio-temporalPreparation.R 2014-02-13 20:05:42 UTC (rev 124) @@ -7,52 +7,79 @@ ## spatio-temporal neighbourhood constructor ############################################ -stNeighbourhood <- function(data, distances, STxDF, ST=NULL,index, - prediction, var) { +stNeighbourhood <- function(data, distances, index, var, coVar=character(), prediction=FALSE) { data <- as.data.frame(data) sizeN <- nrow(data) + dimDists <- dim(distances) + dimInd <- dim(index) - stopifnot(dimDists[1]==sizeN) - stopifnot(dimDists[2]==ncol(data)-(!prediction)) - stopifnot(dimDists[3]==2) - colnames(data) <- paste(paste("N", (0+prediction):dimDists[2], sep=""),var,sep=".") + stopifnot(length(dimDists) == 3) + stopifnot(length(dimInd) == 3) + + stopifnot(dimDists[1] == sizeN) + stopifnot(dimInd[1] == dimDists[1]) + + stopifnot(((dimDists[2] + !prediction) + length(coVar)) == ncol(data)) + stopifnot(dimInd[2] == dimDists[2]+1) + + stopifnot(dimDists[3] == 2) + stopifnot(dimInd[3] == dimDists[3]) + + colnames(data) <- paste(paste("N", (0+prediction):dimDists[2], sep=""), var, sep=".") + + if(length(coVar)>0) + colnames(data)[dimDists[2] + 1:length(coVar)] <- paste("N0", coVar) + if (anyDuplicated(rownames(data))>0) rownames <- 1:length(rownames) - new("stNeighbourhood", data=data, distances=distances, locations=ST, - dataLocs=STxDF, index=index, prediction=prediction, var=var, - sp=as(STxDF at sp, "Spatial"), time=STxDF at time[1], - endTime=STxDF at endTime[length(STxDF at endTime)]) + + new("stNeighbourhood", data=data, distances=distances, index=index, + var=var, coVar=coVar, prediction=prediction) } ## show -showStNeighbourhood <- function(object){ +showStNeighbourhood <- function(object) { cat("A set of spatio-temporal neighbourhoods consisting of", dim(object at distances)[2]+1, "locations each \n") cat("with",nrow(object at data),"rows of observations for:\n") cat(object at var,"\n") + if(length(object at coVar > 0)) + cat("with covariate", object at coVar, "\n") } -setMethod(show,signature("stNeighbourhood"),showStNeighbourhood) +setMethod(show, signature("stNeighbourhood"), showStNeighbourhood) +# select +selectFromStNeighbourhood <- function(x, i) { + new("stNeighbourhood", data=x at data[i,,drop=F], + distances=x at distances[i,,,drop=F], index=x at index[i,,,drop=F], + var=x at var, coVar=x at coVar, prediction=x at prediction) +} +setMethod("[", signature("stNeighbourhood","numeric"), selectFromStNeighbourhood) + ## calculate neighbourhood from ST # returns an neighbourhood object ################################## -getStNeighbours <- function(stData, ST, var=names(stData at data)[1], spSize=4, - t.lags=-(0:2), timeSteps=NA, prediction=FALSE, min.dist=0.01) { +getStNeighbours <- function(stData, ST, spSize=4, t.lags=-(0:2), + var=names(stData at data)[1], coVar=character(), + timeSteps=NA, prediction=FALSE, min.dist=0.01) { stopifnot((!prediction && missing(ST)) || (prediction && !missing(ST))) stopifnot(min.dist>0 || prediction) timeSpan <- min(t.lags) if(missing(ST) && !prediction) - ST=stData + ST=geometry(stData) stopifnot(is(ST,"ST")) if(any(is.na(match(var,names(stData at data))))) - stop("At least one of the variables is unkown or is not part of the data.") + stop("The variables is not part of stData.") + if(length(coVar)>0) + if(any(is.na(match(coVar,names(stData at data))))) + stop("The covariate is not part of stData.") if(!prediction) { if(is.na(timeSteps)) { @@ -62,58 +89,73 @@ reSample <- function() sort(sample((1-timeSpan):length(stData at time), timeSteps)) } nLocs <- length(ST at sp)*timeSteps - nghbrs <- getNeighbours(stData[,1], var=var, size=spSize, min.dist=min.dist) + nghbrs <- getNeighbours(dataLocs=geometry(stData at sp), var=character(), size=spSize, + min.dist=min.dist) } else { nLocs <- length(ST) - nghbrs <- getNeighbours(stData[,1], ST at sp, var, spSize, prediction, min.dist) + nghbrs <- getNeighbours(dataLocs=geometry(stData at sp), predLocs=geometry(ST at sp), + size=spSize, var=character(), prediction=prediction, + min.dist=min.dist) timeNghbrs <- sapply(index(ST at time), function(x) which(x == index(stData at time))) reSample <- function() timeNghbrs timeSteps <- length(stData at time)+timeSpan } - stNeighData <- matrix(NA, nLocs, (spSize-1)*length(t.lags)+1) - stDists <- array(NA,c(nLocs,(spSize-1)*length(t.lags),2)) - stInd <- array(NA,c(nLocs,(spSize-1)*length(t.lags),2)) + nStNeighs <- (spSize-1)*length(t.lags) + stNeighData <- matrix(NA, nLocs, nStNeighs + 1 + length(coVar)) + stDists <- array(NA,c(nLocs, nStNeighs, 2)) + stInd <- array(NA,c(nLocs, nStNeighs + 1, 2)) + nTimeInst <- length(reSample()) - for(i in 1:nrow(nghbrs at index)){ # i <- 1 + for (i in 1:nrow(nghbrs at index)) { timeInst <- reSample() # draw random time steps for each neighbourhood - stNeighData[(i-1)*timeSteps+(1:timeSteps), - 1:spSize] <- matrix(stData[nghbrs at index[i,], timeInst, - var, drop=F]@data[[1]], - ncol=spSize, byrow=T) # retrieve the top level data - tmpInd <- matrix(rep(timeInst, spSize-1), ncol=spSize-1) - for(j in 2:length(t.lags)) { + spInd <- (i-1)*timeSteps+(1:timeSteps) + + stNeighData[spInd, 1:spSize] <- matrix(stData[nghbrs at index[i,], timeInst, + var, drop=F]@data[[1]], + ncol=spSize, byrow=T) + # add covariate(s) to the last column(s) + if (length(coVar) > 0) { + coVarCols <- nStNeighs + 1 + (1:length(coVar)) + stNeighData[spInd, coVarCols] <- matrix(stData[nghbrs at index[i,1], timeInst, + coVar, drop=F]@data[[1]], + ncol=length(coVar), byrow=T) + } + + tmpInd <- matrix(rep(timeInst, spSize), ncol=spSize) + + for (j in 2:length(t.lags)) { t <- t.lags[j] - stNeighData[(i-1)*timeSteps+(1:timeSteps), - (j-1)*(spSize-1)+2:(spSize)] <- matrix(stData[nghbrs at index[i,][-1], - timeInst+t, - var, drop=F]@data[[1]], - ncol=spSize-1, byrow=T) - tmpInd <- cbind(tmpInd, matrix(rep(timeInst+t,spSize-1),ncol=spSize-1)) + stNeighData[spInd, (j-1)*(spSize-1)+2:(spSize)] <- matrix(stData[nghbrs at index[i,][-1], + timeInst+t, var, drop=F]@data[[1]], + ncol=spSize-1, byrow=T) + tmpInd <- cbind(tmpInd, matrix(rep(timeInst+t,spSize-1), ncol=spSize-1)) } - - stDists[(i-1)*timeSteps+1:timeSteps,,1] <- matrix(rep(nghbrs at distances[i,], - timeSteps*length(t.lags)), - byrow=T, ncol=length(t.lags)*(spSize-1)) # store sp distances - stDists[(i-1)*timeSteps+1:timeSteps,,2] <- matrix(rep(rep(t.lags,each=spSize-1), - timeSteps), - byrow=T, ncol=length(t.lags)*(spSize-1)) # store tmp distances - stInd[(i-1)*timeSteps+1:timeSteps,,1] <- matrix(rep(nghbrs at index[i,][-1], - timeSteps*length(t.lags)), - byrow=T, ncol=length(t.lags)*(spSize-1)) - stInd[(i-1)*timeSteps+1:timeSteps,,2] <- tmpInd + + # store spatial distances + stDists[spInd,,1] <- matrix(rep(nghbrs at distances[i,], timeSteps*length(t.lags)), + byrow=T, ncol=nStNeighs) + + # store temporal distances + stDists[spInd,,2] <- matrix(rep(rep(t.lags,each=spSize-1), timeSteps), + byrow=T, ncol=nStNeighs) + + # store space indices + stInd[spInd,,1] <- matrix(rep(c(nghbrs at index[i, ], rep(nghbrs at index[i, -1], length(t.lags)-1)), + timeSteps), ncol = nStNeighs + 1, byrow = T) + + # store time indices + stInd[spInd,,2] <- tmpInd } if (prediction) { - dataLocs <- stData stNeighData <- stNeighData[,-1] } else { dataLocs <- NULL } [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 124 From noreply at r-forge.r-project.org Fri Feb 14 11:34:30 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 14 Feb 2014 11:34:30 +0100 (CET) Subject: [spcopula-commits] r125 - in pkg: . R man Message-ID: <20140214103430.1ACBF186ECC@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-14 11:34:29 +0100 (Fri, 14 Feb 2014) New Revision: 125 Added: pkg/man/condCovariate.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/spCopula.R pkg/R/spVineCopula.R pkg/R/spatio-temporalPreparation.R pkg/R/stCoVarVineCopula.R pkg/R/stCopula.R pkg/R/stVineCopula.R pkg/man/calcBins.Rd pkg/man/dropSpTree.Rd pkg/man/dropStTree.Rd pkg/man/neighbourhood-class.Rd pkg/man/spCopPredict.Rd pkg/man/spGaussLogLik.Rd pkg/man/stCopPredict.Rd pkg/man/stNeighbourhood-class.Rd Log: - subsequent changes due to the redesign of neighbourhood classes Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/DESCRIPTION 2014-02-14 10:34:29 UTC (rev 125) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-02-13 +Date: 2014-02-14 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/NAMESPACE 2014-02-14 10:34:29 UTC (rev 125) @@ -19,7 +19,7 @@ export(qCopula_u) export(condSpVine,spCopPredict) export(condStVine,stCopPredict) -export(condStCoVarVine) +export(condStCoVarVine, condCovariate) export(spGaussCopPredict, spGaussLogLik) # tweaks Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/R/spCopula.R 2014-02-14 10:34:29 UTC (rev 125) @@ -640,7 +640,7 @@ } ## dropping a spatial tree, returning a conditional neighbourhood -dropSpTree <- function(neigh, spCop) { +dropSpTree <- function(neigh, dataLocs, spCop) { u1 <- matrix(NA,nrow(neigh at data),ncol(neigh at data)-1) h1 <- matrix(NA,nrow(neigh at distances),ncol(neigh at distances)-1) @@ -649,7 +649,7 @@ neigh at distances[,i]) if (i < ncol(neigh at distances)) { h1[,i] <- apply(neigh at index[,c(2,2+i)],1, - function(x) spDists(neigh at dataLocs[x,])[1,2]) + function(x) spDists(dataLocs[x,])[1,2]) } } Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/R/spVineCopula.R 2014-02-14 10:34:29 UTC (rev 125) @@ -190,13 +190,9 @@ # interpolation -spCopPredict.expectation <- function(data, spVine, margin, ..., stop.on.error=F) { - stopifnot(is.function(margin$q)) +spCopPredict.expectation <- function(predNeigh, dataLocs, predLocs, spVine, margin, ..., stop.on.error=F) { + dists <- calcSpTreeDists(predNeigh, dataLocs, length(spVine at spCop)) - predNeigh <- data[[1]] - - dists <- calcSpTreeDists(predNeigh, data[[2]], length(spVine at spCop)) - predMean <- NULL pb <- txtProgressBar(0,nrow(predNeigh at data), 0, width=getOption("width")-10, style=3) @@ -217,7 +213,6 @@ } close(pb) - predLocs <- data[[3]] if ("data" %in% slotNames(predLocs)) { res <- predNeigh at predLocs res at data[["expect"]] <- predMean @@ -229,12 +224,9 @@ } } -spCopPredict.quantile <- function(data, spVine, margin, p=0.5) { - stopifnot(is.function(margin$q)) +spCopPredict.quantile <- function(predNeigh, dataLocs, predLocs, spVine, margin, p=0.5) { + dists <- calcSpTreeDists(predNeigh, dataLocs, length(spVine at spCop)) - predNeigh <- data[[1]] - dists <- calcSpTreeDists(predNeigh, data[[2]], length(spVine at spCop)) - predQuantile <- NULL pb <- txtProgressBar(0, nrow(predNeigh at data), 0, width=getOption("width")-10, style=3) for(i in 1:nrow(predNeigh at data)) { # i <-1 @@ -255,7 +247,6 @@ } close(pb) - predLocs <- data[[3]] if ("data" %in% slotNames(predLocs)) { res <- predLocs res at data[[paste("quantile.",p,sep="")]] <- predQuantile @@ -267,13 +258,15 @@ } } -spCopPredict <- function(data, spVine, margin, method="quantile", p=0.5, ...) { - stopifnot(is.list(data)) - stopifnot(length(data)==3) +spCopPredict <- function(predNeigh, dataLocs, predLocs, spVine, margin, method="quantile", p=0.5, ...) { + stopifnot(is.function(margin$q)) + stopifnot(class(predNeigh) == "neighbourhood") + stopifnot(inherits(dataLocs, "Spatial")) + stopifnot(inherits(predLocs, "Spatial")) switch(method, - quantile=spCopPredict.quantile(data, spVine, margin, p), - expectation=spCopPredict.expectation(data, spVine, margin, ...)) + quantile=spCopPredict.quantile(predNeigh, dataLocs, predLocs, spVine, margin, p), + expectation=spCopPredict.expectation(predNeigh, dataLocs, predLocs, spVine, margin, ...)) } # draw from a spatial vine Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/R/spatio-temporalPreparation.R 2014-02-14 10:34:29 UTC (rev 125) @@ -29,7 +29,7 @@ colnames(data) <- paste(paste("N", (0+prediction):dimDists[2], sep=""), var, sep=".") if(length(coVar)>0) - colnames(data)[dimDists[2] + 1:length(coVar)] <- paste("N0", coVar) + colnames(data)[ncol(data) + 1 - (length(coVar):1)] <- paste("N0", coVar) if (anyDuplicated(rownames(data))>0) rownames <- 1:length(rownames) @@ -167,12 +167,15 @@ dimStNeigh <- dim(stNeigh at distances) corMat <- matrix(NA, dimStNeigh[1], dimStNeigh[2]) + pb <- txtProgressBar(0, dimStNeigh[2], style=3) for (i in 1:dimStNeigh[2]) { boolNA <- is.na(stNeigh at data[[1]]) | is.na(stNeigh at data[[1+i]]) stNeigh at distances[boolNA,i,] <- c(NA,NA) tLag <- -1*stNeigh at distances[!boolNA,i,2][1]+1 corMat[!boolNA,i] <- stDepFun(stNeigh at distances[!boolNA,i,1], tLag) + setTxtProgressBar(pb, i) } + close(pb) highCorMat <- t(apply(corMat, 1, function(x) order(x, na.last=TRUE, decreasing=TRUE)[1:n])) nrCM <- nrow(highCorMat) @@ -206,8 +209,8 @@ } ## to be redone -calcStNeighBins <- function(data, var="uniPM10", nbins=9, t.lags=-(0:2), - boundaries=NA, cutoff=NA, cor.method="fasttau") { +# calcStNeighBins <- function(data, var="uniPM10", nbins=9, t.lags=-(0:2), +# boundaries=NA, cutoff=NA, cor.method="fasttau") { # dists <- data at distances[,,1] # # corFun <- switch(cor.method, @@ -310,11 +313,11 @@ # res <- list(np=np, meanDists = meanDists, lagCor=moa, lagData=lagData) # attr(res,"cor.method") <- switch(cor.method, fasttau="kendall", cor.method) # return(res) -} +# } +# +# setMethod(calcBins, signature="stNeighbourhood", calcStNeighBins) -setMethod(calcBins, signature="stNeighbourhood", calcStNeighBins) - # instances: number -> number of randomly choosen temporal intances # NA -> all observations # other -> temporal indexing as in spacetime/xts, the parameter t.lags is set to 0 in this case. Modified: pkg/R/stCoVarVineCopula.R =================================================================== --- pkg/R/stCoVarVineCopula.R 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/R/stCoVarVineCopula.R 2014-02-14 10:34:29 UTC (rev 125) @@ -166,6 +166,25 @@ return(condVineFun) } +# condition the covariate on the central location +condCovariate <- function(stNeigh, coVarCop) { + stopifnot(length(stNeigh at coVar) == 1) + + nrNeigh <- nrow(stNeigh at index) + ncData <- ncol(stNeigh at data) + + vddu <- numeric(nrNeigh) + uv <- as.matrix(stNeigh at data[,c(1,ncData)]) + stInd <- stNeigh at index[,1,] + + for (i in 1:nrNeigh) { + vddu[i] <- dduCopula(uv[i,], coVarCop(stInd[i,])) + } + + return(vddu) +} + + ## interpolation ## ################### # Modified: pkg/R/stCopula.R =================================================================== --- pkg/R/stCopula.R 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/R/stCopula.R 2014-02-14 10:34:29 UTC (rev 125) @@ -177,4 +177,46 @@ setMethod("ddvCopula", signature("numeric","stCopula"), function(u, copula, ...) ddvStCopula(matrix(u,ncol=2), copula, ...)) -setMethod("ddvCopula", signature("matrix","stCopula"), ddvStCopula) \ No newline at end of file +setMethod("ddvCopula", signature("matrix","stCopula"), ddvStCopula) + +# dropping a sptio-temporal tree +dropStTree <- function (stNeigh, dataLocs, stCop) { + stopifnot(class(stNeigh) == "stNeighbourhood") + + u0 <- as.matrix(stNeigh at data) + h0 <- stNeigh at distances + u1 <- matrix(NA, nrow(u0), ncol(u0)-1-length(stNeigh at coVar)) + h1 <- array(dim = c(nrow(u0), ncol(h0)-1, 2)) + + pb <- txtProgressBar(0,dim(h0)[2],style=3) + for (i in 1:dim(h0)[2]) { + u1[,i] <- dduCopula(u0[, c(1, i + 1)], stCop, h = h0[, i, ]) + if (i < ncol(h0)) { + h1[,i,1] <- apply(stNeigh at index[, c(1, i + 1), 1], 1, + function(x) spDists(dataLocs at sp[x, ])[1, 2]) + h1[,i,2] <- apply(stNeigh at index[, c(1, i + 1), 2], 1, + function(x) diff(x)) + } + setTxtProgressBar(pb, i) + } + close(pb) + +# # add covariate to the conditioned neighbourhood? +# if (length(stNeigh at coVar) > 0) +# u1[,ncol(u0)-(1:length(stNeigh at coVar))] <- u0[,ncol(u0) + 1 - (1:length(stNeigh at coVar))] + + varSplit <- strsplit(stNeigh at var, "|", fixed = TRUE)[[1]] + cond <- suppressWarnings(as.numeric(varSplit[length(varSplit)])) + + if (is.na(cond)) { +# coVar <- paste(stNeigh at coVar, "|0", sep = "") + cond <- paste(stNeigh at var, "|0", sep = "") + } + else { +# coVar <- stNeigh at coVar + cond <- paste(stNeigh at var, cond + 1, sep = "") + } + + return(stNeighbourhood(data = u1, distances = h1, index = stNeigh at index[, -1, ], + var = cond, prediction = stNeigh at prediction)) +} \ No newline at end of file Modified: pkg/R/stVineCopula.R =================================================================== --- pkg/R/stVineCopula.R 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/R/stVineCopula.R 2014-02-14 10:34:29 UTC (rev 125) @@ -136,10 +136,7 @@ ## interpolation ## ################### -stCopPredict.expectation <- function(data, stVine, margin, ..., stop.on.error=F) { - stopifnot(is.function(margin$q)) - - predNeigh <- data[[1]] +stCopPredict.expectation <- function(predNeigh, dataST, predST, stVine, margin, ..., stop.on.error=F) { dists <- predNeigh at distances predMean <- NULL @@ -157,24 +154,19 @@ ePred$abs.error, " for location ",i,".") predMean <- c(predMean, ePred$value) } - - predLocs <- data[[3]] - - if ("data" %in% slotNames(predLocs)) { - res <- predLocs + + if ("data" %in% slotNames(predST)) { + res <- predST res at data[["expect"]] <- predMean return(res) } else { predMean <- data.frame(predMean) colnames(predMean) <- "expect" - return(addAttrToGeom(predLocs, predMean, match.ID=FALSE)) + return(addAttrToGeom(predST, predMean, match.ID=FALSE)) } } -stCopPredict.quantile <- function(data, stVine, margin, p=0.5) { - stopifnot(is.function(margin$q)) - - predNeigh <- data[[1]] +stCopPredict.quantile <- function(predNeigh, dataST, predST, stVine, margin, p=0.5) { dists <- predNeigh at distances predQuantile <- NULL @@ -193,68 +185,26 @@ predQuantile <- c(predQuantile, margin$q(xVals[lower]+xRes)) } - - predLocs <- data[[3]] - - if ("data" %in% slotNames(predLocs)) { - res <- predLocs + + if ("data" %in% slotNames(predST)) { + res <- predST res at data[[paste("quantile.",p,sep="")]] <- predQuantile return(res) } else { predQuantile <- data.frame(predQuantile) colnames(predQuantile) <- paste("quantile.",p,sep="") - return(addAttrToGeom(predLocs, predQuantile, match.ID=FALSE)) + return(addAttrToGeom(predST, predQuantile, match.ID=FALSE)) } } -stCopPredict <- function(data, stVine, margin, method="quantile", p=0.5, ...) { - stopifnot(is.list(data)) - stopifnot(length(data)==3) +stCopPredict <- function(predNeigh, dataST, predST, stVine, margin, method="quantile", p=0.5, ...) { + stopifnot(class(predNeigh) == "stNeighbourhood") + stopifnot(inherits(dataST, "ST")) + stopifnot(inherits(predST, "ST")) + stopifnot(class(stVine) == "stVineCopula") + stopifnot(is.function(margin$q)) switch(method, - quantile=stCopPredict.quantile(data, stVine, margin, p), - expectation=stCopPredict.expectation(data, stVine, margin, ...)) -} - -dropStTree <- function (data, stCop) { - stopifnot(is.list(data)) - stopifnot(length(data) == 2) - - neigh <- data[[1]] - stopifnot(class(neigh) == "stNeighbourhood") - - u0 <- as.matrix(neigh at data) - h0 <- neigh at distances - u1 <- matrix(NA, nrow(u0), ncol(u0)-1) - h1 <- array(dim = c(nrow(u0), ncol(h0)-1, 2)) - cat("[Margin ") - for (i in 1:dim(h0)[2]) { - cat(i, ", ",sep="") - u1[,i] <- dduCopula(u0[, c(1, i + 1)], stCop, h = h0[, i, ]) - if (i < ncol(h0)) { - h1[,i,1] <- apply(neigh at index[, c(1, i + 1), 1], 1, - function(x) spDists(data[[2]]@sp[x, ])[1, 2]) - h1[,i,2] <- apply(neigh at index[, c(1, i + 1), 2], 1, - function(x) diff(x)) - } - } - cat("]\n") - - if (length(neigh at coVar) > 0) - u1[,ncol(u0)-(1:length(neigh at coVar))] <- u0[,ncol(u0) + 1 - (1:length(neigh at coVar))] - - varSplit <- strsplit(neigh at var, "|", fixed = TRUE)[[1]] - cond <- suppressWarnings(as.numeric(varSplit[length(varSplit)])) - - if (is.na(cond)) { - coVar <- paste(neigh at coVar, "|0", sep = "") - cond <- paste(neigh at var, "|0", sep = "") - } - else { - coVar <- neigh at coVar - cond <- paste(neigh at var, cond + 1, sep = "") - } - - return(stNeighbourhood(data = u1, distances = h1, index = neigh at index[, -1, ], - var = cond, coVar = coVar, prediction = neigh at prediction)) + quantile=stCopPredict.quantile(predNeigh, dataST, predST, stVine, margin, p), + expectation=stCopPredict.expectation(predNeigh, dataST, predST, stVine, margin, ...)) } \ No newline at end of file Modified: pkg/man/calcBins.Rd =================================================================== --- pkg/man/calcBins.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/calcBins.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -1,11 +1,8 @@ \name{calcBins} \alias{calcBins} - \alias{calcBins-methods} \alias{calcBins,Spatial-method} \alias{calcBins,STFDF-method} -\alias{calcBins,neighbourhood-method} -\alias{calcBins,stNeighbourhood-method} \title{ A function calculating the spatial/spatio-temporal bins Added: pkg/man/condCovariate.Rd =================================================================== --- pkg/man/condCovariate.Rd (rev 0) +++ pkg/man/condCovariate.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -0,0 +1,45 @@ +\name{condCovariate} +\alias{condCovariate} + +\title{ +Conditioning of a Covariate +} +\description{ +Conditions the covariate on the central location in a \code{\linkS4class{stCoVarVineCopula}}. +} +\usage{ +condCovariate(stNeigh, coVarCop) +} + +\arguments{ + \item{stNeigh}{a spatio-temporal neighbourhood \code{\linkS4class{stNeighbourhood}} with a covariate.} + \item{coVarCop}{a function taking spatial and temporal indices and returning a \code{\linkS4class{copula}} object describing the dependence between variable of interest and covariate at this location in space and time.} +} + +\value{A vector of conditioned data, i.e. covariate|variable of interest} + +\author{ +Benedikt Graeler +} + +\seealso{\code{\linkS4class{stNeighbourhood}}} + +\examples{ +library(sp) +library(spacetime) + +sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) +time <- Sys.time()+60*60*24*c(0,1,2) +data <- data.frame(var=runif(6)) +data$coVar <- invdduCopula(data$var, gumbelCopula(7), runif(6)) + +stData <- STFDF(sp, time, data) +stQuerry <- STF(SpatialPoints(matrix(c(181000,181200,333600,333600),2)), + time[2:3]) + +stNeigh <- getStNeighbours(stData=stData, ST=stQuerry, + spSize=3, t.lags=-(0:1), + var="var", coVar="coVar", prediction=TRUE) + +condCovariate(stNeigh, function(x) gumbelCopula(7)) +} Modified: pkg/man/dropSpTree.Rd =================================================================== --- pkg/man/dropSpTree.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/dropSpTree.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -7,19 +7,16 @@ \description{ A spatial tree is dropped in order to fit the following spatial copula. } -\usage{dropSpTree(neigh, spCop)} +\usage{dropSpTree(neigh, dataLocs, spCop)} \arguments{ - \item{neigh}{ -the current \code{\linkS4class{neighbourhood}} + \item{neigh}{the current \code{\linkS4class{neighbourhood}}} + \item{dataLocs}{the locations of the data already used to generate \code{neigh}} + \item{spCop}{the current spatial copula performing the conditioning} } - \item{spCop}{ -the current spatial copula performing the conditioning -} -} \value{ -A conditioned \code{\linkS4class{neighbourhood}} of dimension 1 less. +A conditioned \code{\linkS4class{neighbourhood}} of dimension 1 smaller than the current one. } \author{ Modified: pkg/man/dropStTree.Rd =================================================================== --- pkg/man/dropStTree.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/dropStTree.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -5,18 +5,15 @@ Drops a spatio-temporal tree } \description{ -A spatio-temporal tree is dropped in order to fit the following copula. +A spatio-temporal tree is dropped in order to fit/evaluate the following copula. } -\usage{dropStTree(neigh, stCop)} +\usage{dropStTree(stNeigh, dataLocs, stCop)} \arguments{ - \item{neigh}{ -the current spatio-temporal \code{\linkS4class{stNeighbourhood}} + \item{stNeigh}{the current spatio-temporal \code{\linkS4class{stNeighbourhood}}} + \item{dataLocs}{the data locations (the same as used for the generation of the spatio-temporal neighbourhood).} + \item{stCop}{the current spatio-temporal copula performing the conditioning} } - \item{stCop}{ -the current spatio-temporal copula performing the conditioning -} -} \value{ A conditioned spatio-temporal \code{\linkS4class{stNeighbourhood}} of dimension 1 less. @@ -27,7 +24,7 @@ } \seealso{ -\code{\linkS4class{stNeighbourhood}} +\code{\linkS4class{stNeighbourhood}} and \code{\link{dropSpTree}} } \keyword{ spatio-temporal } \ No newline at end of file Modified: pkg/man/neighbourhood-class.Rd =================================================================== --- pkg/man/neighbourhood-class.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/neighbourhood-class.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -3,8 +3,8 @@ \docType{class} \alias{neighbourhood-class} \alias{names,neighbourhood-method} -\alias{[[,neighbourhood,ANY,ANY-method} -\alias{[[,neighbourhood,numeric,missing-method} +\alias{[,neighbourhood,numeric,ANY,ANY-method} +\alias{calcBins,neighbourhood-method} \title{Class \code{neighbourhood}} \description{A class representing a local spatial neighbourhood.} @@ -26,7 +26,8 @@ \describe{ \item{names}{\code{signature(x = "neighbourhood")}: provides the variable names of the neighbourhood. } \item{show}{\code{signature(object = "neighbourhood")}: a brief description of the characteristics of the neighbourhood.} - \item{[[}{subsets the selection of neighbourhoods returning a subset of these ("column wise")} + \item{[}{\code{signature(x = "neighbourhood", i = "numeric", j = "missing")}: subsets the selection of neighbourhoods returning a subset of these ("column wise")} + \item{calcBins}{\code{signature(data = "neighbourhood")}: calculates bins from an existing neighbourhood for repeated application of spatio-temporal trees in a spatio-temporal vine copula.} } } \author{ Modified: pkg/man/spCopPredict.Rd =================================================================== --- pkg/man/spCopPredict.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/spCopPredict.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -8,10 +8,13 @@ A spatial vine copula is used to predict values at unobserved locations conditioned on observations of a local neighbourhood. } \usage{ -spCopPredict(predNeigh, spVine, margin, method = "quantile", p = 0.5, ...) +spCopPredict(predNeigh, dataLocs, predLocs, spVine, margin, + method = "quantile", p = 0.5, ...) } \arguments{ \item{predNeigh}{the \code{\linkS4class{neighbourhood}} used for prediction, its slot \code{prediction} must be \code{TRUE}.} + \item{dataLocs}{some \code{\linkS4class{Spatial}} class providing the data for the prediction.} + \item{predLocs}{some \code{\linkS4class{Spatial}} class providing the prediction locations.} \item{spVine}{the spatial vine copula describing the spatial dependence} \item{margin}{the marginal distribution as a list with entries named "d" for the density function (PDF), "q" for the quantile function and "p" for cumulative distribution function (CDF).} \item{method}{one of \code{"quantile"} or \code{"expectation"} denoting the type of predictor.} @@ -66,7 +69,7 @@ qlnorm(x,mean(log(meuse$zinc)),sd(log(meuse$zinc))) } -predMedian <- spCopPredict(list(predMeuseNeigh, dataLocs, predLocs), +predMedian <- spCopPredict(predMeuseNeigh, dataLocs, predLocs, spVineCop, list(q=qMar), "quantile", p=0.5) \dontrun{ Modified: pkg/man/spGaussLogLik.Rd =================================================================== --- pkg/man/spGaussLogLik.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/spGaussLogLik.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -2,28 +2,23 @@ \alias{spGaussLogLik} \title{ -Density evalaution for a spatial Gaussian Copula +Density evaluation for a spatial Gaussian Copula } \description{ Evaluates the density for a spatial Gaussian Copula. } \usage{ -spGaussLogLik(corFun, neigh, log = T) +spGaussLogLik(corFun, neigh, dataLocs, log = T) } \arguments{ - \item{corFun}{ -A valid correlogram (i.e. producing a valid correlation matrix; e.g. based on a variogram). + \item{corFun}{A valid correlogram (i.e. producing a valid correlation matrix; e.g. based on a variogram).} + \item{neigh}{A \code{\linkS4class{neighbourhood}} object to be evaluated.} + \item{dataLocs}{The same \code{\linkS4class{Spatial}} object used to generate \code{neigh}.} + \item{log}{Should the log-likelihood be returned?} } - \item{neigh}{ -A \code{\linkS4class{neighbourhood}} object to be evaluated. -} - \item{log}{ -Should the log-likelihood be returned? -} -} \details{ -Evaluates the density for all neioghbourhoods in \code{neigh} and returns the (log)-likelihood. +Evaluates the density for all neighbourhoods in \code{neigh} and returns the (log)-likelihood. } \value{ The (log)-likelihood value. Modified: pkg/man/stCopPredict.Rd =================================================================== --- pkg/man/stCopPredict.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/stCopPredict.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -2,16 +2,18 @@ \alias{stCopPredict} \title{ -spatio-temporal prediction based on a spatio-temporal vine copula +Spatio-Temporal Prediction based on a Spatio-Temporal Vine Copula } \description{ A spatio-temporal vine copula is used to predict values at unobserved spatio-temporal locations conditioned on observations of a local spatio-temporal neighbourhood. } \usage{ -stCopPredict(predNeigh, stVine, margin, method = "quantile", p = 0.5, ...) +stCopPredict(predNeigh, dataST, predST, stVine, margin, method = "quantile", p = 0.5, ...) } \arguments{ \item{predNeigh}{the \code{\linkS4class{neighbourhood}} used for prediction, its slot \code{prediction} must be \code{TRUE}.} + \item{dataST}{the same \code{\linkS4class{ST}} object as used in the generation of \code{predNeigh} providing the data for interpolation.} + \item{predST}{the same \code{\linkS4class{ST}} object as used in the generation of \code{predNeigh} providing the prediction locations for interpolation.} \item{stVine}{the spatio-temporal vine copula describing the spatio-temporal dependence} \item{margin}{the marginal distribution as a list with entries named "d" for the density function (PDF), "q" for the quantile function and "p" for cumulative distribution function (CDF).} \item{method}{one of \code{"quantile"} or \code{"expectation"} denoting the type of predictor.} @@ -62,7 +64,7 @@ stNeigh <- getStNeighbours(stData=stData, ST=stQuerry, prediction=TRUE, spSize=3, t.lags=-(0:1)) -stCopPredict(list(stNeigh, stData, stQuerry), stVineCop, list(q=qunif), "quantile", 0.5) +stCopPredict(stNeigh, stData, stQuerry, stVineCop, list(q=qunif), "quantile", 0.5) } \keyword{ distribution } Modified: pkg/man/stNeighbourhood-class.Rd =================================================================== --- pkg/man/stNeighbourhood-class.Rd 2014-02-13 20:05:42 UTC (rev 124) +++ pkg/man/stNeighbourhood-class.Rd 2014-02-14 10:34:29 UTC (rev 125) @@ -2,27 +2,39 @@ \Rdversion{1.1} \docType{class} \alias{stNeighbourhood-class} +\alias{[,stNeighbourhood,numeric,ANY,ANY-method} +\alias{names,stNeighbourhood-method} +\alias{show,stNeighbourhood-method} + \title{Class \code{"stNeighbourhood"}} \description{ An object representing a set of spatio-temporal neighbourhoods including data, spatio-temporal indices and spatio-temporal distances. } + \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("stNeighbourhood", ...)} or through the simplified call to \code{\link{getStNeighbours}}. } + \section{Slots}{ \describe{ \item{\code{data}:}{Object of class \code{"data.frame"} holding the data of spatio-temporal neighbourhoods. } - \item{\code{distances}:}{Object of class \code{"array"} with the following three dimensions: number of neighbourhoods, dimension of each neighbourhood, 2 (spatial and temporal distance).} - \item{\code{index}:}{Object of class \code{"array"} with the following three dimensions: number of neighbourhoods, dimension of each neighbourhood, 2 (spatial and temporal index). } + \item{\code{distances}:}{Object of class \code{"array"} with the following three dimensions: number of spatio-temporal neighbourhoods, size of each spatio-temporal neighbourhood, 2 (spatial and temporal distance).} + \item{\code{index}:}{Object of class \code{"array"} with the following three dimensions: number of spatio-temporal neighbourhoods, size of each spatio-temporal neighbourhood, 2 (spatial and temporal index). } \item{\code{var}:}{Object of class \code{"character"}; the name of the variable that is estimated.} \item{\code{coVar}:}{Object of class \code{"character"}; the name of the covariate.} \item{\code{prediction}:}{Object of class \code{"logical"} whether prediction or fitting takes place. } } } + \section{Methods}{ -No methods defined with class "stNeighbourhood" in the signature. + \describe{ + \item{[[}{\code{signature(x = "neighbourhood", i = "numeric", j = "missing")}: select distinct rows from the neighbourhood slots.} + \item{names}{\code{signature(x = "neighbourhood")}: retrieve the names of the data slot.} + \item{show}{\code{signature(object = "neighbourhood")}: print some useful information. } + } } + \author{ Benedikt Graeler } From noreply at r-forge.r-project.org Mon Feb 17 16:46:16 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 17 Feb 2014 16:46:16 +0100 (CET) Subject: [spcopula-commits] r126 - in pkg: . R man Message-ID: <20140217154616.BD4DF186819@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-17 16:46:15 +0100 (Mon, 17 Feb 2014) New Revision: 126 Modified: pkg/DESCRIPTION pkg/R/spatio-temporalPreparation.R pkg/man/reduceNeighbours.Rd Log: - improvement of reduceNeighbours for prediction neighbourhoods Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-02-14 10:34:29 UTC (rev 125) +++ pkg/DESCRIPTION 2014-02-17 15:46:15 UTC (rev 126) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-02-14 +Date: 2014-02-17 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2014-02-14 10:34:29 UTC (rev 125) +++ pkg/R/spatio-temporalPreparation.R 2014-02-17 15:46:15 UTC (rev 126) @@ -160,23 +160,31 @@ ## reduction of a larger neigbopurhood based on correlation strengths -reduceNeighbours <- function(stNeigh, stDepFun, n) { +reduceNeighbours <- function(stNeigh, stDepFun, n, + prediction=stNeigh at prediction, dropEmpty=!prediction) { stopifnot(n>0) # transform distances into correlations to detect the strongest correlated ones dimStNeigh <- dim(stNeigh at distances) corMat <- matrix(NA, dimStNeigh[1], dimStNeigh[2]) - pb <- txtProgressBar(0, dimStNeigh[2], style=3) + pb <- txtProgressBar(0, 2*dimStNeigh[1], style=3) for (i in 1:dimStNeigh[2]) { - boolNA <- is.na(stNeigh at data[[1]]) | is.na(stNeigh at data[[1+i]]) + # whether neighbours are missing: set distance to NA + if (prediction) # central location is not part of the data + boolNA <- is.na(stNeigh at data[[i]]) + else { + if(dropEmpty) # neighbourrhoods with missing central location are not to be considered + boolNA <- is.na(stNeigh at data[[1]]) | is.na(stNeigh at data[[1+i]]) + else # do not care about NA at the central location (e.g. cross-validation) + boolNA <- is.na(stNeigh at data[[1+i]]) + } stNeigh at distances[boolNA,i,] <- c(NA,NA) tLag <- -1*stNeigh at distances[!boolNA,i,2][1]+1 corMat[!boolNA,i] <- stDepFun(stNeigh at distances[!boolNA,i,1], tLag) - setTxtProgressBar(pb, i) + setTxtProgressBar(pb, i*dimStNeigh[1]/dimStNeigh[2]) } - close(pb) - + highCorMat <- t(apply(corMat, 1, function(x) order(x, na.last=TRUE, decreasing=TRUE)[1:n])) nrCM <- nrow(highCorMat) @@ -185,23 +193,36 @@ stNeighIndeRed <- array(NA, dim=c(nrCM, n+1, 2)) if (length(stNeigh at coVar) > 0) { for (i in 1:nrCM) { - selCol <- c(1,highCorMat[i,]+1, ncol(stNeigh at data)-((length(stNeigh at coVar)-1):0)) + if (prediction) + selCol <- c(highCorMat[i,], ncol(stNeigh at data)-((length(stNeigh at coVar)-1):0)) + else + selCol <- c(1,highCorMat[i,]+1, ncol(stNeigh at data)-((length(stNeigh at coVar)-1):0)) stNeighDataRed[i,] <- as.numeric(stNeigh at data[i,selCol]) stNeighDistRed[i,,] <- stNeigh at distances[i,highCorMat[i,],] stNeighIndeRed[i,,] <- stNeigh at index[i,c(1,highCorMat[i,]+1),] + setTxtProgressBar(pb, dimStNeigh[1]+i) } } else { for (i in 1:nrCM) { - stNeighDataRed[i,] <- as.numeric(stNeigh at data[i,c(1,highCorMat[i,]+1)]) + if (prediction) + selCol <- c(highCorMat[i,]) + else + selCol <- c(1,highCorMat[i,]+1) + stNeighDataRed[i,] <- as.numeric(stNeigh at data[i, selCol]) stNeighDistRed[i,,] <- stNeigh at distances[i,highCorMat[i,],] stNeighIndeRed[i,,] <- stNeigh at index[i,c(1,highCorMat[i,]+1),] + setTxtProgressBar(pb, dimStNeigh[1]+i) } } + close(pb) - boolNA <- !is.na(stNeigh at data[[1]]) - stNeighDataRed <- stNeighDataRed[boolNA,] - stNeighDistRed <- stNeighDistRed[boolNA,,] - stNeighIndeRed <- stNeighIndeRed[boolNA,,] + # check whether neighbourhoods with missing central locations need to be dropped + if (dropEmpty) { + boolNA <- !is.na(stNeigh at data[[1]]) + stNeighDataRed <- stNeighDataRed[boolNA,] + stNeighDistRed <- stNeighDistRed[boolNA,,] + stNeighIndeRed <- stNeighIndeRed[boolNA,,] + } return(stNeighbourhood(stNeighDataRed, stNeighDistRed, stNeighIndeRed, var=stNeigh at var, coVar=stNeigh at coVar, Modified: pkg/man/reduceNeighbours.Rd =================================================================== --- pkg/man/reduceNeighbours.Rd 2014-02-14 10:34:29 UTC (rev 125) +++ pkg/man/reduceNeighbours.Rd 2014-02-17 15:46:15 UTC (rev 126) @@ -8,7 +8,8 @@ A function selecting the strongest correlated neighbours from a larger set of neighbours } \usage{ -reduceNeighbours(stNeigh, stDepFun, n) +reduceNeighbours(stNeigh, stDepFun, n, + prediction=stNeigh at prediction, dropEmpty=!prediction) } \arguments{ @@ -18,10 +19,10 @@ \item{stDepFun}{ a spatio-temporal dependence function that return correlation estimates based on a spatial and temporal distance } - \item{n}{ -the number of neighbours to be selected. + \item{n}{the number of neighbours to be selected.} + \item{prediction}{whether the neighbourhood is used for prediction (the data slot does not provide the central location's data)} + \item{dropEmpty}{whether empty neighbourhoods (i.e. neighbourhoods with \code{NA}'s at the central location) shall be dropped.} } -} \value{A spatio-temporal neighbourhood \code{\linkS4class{stNeighbourhood}} with fewer neighbours.} \author{ From noreply at r-forge.r-project.org Wed Feb 19 20:33:05 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 19 Feb 2014 20:33:05 +0100 (CET) Subject: [spcopula-commits] r127 - in pkg: . R data demo man Message-ID: <20140219193305.35A88186BB4@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-19 20:32:57 +0100 (Wed, 19 Feb 2014) New Revision: 127 Modified: pkg/NAMESPACE pkg/R/Classes.R pkg/R/spCopula.R pkg/R/spatialPreparation.R pkg/R/spatio-temporalPreparation.R pkg/R/stCopula.R pkg/data/spCopDemo.RData pkg/demo/spCopula.R pkg/man/calcBins.Rd pkg/man/condCovariate.Rd pkg/man/condStCoVarVine.Rd pkg/man/condStVine.Rd pkg/man/fitCorFun.Rd pkg/man/fitSpCopula.Rd pkg/man/getStNeighbours.Rd pkg/man/loglikByCopulasLags.Rd pkg/man/reduceNeighbours.Rd pkg/man/spCopDemo.Rd pkg/man/stCoVarVineCopula.Rd pkg/man/stCopPredict.Rd pkg/man/stCopula-class.Rd pkg/man/stCopula.Rd pkg/man/stNeighbourhood.Rd pkg/man/stVineCopula.Rd Log: - redesign of spatial and spatio-temporal bins (i.e. dropping the lagData entry) - renaming of arguments from t.lags to tlags and slots t.res to tres Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/NAMESPACE 2014-02-19 19:32:57 UTC (rev 127) @@ -32,7 +32,7 @@ export(reduceNeighbours) # fitting -export(fitCorFun, loglikByCopulasLags, fitSpCopula, composeSpCopula) +export(fitCorFun, loglikByCopulasLags, loglikByCopulasStLags, fitSpCopula, composeSpCopula) export(tailDepFun, lowerTailDepFun, upperTailDepFun) export(empTailDepFun, lowerEmpTailDepFun, upperEmpTailDepFun) Modified: pkg/R/Classes.R =================================================================== --- pkg/R/Classes.R 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/R/Classes.R 2014-02-19 19:32:57 UTC (rev 127) @@ -163,14 +163,14 @@ ############################ validStCopula <- function(object) { - if(length(object at t.lags) != length(object at spCopList)) return("The length of the temporal distance vector must equal the number of spatial copulas.") + if(length(object at tlags) != length(object at spCopList)) return("The length of the temporal distance vector must equal the number of spatial copulas.") return(TRUE) # validity of any spCopula in spCopList is tested by the constructor, I believe } setClass("stCopula", representation = representation("copula", spCopList="list", - t.lags="numeric", - t.res="character"), + tlags="numeric", + tres="character"), validity = validStCopula, contains = list("copula")) ############################################### Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/R/spCopula.R 2014-02-19 19:32:57 UTC (rev 127) @@ -448,7 +448,7 @@ } } -fitCorFun <- function(bins, degree=3, cutoff=NA, bounds=c(0,1), +fitCorFun <- function(bins, degree=3, cutoff=NA, tlags, bounds=c(0,1), cor.method=NULL, weighted=FALSE){ if(is.null(cor.method)) { if(is.null(attr(bins,"cor.method"))) @@ -460,9 +460,10 @@ stop("The cor.method attribute of the bins argument and the argument cor.method do not match.") } - if(is.null(nrow(bins$lagCor))) + if(is.null(nrow(bins$lagCor))) # the spatial case return(fitCorFunSng(bins, degree, cutoff, bounds, cor.method, weighted)) - + + # the spatio-temporal case degree <- rep(degree,length.out=nrow(bins$lagCor)) calcKTau <- list() for(j in 1:nrow(bins$lagCor)) { @@ -471,14 +472,21 @@ degree[j], cutoff, bounds, cor.method, weighted) } - return(calcKTau) + + corFun <- function(h, time, tlags=sort(tlags,decreasing=TRUE)) { + t <- which(tlags==time) + calcKTau[[time]](h) + } + + attr(corFun, "tlags") <- sort(tlags, decreasing=TRUE) + return(corFun) } # towards b) ## loglikelihoods for a dynamic spatial copula -loglikByCopulasLags.dyn <- function(bins, families, calcCor) { +loglikByCopulasLags.dyn <- function(bins, lagData, families, calcCor) { moa <- switch(calcCor(NULL), kendall=function(copula, h) iTau(copula, calcCor(h)), spearman=function(copula, h) iRho(copula, calcCor(h)), @@ -496,18 +504,18 @@ if(class(cop)!="indepCopula") { if(class(cop) == "asCopula") { cop <- switch(calcCor(NULL), - kendall=fitASC2.itau(cop, bins$lagData[[i]], + kendall=fitASC2.itau(cop, lagData[[i]], tau=calcCor(bins$meanDists[i]))@copula, - spearman=fitASC2.irho(cop, bins$lagData[[i]], + spearman=fitASC2.irho(cop, lagData[[i]], rho=calcCor(bins$meanDists[i]))@copula, stop(paste(calcCor(NULL), "is not yet supported."))) param <- cop at parameters } else { if(class(cop) == "cqsCopula") { cop <- switch(calcCor(NULL), - kendall=fitCQSec.itau(cop, bins$lagData[[i]], + kendall=fitCQSec.itau(cop, lagData[[i]], tau=calcCor(bins$meanDists[i]))@copula, - spearman=fitCQSec.irho(cop, bins$lagData[[i]], + spearman=fitCQSec.irho(cop, lagData[[i]], rho=calcCor(bins$meanDists[i]))@copula, stop(paste(calcCor(NULL), "is not yet supported."))) param <- cop at parameters @@ -522,7 +530,7 @@ if(any(is.na(param))) tmploglik <- c(tmploglik, NA) else - tmploglik <- c(tmploglik, sum(dCopula(bins$lagData[[i]], cop, log=T))) + tmploglik <- c(tmploglik, sum(dCopula(lagData[[i]], cop, log=T))) tmpCop <- append(tmpCop, cop) setTxtProgressBar(pb, i) } @@ -537,12 +545,12 @@ } ## loglikelihoods for a static spatial copula -loglikByCopulasLags.static <- function(bins, families) { +loglikByCopulasLags.static <- function(lagData, families) { fits <-lapply(families, function(cop) { cat(cop at fullname,"\n") - lapply(bins$lagData, + lapply(lagData, function(x) { tryCatch(fitCopula(cop, x, estimate.variance = FALSE), error=function(e) return(NA)) @@ -571,28 +579,36 @@ return(list(loglik=loglik, copulas=copulas)) } -# bins -> typically output from calcBins -# calcTau -> a function on distance providing Kendall's tau estimates, -# families -> a vector of dummy copula objects of each family to be considered -# DEFAULT: c(normal, t_df=4, clayton, frank, gumbel -loglikByCopulasLags <- function(bins, families=c(normalCopula(0), - tCopula(0,dispstr="un"), - claytonCopula(0), frankCopula(1), - gumbelCopula(1)), - calcCor) { - bins$lagData <- lapply(bins$lagData, - function(pairs) { - bool <- !is.na(pairs[,1]) & !is.na(pairs[,2]) - pairs[bool,] - }) +## + +loglikByCopulasLags <- function(bins, data, families=c(normalCopula(), + tCopula(), + claytonCopula(), frankCopula(), + gumbelCopula()), + calcCor, lagSub=1:length(bins$meanDists)) { + var <- attr(bins, "variable") + lagData <- lapply(bins$lags[lagSub], + function(x) { + as.matrix((cbind(data[x[,1], var]@data, + data[x[,2], var]@data))) + }) + + lagData <- lapply(lagData, + function(pairs) { + bool <- !is.na(pairs[,1]) & !is.na(pairs[,2]) + pairs[bool,] + }) + if(missing(calcCor)) - return(loglikByCopulasLags.static(bins, families)) + return(loglikByCopulasLags.static(lagData, families)) else - return(loglikByCopulasLags.dyn(bins, families, calcCor)) + return(loglikByCopulasLags.dyn(lapply(bins, function(x) x[lagSub]), + lagData, families, calcCor)) } + # towards d) composeSpCopula <- function(bestFit, families, bins, calcCor, range=max(bins$meanDists)) { nFits <- length(bestFit) @@ -626,12 +642,12 @@ # degree -> the degree of the polynominal # bounds -> the bounds of the correlation function (typically c(0,1)) # method -> the measure of association, either "kendall" or "spearman" -fitSpCopula <- function(bins, cutoff=NA, +fitSpCopula <- function(bins, data, cutoff=NA, families=c(normalCopula(), tCopula(), claytonCopula(), frankCopula(), gumbelCopula()), ...) { calcCor <- fitCorFun(bins, cutoff=cutoff, ...) - loglik <- loglikByCopulasLags(bins, families, calcCor) + loglik <- loglikByCopulasLags(bins, data, families, calcCor) bestFit <- apply(apply(loglik$loglik, 1, rank),2, function(x) which(x==length(families))) Modified: pkg/R/spatialPreparation.R =================================================================== --- pkg/R/spatialPreparation.R 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/R/spatialPreparation.R 2014-02-19 19:32:57 UTC (rev 127) @@ -168,8 +168,10 @@ abline(h=c(-min(lagCor),0,min(lagCor)),col="grey") } - res <- list(np=np, meanDists = mDists, lagCor=lagCor, lagData=lagData, lags=lags) +# res <- list(np=np, meanDists = mDists, lagCor=lagCor, lagData=lagData, lags=lags) + res <- list(np=np, meanDists = mDists, lagCor=lagCor, lags=lags) attr(res,"cor.method") <- cor.method + attr(res,"variable") <- var return(res) } @@ -177,7 +179,7 @@ # calc bins from a (conditional) neighbourhood -calcNeighBins <- function(data, var=names(data), nbins=9, boundaries=NA, +calcNeighBins <- function(data, var=data at var, nbins=9, boundaries=NA, cutoff=NA, cor.method="kendall", plot=TRUE) { dists <- data at distances @@ -199,7 +201,6 @@ np <- numeric(nbins) moa <- numeric(nbins) meanDists <- numeric(nbins) - lagData <- NULL data <- as.matrix(data at data) @@ -211,7 +212,7 @@ pairs <- rbind(pairs, data[bools[,col],c(1,1+col)]) } - lagData <- append(lagData, list(pairs)) +# lagData <- append(lagData, list(pairs)) moa[i] <- corFun(pairs) meanDists[i] <- mean(dists[bools]) np[i] <- sum(bools) @@ -223,8 +224,11 @@ abline(h=c(-min(moa),0,min(moa)),col="grey") } - res <- list(np=np, meanDists = meanDists, lagCor=moa, lagData=lagData) +# res <- list(np=np, meanDists = meanDists, lagCor=moa, lagData=lagData) + res <- list(np=np, meanDists = meanDists, lagCor=moa) attr(res,"cor.method") <- switch(cor.method, fasttau="kendall", cor.method) + attr(res,"variable") <- var + return(res) } Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/R/spatio-temporalPreparation.R 2014-02-19 19:32:57 UTC (rev 127) @@ -63,13 +63,13 @@ # returns an neighbourhood object ################################## -getStNeighbours <- function(stData, ST, spSize=4, t.lags=-(0:2), +getStNeighbours <- function(stData, ST, spSize=4, tlags=-(0:2), var=names(stData at data)[1], coVar=character(), timeSteps=NA, prediction=FALSE, min.dist=0.01) { stopifnot((!prediction && missing(ST)) || (prediction && !missing(ST))) stopifnot(min.dist>0 || prediction) - timeSpan <- min(t.lags) + timeSpan <- min(tlags) if(missing(ST) && !prediction) ST=geometry(stData) @@ -101,7 +101,7 @@ timeSteps <- length(stData at time)+timeSpan } - nStNeighs <- (spSize-1)*length(t.lags) + nStNeighs <- (spSize-1)*length(tlags) stNeighData <- matrix(NA, nLocs, nStNeighs + 1 + length(coVar)) stDists <- array(NA,c(nLocs, nStNeighs, 2)) @@ -126,8 +126,8 @@ tmpInd <- matrix(rep(timeInst, spSize), ncol=spSize) - for (j in 2:length(t.lags)) { - t <- t.lags[j] + for (j in 2:length(tlags)) { + t <- tlags[j] stNeighData[spInd, (j-1)*(spSize-1)+2:(spSize)] <- matrix(stData[nghbrs at index[i,][-1], timeInst+t, var, drop=F]@data[[1]], ncol=spSize-1, byrow=T) @@ -135,15 +135,15 @@ } # store spatial distances - stDists[spInd,,1] <- matrix(rep(nghbrs at distances[i,], timeSteps*length(t.lags)), + stDists[spInd,,1] <- matrix(rep(nghbrs at distances[i,], timeSteps*length(tlags)), byrow=T, ncol=nStNeighs) # store temporal distances - stDists[spInd,,2] <- matrix(rep(rep(t.lags,each=spSize-1), timeSteps), + stDists[spInd,,2] <- matrix(rep(rep(tlags,each=spSize-1), timeSteps), byrow=T, ncol=nStNeighs) # store space indices - stInd[spInd,,1] <- matrix(rep(c(nghbrs at index[i, ], rep(nghbrs at index[i, -1], length(t.lags)-1)), + stInd[spInd,,1] <- matrix(rep(c(nghbrs at index[i, ], rep(nghbrs at index[i, -1], length(tlags)-1)), timeSteps), ncol = nStNeighs + 1, byrow = T) # store time indices @@ -230,7 +230,7 @@ } ## to be redone -# calcStNeighBins <- function(data, var="uniPM10", nbins=9, t.lags=-(0:2), +# calcStNeighBins <- function(data, var="uniPM10", nbins=9, tlags=-(0:2), # boundaries=NA, cutoff=NA, cor.method="fasttau") { # dists <- data at distances[,,1] # @@ -248,8 +248,8 @@ # } # # lagData <- NULL -# for(t.lag in t.lags) { # t.lag <- 0 -# tBool <- data at distances[,,2]==t.lag +# for(tlag in tlags) { # tlag <- 0 +# tBool <- data at distances[,,2]==tlag # tmpLagData <- NULL # for(i in 1:nbins) { # i <- 1 # sBool <- (dists <= boundaries[i + 1] & dists > boundaries[i]) @@ -341,10 +341,10 @@ # instances: number -> number of randomly choosen temporal intances # NA -> all observations -# other -> temporal indexing as in spacetime/xts, the parameter t.lags is set to 0 in this case. -# t.lags: numeric -> temporal shifts between obs +# other -> temporal indexing as in spacetime/xts, the parameter tlags is set to 0 in this case. +# tlags: numeric -> temporal shifts between obs calcStBins <- function(data, var, nbins=15, boundaries=NA, cutoff=NA, - instances=NA, t.lags=-(0:2), ..., + instances=NA, tlags=-(0:2), ..., cor.method="fasttau", plot=FALSE) { if(is.na(cutoff)) cutoff <- spDists(coordinates(t(data at sp@bbox)))[1,2]/3 @@ -363,11 +363,14 @@ } else { tempIndices <- NULL - for (t.lag in rev(t.lags)) { - # smplInd <- max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)) - smplInd <- sample(x=max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)), - size=min(instances,lengthTime-max(abs(t.lags)))) - tempIndices <- cbind(smplInd+t.lag, tempIndices) + for (tlag in rev(tlags)) { + if(is.na(instances)) + smplInd <- max(1,1-min(tlags)):min(lengthTime,lengthTime-min(tlags)) + else + smplInd <- sort(sample(x=max(1,1-min(tlags)):min(lengthTime,lengthTime-min(tlags)), + size=min(instances,lengthTime-max(abs(tlags))))) + + tempIndices <- cbind(smplInd+tlag, tempIndices) tempIndices <- cbind(smplInd, tempIndices) } } @@ -412,8 +415,10 @@ abline(h=c(-min(lagCor),0,min(lagCor)),col="grey") } - res <- list(meanDists = mDists, lagCor=lagCor, lagData=lagData, lags=list(sp=spIndices, time=tempIndices)) + # res <- list(meanDists = mDists, lagCor=lagCor, lagData=lagData, lags=list(sp=spIndices, time=tempIndices)) + res <- list(meanDists = mDists, lagCor=lagCor, lags=list(sp=spIndices, time=tempIndices)) attr(res,"cor.method") <- cor.method + attr(res, "variable") <- var return(res) } Modified: pkg/R/stCopula.R =================================================================== --- pkg/R/stCopula.R 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/R/stCopula.R 2014-02-19 19:32:57 UTC (rev 127) @@ -5,23 +5,23 @@ ## constructor ## ################# -stCopula <- function(components, t.lags, distances=NA, stDepFun, unit="m", t.res="day") { +stCopula <- function(components, tlags, distances=NA, stDepFun, unit="m", tres="day") { if(all(sapply(components, function(x) class(x)=="spCopula"))) { if(length(unique(sapply(components, function(x) x at unit))) >1 ) stop("All spatial copulas need to have the same distance unit.") - stopifnot(length(t.lags) == length(components)) + stopifnot(length(tlags) == length(components)) spCopList <- components } else { spCopList <- list() if(!missing(stDepFun)) { getSpCop <- function(comp,dist,time) spCopula(comp, dist, - spDepFun=function(h) stDepFun(h,time), unit) - for(i in 1:length(t.lags)){ + spDepFun=function(h) stDepFun(h, time, 1:length(tlags)), unit) + for(i in 1:length(tlags)){ spCopList <- append(spCopList, getSpCop(components[[i]], distances[[i]], i)) } } else { - for(i in 1:length(t.lags)){ + for(i in 1:length(tlags)){ spCopList <- append(spCopList, spCopula(components[[i]], distances[[i]], unit=unit)) } } @@ -35,7 +35,7 @@ new("stCopula", dimension=as.integer(2), parameters=param, param.names=param.names, param.lowbnd=param.low, param.upbnd=param.up, fullname="Spatio-Temporal Copula: distance and time dependent convex combination of bivariate copulas", - spCopList=spCopList, t.lags=t.lags, t.res=t.res) + spCopList=spCopList, tlags=tlags, tres=tres) } ## show method ## @@ -47,8 +47,8 @@ cat("Copulas:\n") for (i in 1:length(object at spCopList)) { cmpCop <- object at spCopList[[i]] - cat(" ", cmpCop at fullname, "at", object at t.lags[i], - paste("[",object at t.res,"]",sep=""), "\n") + cat(" ", cmpCop at fullname, "at", object at tlags[i], + paste("[",object at tres,"]",sep=""), "\n") show(cmpCop) } } @@ -65,16 +65,16 @@ n <- nrow(u) tDist <- unique(h[,2]) - if(any(is.na(match(tDist,copula at t.lags)))) + if(any(is.na(match(tDist,copula at tlags)))) stop("Prediction time(s) do(es) not math the modelled time slices.") if (length(tDist)==1) { - res <- pSpCopula(u, copula at spCopList[[match(tDist, copula at t.lags)]], h[,1]) + res <- pSpCopula(u, copula at spCopList[[match(tDist, copula at tlags)]], h[,1]) } else { res <- numeric(n) for(t in tDist) { tmpInd <- h[,2]==t - tmpCop <- copula at spCopList[[match(t, copula at t.lags)]] + tmpCop <- copula at spCopList[[match(t, copula at tlags)]] res[tmpInd] <- pSpCopula(u[tmpInd,,drop=F], tmpCop, h[tmpInd,1]) } } @@ -95,16 +95,16 @@ n <- nrow(u) tDist <- unique(h[,2]) - if(any(is.na(match(tDist,copula at t.lags)))) + if(any(is.na(match(tDist,copula at tlags)))) stop("Prediction time(s) do(es) not math the modelled time slices.") if (length(tDist)==1) { - res <- dSpCopula(u, copula at spCopList[[match(tDist, copula at t.lags)]], log, h[,1]) + res <- dSpCopula(u, copula at spCopList[[match(tDist, copula at tlags)]], log, h[,1]) } else { res <- numeric(n) for(t in tDist) { tmpInd <- h[,2]==t - tmpCop <- copula at spCopList[[match(t, copula at t.lags)]] + tmpCop <- copula at spCopList[[match(t, copula at tlags)]] res[tmpInd] <- dSpCopula(u[tmpInd,,drop=F], tmpCop, log, h[tmpInd,1]) } } @@ -128,16 +128,16 @@ n <- nrow(u) tDist <- unique(h[,2]) - if(any(is.na(match(tDist,copula at t.lags)))) + if(any(is.na(match(tDist,copula at tlags)))) stop("Prediction time(s) do(es) not math the modelled time slices.") if (length(tDist)==1) { - res <- dduSpCopula(u, copula at spCopList[[match(tDist, copula at t.lags)]], h[,1]) + res <- dduSpCopula(u, copula at spCopList[[match(tDist, copula at tlags)]], h[,1]) } else { res <- numeric(n) for(t in tDist) { tmpInd <- h[,2]==t - tmpCop <- copula at spCopList[[match(t, copula at t.lags)]] + tmpCop <- copula at spCopList[[match(t, copula at tlags)]] res[tmpInd] <- dduSpCopula(u[tmpInd,,drop=F], tmpCop, h[tmpInd,1]) } } @@ -159,16 +159,16 @@ n <- nrow(u) tDist <- unique(h[,2]) - if(any(is.na(match(tDist,copula at t.lags)))) + if(any(is.na(match(tDist,copula at tlags)))) stop("Prediction time(s) do(es) not math the modelled time slices.") if (length(tDist)==1) { - res <- ddvSpCopula(u, copula at spCopList[[match(tDist,copula at t.lags)]], h[,1]) + res <- ddvSpCopula(u, copula at spCopList[[match(tDist,copula at tlags)]], h[,1]) } else { res <- numeric(n) for(t in tDist) { tmpInd <- h[,2]==t - tmpCop <- copula at spCopList[[match(t, copula at t.lags)]] + tmpCop <- copula at spCopList[[match(t, copula at tlags)]] res[tmpInd] <- ddvSpCopula(u[tmpInd,,drop=F], tmpCop, h[tmpInd,1]) } } @@ -179,7 +179,53 @@ function(u, copula, ...) ddvStCopula(matrix(u,ncol=2), copula, ...)) setMethod("ddvCopula", signature("matrix","stCopula"), ddvStCopula) -# dropping a sptio-temporal tree +# log-likelihood by copula for all spatio-temporal lags + + +loglikByCopulasStLags <- function(stBins, data, families = c(normalCopula(), + tCopula(), + claytonCopula(), + frankCopula(), + gumbelCopula()), + calcCor, lagSub=1:length(stBins$meanDists)) { + nTimeLags <- dim(stBins$lagCor)[1] + var <- attr(stBins, "variable") + + retrieveData <- function(spIndex, tempIndices) { + binnedData <- NULL + for (i in 1:(ncol(tempIndices)/2)) { + binnedData <- cbind(binnedData, + as.matrix((cbind(data[spIndex[,1], tempIndices[,2*i-1], var]@data, + data[spIndex[,2], tempIndices[,2*i], var]@data)))) + } + return(binnedData) + } + + lagData <- lapply(stBins$lags[[1]][lagSub], retrieveData, tempIndices=stBins$lags[[2]]) + + tmpBins <- list(meanDists=stBins$meanDists[lagSub]) + attr(tmpBins, "variable") <- var + + loglikTau <- list() + for(j in 1:nTimeLags) { + tmpLagData <- lapply(lagData, function(x) x[,c(2*j-1,2*j)]) + tmpLagData <- lapply(tmpLagData, function(pairs) { + bool <- !is.na(pairs[,1]) & !is.na(pairs[,2]) + pairs[bool,] + }) + + if(missing(calcCor)) + res <- loglikByCopulasLags.static(tmpLagData, families) + else + res <- loglikByCopulasLags.dyn(tmpBins, tmpLagData, families, + function(h) calcCor(h, j, 1:nTimeLags)) + loglikTau[[paste("loglik",j,sep="")]] <- res + } + + return(loglikTau) +} + +# dropping a spatio-temporal tree dropStTree <- function (stNeigh, dataLocs, stCop) { stopifnot(class(stNeigh) == "stNeighbourhood") Modified: pkg/data/spCopDemo.RData =================================================================== (Binary files differ) Modified: pkg/demo/spCopula.R =================================================================== --- pkg/demo/spCopula.R 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/demo/spCopula.R 2014-02-19 19:32:57 UTC (rev 127) @@ -26,7 +26,7 @@ meuse$marZinc <- pMar(meuse$zinc) ## lag classes ## -bins <- calcBins(meuse,var="marZinc",nbins=10,cutoff=800) +bins <- calcBins(meuse, var="marZinc", nbins=10, cutoff=800) ## calculate parameters for Kendall's tau function ## # either linear @@ -38,7 +38,7 @@ curve(calcKTauPol,0, 1000, col="purple",add=TRUE) ## find best fitting copula per lag class -loglikTau <- loglikByCopulasLags(bins, calcKTauPol, +loglikTau <- loglikByCopulasLags(bins, meuse, calcKTauPol, families=c(normalCopula(0), tCopula(0), claytonCopula(0), frankCopula(1), gumbelCopula(1), joeBiCopula(1.5), @@ -57,11 +57,16 @@ spDepFun=calcKTauPol, unit="m") ## compare spatial copula loglik by lag: +lagData <- lapply(bins$lags, function(x) { + as.matrix((cbind(meuse[x[,1], "marZinc"]@data, + meuse[x[,2], "marZinc"]@data))) + }) + spLoglik <- NULL for(i in 1:length(bins$lags)) { # i <- 7 cat("Lag",i,"\n") spLoglik <- c(spLoglik, - sum((dCopula(u=bins$lagData[[i]], spCop,log=T, + sum((dCopula(u=lagData[[i]], spCop,log=T, h=bins$lags[[i]][,3])))) } @@ -71,7 +76,7 @@ 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)) +text(x=(1:10+0.5), y=spLoglik, lapply(lagData,length)) ## # spatial vine Modified: pkg/man/calcBins.Rd =================================================================== --- pkg/man/calcBins.Rd 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/man/calcBins.Rd 2014-02-19 19:32:57 UTC (rev 127) @@ -34,7 +34,7 @@ \item{\dots}{Additional arguments for the spatio-temporal case: \describe{ \item{instances}{To reduce the data size or circumvent unwanted autocorrelation effects, one might provide a number of randomly selected time instances from the spatio-temporal \code{data.frame}. If this parameter is set to \code{NA}, the complete time series will be used, if different from a single number, \code{instances} will be passed on as to index time.} - \item{t.lags}{a vector indicating the time lags to be investigated} + \item{tlags}{a vector indicating the time lags to be investigated} } } \item{cor.method}{ Modified: pkg/man/condCovariate.Rd =================================================================== --- pkg/man/condCovariate.Rd 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/man/condCovariate.Rd 2014-02-19 19:32:57 UTC (rev 127) @@ -38,7 +38,7 @@ time[2:3]) stNeigh <- getStNeighbours(stData=stData, ST=stQuerry, - spSize=3, t.lags=-(0:1), + spSize=3, tlags=-(0:1), var="var", coVar="coVar", prediction=TRUE) condCovariate(stNeigh, function(x) gumbelCopula(7)) Modified: pkg/man/condStCoVarVine.Rd =================================================================== --- pkg/man/condStCoVarVine.Rd 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/man/condStCoVarVine.Rd 2014-02-19 19:32:57 UTC (rev 127) @@ -59,7 +59,7 @@ unit="km") stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), - t.lags=-(0:2)) + tlags=-(0:2)) # only a constant copula ius used for the covariate stCVVC <- stCoVarVineCopula(function(x) gumbelCopula(7), stCop, vineCopula(5L)) Modified: pkg/man/condStVine.Rd =================================================================== --- pkg/man/condStVine.Rd 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/man/condStVine.Rd 2014-02-19 19:32:57 UTC (rev 127) @@ -49,7 +49,7 @@ unit="km") stCop <- stCopula(components=list(spCopT0, spCopT1), - t.lags=-(0:1)) + tlags=-(0:1)) stVineCop <- stVineCopula(stCop, vineCopula(4L)) Modified: pkg/man/fitCorFun.Rd =================================================================== --- pkg/man/fitCorFun.Rd 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/man/fitCorFun.Rd 2014-02-19 19:32:57 UTC (rev 127) @@ -5,44 +5,30 @@ Automated fitting of a correlation function to the correlogram } \description{ -Polynomials of different degrees can be fitted to the correlogram calculated using \code{\link{calcBins}}. This function will be used to adjust the copula parameter in the spatial/spatio-temporal copula. +Polynomials of different degrees can be fitted to the spatial/spatio-temporal correlogram calculated using \code{\link{calcBins}}. This function will be used to adjust the copula parameter in the spatial/spatio-temporal copula. } \usage{ -fitCorFun(bins, degree = 3, cutoff = NA, bounds = c(0, 1), cor.method = NULL, - weighted = FALSE) +fitCorFun(bins, degree = 3, cutoff = NA, tlags, bounds = c(0, 1), + cor.method = NULL, weighted = FALSE) } \arguments{ - \item{bins}{ -Typically the output of \code{\link{calcBins}}. Any \code{data.frame} with a columns \code{lagCor} and \code{meanDists} in the first two columns will do. + \item{bins}{Typically the output of \code{\link{calcBins}}. Any \code{data.frame} with a columns \code{lagCor} and \code{meanDists} in the first two columns will do.} + \item{degree}{The degree of polynomial to be fitted - recycled if needed.} + \item{cutoff}{Maximal distance to which lags should be included in the polynomial fit.} + \item{tlags}{The temporal lags used for the genration of \code{bins}.} + \item{bounds}{Bounds of the correlation values. The default is set [0,1] not allowing any negative relationship but perfect positive dependence.} + \item{cor.method}{The output of \code{\link{calcBins}} has an attribute \code{cor.method}, in case this is not present the parameter \code{cor.method} will be used. In case the parameter \code{cor.method} is not \code{NULL} and the attribute \code{cor.method} is present, they will be compared.} + \item{weighted}{shall the residuals be weighted by the number of points in the lag class?} } - \item{degree}{ -The degree of polynomial to be fitted. -} - \item{cutoff}{ -Maximal distance to which lags should be included in the polynomial fit. -} - \item{bounds}{ -Bounds of the correlation values. The default is set [0,1] not allowing any negative relationship but perfect positive dependence. -} - \item{cor.method}{ -The output of \code{\link{calcBins}} has an attribute \code{cor.method}, in case this is not present the parameter \code{cor.method} will be used. In case the parameter \code{cor.method} is not \code{NULL} and the attribute \code{cor.method} is present, they will be compared. -} - \item{weighted}{ - shall the residulas be weighted by the number of points in the lag class? - } -} -\value{ -Returns a function that provides correlation estimate for every separating distance. -} -\author{ -Benedikt Graeler -} -\seealso{ -See also \code{\link{calcBins}} and \code{\link{spCopula}}. -} +\value{Returns a one/two-place function that provides correlation estimates for every separating spatial/spatio-temporal distance.} + +\author{Benedikt Graeler} + +\seealso{See also \code{\link{calcBins}} and \code{\link{spCopula}}.} + \examples{ -# a simplified bins object (from demo(spcopula_estimation)) +# a simplified bins object (from demo(spcopula)) bins <- list(meanDists=c(64, 128, 203, 281, 361, 442, 522, 602, 681, 760), lagCor=c(0.57, 0.49, 0.32, 0.29, 0.15, 0.14, 0.10, -0.00, 0.03, -0.01)) attr(bins,"cor.method") <- "kendall" Modified: pkg/man/fitSpCopula.Rd =================================================================== --- pkg/man/fitSpCopula.Rd 2014-02-17 15:46:15 UTC (rev 126) +++ pkg/man/fitSpCopula.Rd 2014-02-19 19:32:57 UTC (rev 127) @@ -4,31 +4,26 @@ \title{ Spatial Copula Fitting } + \description{ A bivariate spatial copula is composed out of a set of bivariate copulas. These are combined using a convex linear combination with weights based on distances where for copulas with a 1-1 correspondence of Kendall's tau or Spearman's rho a dependence function providing measures of association based on distances might be used. This function estimates a spatial dependence function, evaluates the log-likelihood per family and lag class, selects the best fits and composes a spatial bivariate copula. } \usage{ -fitSpCopula(bins, cutoff = NA, families = c(normalCopula(), tCopula(), +fitSpCopula(bins, data, cutoff = NA, families = c(normalCopula(), tCopula(), claytonCopula(), frankCopula(), gumbelCopula()), ...) } \arguments{ - \item{bins}{ -the bins to be used, typically output from \code{\link{calcBins}}. + \item{bins}{the bins to be used, typically output from \code{\link{calcBins}}.} + \item{data}{the spatial dataset that ahs been used to generate \code{bins}.} + \item{cutoff}{The maximal distance to be used in the fit.} + \item{families}{The set of families to be investigated.} + \item{\dots}{Passed on to the function \code{\link{fitCorFun}}.} } - \item{cutoff}{ -The maximal distance to be used in the fit. -} - \item{families}{ -The set of families to be investigated. -} - \item{\dots}{ -Passed on to the function \code{\link{fitCorFun}}. -} -} \value{ A \code{\linkS4class{spCopula}} object. } + \references{ Graeler, B. & E. Pebesma (2011): The pair-copula construction for spatial data: a new approach to model spatial dependency. Poster at: Spatial Statistics 2011 - Mapping global change. Enschede, The Netherlands, 23-25 March 2011. @@ -42,9 +37,20 @@ Take a look at \code{\link{fitCorFun}}, \code{\link{loglikByCopulasLags}}, \code{\link{composeSpCopula}} and \code{\linkS4class{spCopula}} to gain more control over the fitting procedure. } [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 127 From noreply at r-forge.r-project.org Fri Feb 21 15:27:50 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 21 Feb 2014 15:27:50 +0100 (CET) Subject: [spcopula-commits] r128 - pkg Message-ID: <20140221142750.89EC5186BFE@r-forge.r-project.org> Author: ben_graeler Date: 2014-02-21 15:27:50 +0100 (Fri, 21 Feb 2014) New Revision: 128 Modified: pkg/DESCRIPTION Log: - re-build on r-forge Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-02-19 19:32:57 UTC (rev 127) +++ pkg/DESCRIPTION 2014-02-21 14:27:50 UTC (rev 128) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-02-17 +Date: 2014-02-21 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb"))