[spcopula-commits] r96 - / pkg pkg/R pkg/demo pkg/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue May 21 10:26:21 CEST 2013
Author: ben_graeler
Date: 2013-05-21 10:26:21 +0200 (Tue, 21 May 2013)
New Revision: 96
Modified:
pkg/DESCRIPTION
pkg/R/spVineCopula.R
pkg/R/spatialPreparation.R
pkg/R/vineCopulas.R
pkg/demo/MRP.R
pkg/demo/spCopula.R
pkg/man/loglikByCopulasLags.Rd
pkg/man/neighbourhood-class.Rd
spcopula_0.1-1.tar.gz
spcopula_0.1-1.zip
Log:
- bug fixes in the spatial copula demo spCopula.R
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/DESCRIPTION 2013-05-21 08:26:21 UTC (rev 96)
@@ -2,13 +2,13 @@
Type: Package
Title: copula driven spatial analysis
Version: 0.1-1
-Date: 2013-05-03
+Date: 2013-05-21
Author: Benedikt Graeler
Maintainer: Benedikt Graeler <ben.graeler at uni-muenster.de>
Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of the spacetime package. Additionally, support for calculating different multivariate return periods is implemented.
License: GPL-2
LazyLoad: yes
-Depends: copula (>= 0.999-5), spacetime (>= 1.0-2), VineCopula, methods, R (>= 2.15.0)
+Depends: copula (>= 0.999-6), spacetime (>= 1.0-2), VineCopula, methods, R (>= 2.15.0)
URL: http://r-forge.r-project.org/projects/spcopula/
Collate:
Classes.R
Modified: pkg/R/spVineCopula.R
===================================================================
--- pkg/R/spVineCopula.R 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/R/spVineCopula.R 2013-05-21 08:26:21 UTC (rev 96)
@@ -238,7 +238,7 @@
xVals <- attr(condSecVine,"xVals")
density <- condSecVine(xVals)
nx <- length(xVals)
- int <- cumsum(c(0,diff(xVals)*(p*diff(density)+density[-nx])))
+ 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]
@@ -268,4 +268,41 @@
switch(method,
quantile=spCopPredict.quantile(predNeigh, spVine, margin, p),
expectation=spCopPredict.expectation(predNeigh, spVine, margin, ...))
-}
\ No newline at end of file
+}
+
+# draw from a spatial vine
+# Algorithm 1 from Aas et al. (2006): Pair-copula constructions of multiple dependence
+
+r.spVineCop <- function(n, spVine, h) {
+ spVineDim <- spVine at dimension
+
+ sims <- NULL
+ for(runs in 1:n) {
+ init <- runif(spVineDim)
+ res <- init[1]
+ v <- matrix(NA,spVineDim,spVineDim)
+ v[1,1] <- init[1]
+ for (i in 2:spVineDim) { # i <- 2
+ v[i,1] <- init[i]
+ for (k in (i-1):1) { # k <- i-1
+ v[i,1] <- uniroot(function(u) {
+ v[i,1] - ddvCopula(cbind(u,v[k,k]), spVine at spCop[[k]],
+ h=h[[k]][i-k])
+ }, c(0,1))$root
+ }
+ res <- c(res,v[i,1])
+ if(i==spVineDim)
+ break()
+ for(j in 1:(i-1)) {
+ v[i,j+1] <- ddvCopula(cbind(v[i,j],v[j,j]),spVine at spCop[[k]], h=h[[j]][i-j])
+ }
+ }
+ sims <- rbind(sims,res)
+ }
+
+ rownames(sims) <- NULL
+ sims
+}
+
+setMethod("rCopula", signature("numeric","spVineCopula"),
+ function(n, copula, ...) r.spVineCop(n, copula, ...))
\ No newline at end of file
Modified: pkg/R/spatialPreparation.R
===================================================================
--- pkg/R/spatialPreparation.R 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/R/spatialPreparation.R 2013-05-21 08:26:21 UTC (rev 96)
@@ -54,7 +54,7 @@
prediction=x at prediction)
}
-setMethod("[", signature("neighbourhood"), selectFromNeighbourhood)
+setMethod("[[", "neighbourhood", selectFromNeighbourhood)
## calculate neighbourhood from SpatialPointsDataFrame
Modified: pkg/R/vineCopulas.R
===================================================================
--- pkg/R/vineCopulas.R 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/R/vineCopulas.R 2013-05-21 08:26:21 UTC (rev 96)
@@ -77,9 +77,10 @@
function(u,copula) pvineCopula(as.matrix(u),copula))
setMethod("pCopula", signature("matrix","vineCopula"), pvineCopula)
+## simulation
+
rRVine <- function(n, copula) {
RVM <- copula at RVM
-# class(RVM) <- "RVineMatrix"
RVineSim(n, RVM)
}
Modified: pkg/demo/MRP.R
===================================================================
--- pkg/demo/MRP.R 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/demo/MRP.R 2013-05-21 08:26:21 UTC (rev 96)
@@ -10,7 +10,7 @@
cor(triples,method="kendall")
# estiamte the BB7 copula by means of maximum likelihood
-copQV <- fitCopula(BB7Copula(param=c(2,14)), peakVol, method="ml",
+copQV <- fitCopula(BB7Copula(param=c(2,14)), peakVol, method="mpl",
start=c(2,14), estimate.variance=F)@copula
copQV
Modified: pkg/demo/spCopula.R
===================================================================
--- pkg/demo/spCopula.R 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/demo/spCopula.R 2013-05-21 08:26:21 UTC (rev 96)
@@ -47,30 +47,31 @@
claytonCopula(0), frankCopula(1),
gumbelCopula(1), joeBiCopula(1.5),
indepCopula()))
-bestFitTau <- apply(apply(loglikTau, 1, rank, na.last=T), 2,
+bestFitTau <- apply(apply(loglikTau$loglik, 1, rank, na.last=T), 2,
function(x) which(x==7))
-bestFitTau
+colnames(loglikTau$loglik)[bestFitTau]
## set-up a spatial Copula ##
spCop <- spCopula(components=list(normalCopula(0), tCopula(0),
frankCopula(1), normalCopula(0),
- claytonCopula(0), claytonCopula(0),
claytonCopula(0), claytonCopula(0),
+ claytonCopula(0), claytonCopula(0),
claytonCopula(0), indepCopula()),
distances=bins$meanDists,
spDepFun=calcKTauPol, unit="m")
## compare spatial copula loglik by lag:
spLoglik <- NULL
-for(i in 1:length(bins$lags)) { # i <- 8
+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,
- h=bins$lags[[i]][,3])))
+ sum((dCopula(u=bins$lagData[[i]], spCop,log=T,
+ h=bins$lags[[i]][,3]))))
}
plot(spLoglik, ylab="log-likelihood", xlim=c(1,11))
-points(loglikTau[cbind(1:10,bestFitTau)], col="green", pch=16)
-points(loglikTau[,1], col="red", pch=5)
+points(loglikTau$loglik[cbind(1:10,bestFitTau)], col="green", pch=16)
+points(loglikTau$loglik[,1], col="red", pch=5)
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"))
@@ -90,27 +91,14 @@
##
# leave-one-out x-validation
-condVine <- function(condVar, dists, n=100) {
- rat <- 0.2/(1:(n/2))-(0.1/((n+1)/2))
- xVals <- unique(sort(c(rat,1-rat,1:(n-1)/(n))))
- xLength <- length(xVals)
- repCondVar <- matrix(condVar, ncol=length(condVar), nrow=xLength, byrow=T)
- density <- dCopula(cbind(xVals, repCondVar), meuseSpVine, h=dists)
-
- linAppr <- approxfun(c(0,xVals,1), density[c(1,1:xLength,xLength)] ,yleft=0, yright=0)
- int <- integrate(linAppr,lower=0, upper=1)$value
-
- return(function(u) linAppr(u)/int)
-}
-
-time <- proc.time() # ~30 s
+time <- proc.time() # ~60 s
predMedian <- NULL
predMean <- NULL
-for(loc in 1:nrow(meuseNeigh at data)) { # loc <- 429 predNeigh$data[loc,1]
+for(loc in 1:nrow(meuseNeigh at data)) { # loc <- 145
cat("Location:",loc,"\n")
- condSecVine <- condVine(condVar=as.numeric(meuseNeigh at data[loc,-1]),
- dists=meuseNeigh at distances[loc,,drop=F])
-
+ condSecVine <- condSpVine(condVar=as.numeric(meuseNeigh at data[loc,-1]),
+ dists=list(meuseNeigh at distances[loc,,drop=F]),meuseSpVine)
+
predMedian <- c(predMedian, qMar(optimise(function(x) abs(integrate(condSecVine,0,x)$value-0.5),c(0,1))$minimum))
condExp <- function(x) {
Modified: pkg/man/loglikByCopulasLags.Rd
===================================================================
--- pkg/man/loglikByCopulasLags.Rd 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/man/loglikByCopulasLags.Rd 2013-05-21 08:26:21 UTC (rev 96)
@@ -22,7 +22,7 @@
}
}
\value{
-A matrix of spatial lags (rows) and copula family names (columns) holding the calculated log-likelihood values.
+A list containing a matrix (\code{loglik}) of spatial lags (rows) and copula family names (columns) holding the calculated log-likelihood value and a list o the corresponding copula fits.
}
\author{
Benedikt Graeler
@@ -38,7 +38,7 @@
calcKTauPol <- fitCorFun(bins, degree=3)
loglikTau <- loglikByCopulasLags(bins, calcKTauPol)
-loglikTau
+loglikTau$loglik
}
\keyword{spcopula}
Modified: pkg/man/neighbourhood-class.Rd
===================================================================
--- pkg/man/neighbourhood-class.Rd 2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/man/neighbourhood-class.Rd 2013-05-21 08:26:21 UTC (rev 96)
@@ -3,7 +3,7 @@
\docType{class}
\alias{neighbourhood-class}
\alias{names,neighbourhood-method}
-\alias{[,neighbourhood-method}
+\alias{[[,neighbourhood,ANY,ANY-method}
\title{Class \code{neighbourhood}}
\description{A class representing a local spatial neighbourhood.}
@@ -32,6 +32,7 @@
\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{spplot}{\code{signature(obj = "neighbourhood")}: plots the values of the one or more selected columns (0="central location", 1="closest neighbours", ...) at the coordinates of the central location.}
+ \item{[[}{subsets the selection of neighbourhoods returning a subset of these ("columnwise")}
}
}
\author{
Modified: spcopula_0.1-1.tar.gz
===================================================================
(Binary files differ)
Modified: spcopula_0.1-1.zip
===================================================================
(Binary files differ)
More information about the spcopula-commits
mailing list