[spcopula-commits] r155 - in pkg: . R man vignettes/figures
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Aug 30 09:33:12 CEST 2016
Author: ben_graeler
Date: 2016-08-30 09:33:12 +0200 (Tue, 30 Aug 2016)
New Revision: 155
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/partialDerivatives.R
pkg/R/spCopula.R
pkg/R/spatialPreparation.R
pkg/R/spatio-temporalPreparation.R
pkg/R/stCopula.R
pkg/man/calcBins.Rd
pkg/vignettes/figures/copula_densities.pdf
Log:
adopting for changes in package copula
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/DESCRIPTION 2016-08-30 07:33:12 UTC (rev 155)
@@ -2,7 +2,7 @@
Type: Package
Title: Copula Driven Spatio-Temporal Analysis
Version: 0.2-1
-Date: 2015-11-26
+Date: 2016-08-30
Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"),
email = "ben.graeler at uni-muenster.de"),
person("Marius", "Appel",role = "ctb"))
@@ -10,7 +10,7 @@
Description: We provide a framework to analyse spatial and spatio-temporal data via copulas and vine copulas. The data needs to be provided in the form of the sp and spacetime package respectively. Additionally, support for calculating different multivariate return periods based on copulas and vine copulas is implemented.
License: GPL-3
LazyLoad: yes
-Depends: copula (>= 0.999-12), R (>= 3.1.0)
+Depends: copula (>= 0.999-15), R (>= 3.1.0)
Imports: methods, sp, spacetime (>= 1.0-9), VineCopula (>= 1.4)
Suggests: evd
URL: http://r-forge.r-project.org/projects/spcopula/
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/NAMESPACE 2016-08-30 07:33:12 UTC (rev 155)
@@ -2,6 +2,12 @@
import(sp, spacetime)
import(methods)
+importFrom("graphics", "abline", "smoothScatter")
+ importFrom("stats", "D", "approxfun", "cor", "ecdf", "integrate", "lm",
+ "optim", "optimise", "optimize", "pnorm", "predict", "pt",
+ "qnorm", "qt", "quantile", "runif", "uniroot", "var")
+ importFrom("utils", "setTxtProgressBar", "txtProgressBar")
+
importMethodsFrom(VineCopula, fitCopula)
importMethodsFrom(VineCopula, dduCopula,ddvCopula)
Modified: pkg/R/partialDerivatives.R
===================================================================
--- pkg/R/partialDerivatives.R 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/R/partialDerivatives.R 2016-08-30 07:33:12 UTC (rev 155)
@@ -339,7 +339,7 @@
##########################
dduStudent <- function(u, copula){
- df <- copula at df
+ df <- copula at parameters[2]
v <- qt(u,df=df)
rho <- copula at parameters[1]
@@ -358,7 +358,7 @@
##########################
ddvStudent <- function(u, copula){
- df <- copula at df
+ df <- copula at parameters[2]
v <- qt(u, df=df)
rho <- copula at parameters[1]
Modified: pkg/R/spCopula.R
===================================================================
--- pkg/R/spCopula.R 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/R/spCopula.R 2016-08-30 07:33:12 UTC (rev 155)
@@ -521,10 +521,11 @@
return(fitCorFunSng(bins, degree, cutoff, bounds, cor.method, weighted))
# the spatio-temporal case
- degree <- rep(degree,length.out=nrow(bins$lagCor))
+ degree <- rep(degree, length.out = nrow(bins$lagCor))
calcKTau <- list()
- for(j in 1:nrow(bins$lagCor)) {
- calcKTau[[paste("fun",j,sep="")]] <- fitCorFunSng(data.frame(meanDists=bins$meanDists,
+ for (j in 1:nrow(bins$lagCor)) {
+ calcKTau[[paste("fun",j,sep="")]] <- fitCorFunSng(data.frame(np=bins$lagNp[j,],
+ meanDists=bins$meanDists,
lagCor=bins$lagCor[j,]),
degree[j], cutoff, bounds,
cor.method, weighted)
@@ -653,8 +654,8 @@
else {
lagData <- lapply(bins$lags[lagSub],
function(x) {
- as.matrix((cbind(data[x[, 1], var]@data,
- data[x[, 2], var]@data)))
+ as.matrix((cbind(data[x[, 1], var, drop=FALSE]@data,
+ data[x[, 2], var, drop=FALSE]@data)))
})
}
Modified: pkg/R/spatialPreparation.R
===================================================================
--- pkg/R/spatialPreparation.R 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/R/spatialPreparation.R 2016-08-30 07:33:12 UTC (rev 155)
@@ -151,7 +151,7 @@
mDists <- sapply(lags, function(x) mean(x[,3]))
np <- sapply(lags, function(x) length(x[,3]))
- lagData <- lapply(lags, function(x) as.matrix((cbind(data[x[,1],var]@data, data[x[,2],var]@data))))
+ lagData <- lapply(lags, function(x) as.matrix((cbind(data[x[,1],var,drop=FALSE]@data, data[x[,2],var,drop=FALSE]@data))))
if(cor.method == "fasttau")
lagCor <- sapply(lagData, function(x) TauMatrix(x)[1,2])
Modified: pkg/R/spatio-temporalPreparation.R
===================================================================
--- pkg/R/spatio-temporalPreparation.R 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/R/spatio-temporalPreparation.R 2016-08-30 07:33:12 UTC (rev 155)
@@ -349,13 +349,13 @@
if(is.na(cutoff))
cutoff <- spDists(coordinates(t(data at sp@bbox)))[1,2]/3
if(is.na(boundaries))
- boundaries <- ((1:nbins) * cutoff / nbins)
+ 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]))
+ mDists <- sapply(spIndices, function(x) mean(x[,3]))
lengthTime <- length(data at time)
if (!is.numeric(instances) | !length(instances)==1) {
@@ -375,48 +375,52 @@
}
}
- 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)
-
+ # internal stat function
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)
+ return(c(sum(!apply(binnedData, 1, function(x) any(is.na))),
+ cor(binnedData[,1], binnedData[,2],
+ method=cor.method,
+ use="pairwise.complete.obs")))
}
- calcTau <- function(binnedData) {
- cors <- NULL
- for(i in 1:(ncol(binnedData)/2)) {
- tmpData <- binnedData[,2*i+c(-1,0)]
+ # internal fast tau function
+ calcTau <- function(tmpData) {
tmpData <- tmpData[!apply(tmpData, 1, function(x) any(is.na(x))),]
- cors <- c(cors, TauMatrix(tmpData)[1,2])
- }
- return(cors)
+ return(c(nrow(tmpData), TauMatrix(tmpData)[1,2]))
}
calcCor <- switch(cor.method, fasttau=calcTau, calcStats)
- lagCor <- sapply(lagData, calcCor)
+ retrieveData <- function(spIndex, tempIndices, corFun) {
+ binStats <- matrix(NA, nrow = ncol(tempIndices)/2, ncol = 2)
+ for (i in 1:(ncol(tempIndices)/2)) {
+ binStats[i,] <- corFun(cbind(data[spIndex[,1], tempIndices[,2*i-1], var, drop=F]@data[[1]],
+ data[spIndex[,2], tempIndices[,2*i], var, drop=F]@data[[1]]))
+ }
+
+ return(binStats)
+ }
+ lagStats <- lapply(spIndices, retrieveData, tempIndices=tempIndices, corFun=calcCor)
+
+ lagCor <- matrix(NA, length(tlags), nbins)
+ lagNp <- matrix(NA, length(tlags), nbins)
+ for (i in 1:length(lagStats)) {
+ lagNp[,i] <- lagStats[[i]][,1]
+ lagCor[,i] <- lagStats[[i]][,2]
+ }
+
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")
+ plot(mDists, 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))
- res <- list(meanDists = mDists, lagCor=lagCor, lags=list(sp=spIndices, time=tempIndices))
+ res <- list(meanDists = mDists, lagCor = lagCor, lagNp=lagNp,
+ 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 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/R/stCopula.R 2016-08-30 07:33:12 UTC (rev 155)
@@ -242,14 +242,16 @@
gumbelCopula()),
calcCor, lagSub=1:length(stBins$meanDists)) {
nTimeLags <- dim(stBins$lagCor)[1]
+ if(is.null(nTimeLags))
+ nTimeLags <- 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))))
+ as.matrix((cbind(data[spIndex[,1], tempIndices[,2*i-1], var, drop=FALSE]@data,
+ data[spIndex[,2], tempIndices[,2*i], var, drop=FALSE]@data))))
}
return(binnedData)
}
Modified: pkg/man/calcBins.Rd
===================================================================
--- pkg/man/calcBins.Rd 2015-11-26 10:30:03 UTC (rev 154)
+++ pkg/man/calcBins.Rd 2016-08-30 07:33:12 UTC (rev 155)
@@ -52,9 +52,6 @@
\author{
Benedikt Graeler
}
-\seealso{
-\code{\link{VineCopula-package}}
-}
\examples{
library("sp")
data("meuse")
Modified: pkg/vignettes/figures/copula_densities.pdf
===================================================================
(Binary files differ)
More information about the spcopula-commits
mailing list