From noreply at r-forge.r-project.org Tue Aug 30 09:33:12 2016 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 30 Aug 2016 09:33:12 +0200 (CEST) Subject: [spcopula-commits] r155 - in pkg: . R man vignettes/figures Message-ID: <20160830073312.A282A1877A3@r-forge.r-project.org> 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)