From noreply at r-forge.r-project.org Mon Nov 11 18:05:37 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 11 Nov 2013 18:05:37 +0100 (CET) Subject: [spcopula-commits] r111 - pkg pkg/R pkg/man thoughts-Ben Message-ID: <20131111170537.CD38418626F@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-11 18:05:37 +0100 (Mon, 11 Nov 2013) New Revision: 111 Modified: pkg/DESCRIPTION pkg/R/ClaytonGumbelCopula.R pkg/R/joeBiCopula.R pkg/R/spCopula.R pkg/R/spVineCopula.R pkg/R/spatio-temporalPreparation.R pkg/R/stCopula.R pkg/R/stVineCopula.R pkg/man/condStVine.Rd pkg/man/getStNeighbours.Rd pkg/man/loglikByCopulasLags.Rd pkg/man/spCopPredict.Rd pkg/man/spVineCopula.Rd pkg/man/stCopPredict.Rd pkg/man/stCopula.Rd pkg/man/stNeighbourhood.Rd pkg/man/stVineCopula.Rd thoughts-Ben/tawn3pCopula-stub.R Log: - moved VineCopula from Depends to Imports - catched a couple of warnings in copula fitting procedures - updated examples for spatio-temporal functions to be spatio-temporal - chnaged the getStNeighbours function Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/DESCRIPTION 2013-11-11 17:05:37 UTC (rev 111) @@ -10,8 +10,8 @@ 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-7), VineCopula (>= 1.1-2), R (>= 2.15.0) -Imports: sp, spacetime (>= 1.0-2), methods +Depends: copula (>= 0.999-7), R (>= 2.15.0) +Imports: VineCopula (>= 1.1-2), sp, spacetime (>= 1.0-9), methods URL: http://r-forge.r-project.org/projects/spcopula/ Collate: Classes.R Modified: pkg/R/ClaytonGumbelCopula.R =================================================================== --- pkg/R/ClaytonGumbelCopula.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/ClaytonGumbelCopula.R 2013-11-11 17:05:37 UTC (rev 111) @@ -71,7 +71,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("surClaytonCopula"), function(copula, tau) { - if(tau <= 0) warning("The survival Clayton copula can only represent positive dependence!") + if(tau <= 0) + return(NA) linkVineCop.iTau(copula, max(1e-6,abs(tau))) }) @@ -145,12 +146,12 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("r90ClaytonCopula"), function(copula, tau) { - if(tau >= 0) warning("The rotated Clayton copula can only represent negative dependence!") + if(tau >= 0) + return(NA) linkVineCop.iTau(copula, min(-1e-6,-abs(tau))) }) setMethod("tau",signature("r90ClaytonCopula"),linkVineCop.tau) - setMethod("tailIndex",signature("r90ClaytonCopula"),linkVineCop.tailIndex) ######################## @@ -205,7 +206,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("r270ClaytonCopula"), function(copula, tau) { - if(tau >= 0) warning("The rotated Clayton copula can only represent negative dependence!") + if(tau >= 0) + return(NA) linkVineCop.iTau(copula, min(-1e-6,-abs(tau))) }) @@ -286,7 +288,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("surGumbelCopula"), function(copula, tau) { - if(tau < 0) warning("The survival Gumbel copula can only represent non-negative dependence!") + if(tau < 0) + return(NA) linkVineCop.iTau(copula, max(0,abs(tau))) }) @@ -361,7 +364,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("r90GumbelCopula"), function(copula, tau) { - if(tau > 0) warning("The rotated Gumbel copula can only represent non-positive dependence!") + if(tau > 0) + return(NA) linkVineCop.iTau(copula, min(0,-abs(tau))) }) @@ -421,7 +425,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("r270GumbelCopula"), function(copula, tau) { - if(tau >= 0) warning("The rotated Gumbel copula can only represent negative dependence!") + if(tau >= 0) + return(NA) linkVineCop.iTau(copula, min(-1e-6,-abs(tau))) }) Modified: pkg/R/joeBiCopula.R =================================================================== --- pkg/R/joeBiCopula.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/joeBiCopula.R 2013-11-11 17:05:37 UTC (rev 111) @@ -68,7 +68,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("joeBiCopula"), function(copula, tau) { - if(tau <= 0) warning("The Joe copula can only represent positive dependence!") + if(tau <= 0) + return(NA) linkVineCop.iTau(copula, max(1e-6,abs(tau))) }) @@ -147,7 +148,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("surJoeBiCopula"), function(copula, tau) { - if(tau <= 0) warning("The survival Joe copula can only represent positive dependence!") + if(tau <= 0) + return(NA) linkVineCop.iTau(copula, max(1e-6,abs(tau))) }) @@ -224,7 +226,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("r90JoeBiCopula"), function(copula, tau) { - if(tau >= 0) warning("The rotated Joe copula can only represent negative dependence!") + if(tau >= 0) + return(NA) linkVineCop.iTau(copula, min(-1e-6,-abs(tau))) }) @@ -286,7 +289,8 @@ ## Kendalls tau to parameter conversion setMethod("iTau", signature("r270JoeBiCopula"), function(copula, tau) { - if(tau >= 0) warning("The rotated Joe copula can only represent negative dependence!") + if(tau >= 0) + return(NA) linkVineCop.iTau(copula, min(-1e-6,-abs(tau))) }) Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/spCopula.R 2013-11-11 17:05:37 UTC (rev 111) @@ -487,7 +487,7 @@ loglik <- NULL copulas <- list() for (cop in families) { - print(cop) + cat(cop at fullname,"\n") tmploglik <- NULL tmpCop <- list() for(i in 1:length(bins$meanDists)) { @@ -509,12 +509,16 @@ stop(paste(calcCor(NULL), "is not yet supported."))) } else { param <- moa(cop, bins$meanDists[i]) - cop at parameters[1:length(param)] <- param + if(!is.na(param)) + cop at parameters[1:length(param)] <- param } } } - tmploglik <- c(tmploglik, sum(dCopula(bins$lagData[[i]], cop, log=T))) + if(is.na(param)) + tmploglik <- c(tmploglik, NA) + else + tmploglik <- c(tmploglik, sum(dCopula(bins$lagData[[i]], cop, log=T))) tmpCop <- append(tmpCop, cop) } loglik <- cbind(loglik, tmploglik) @@ -531,7 +535,7 @@ fits <-lapply(families, function(cop) { - print(cop) + cat(cop at fullname,"\n") lapply(bins$lagData, function(x) { tryCatch(fitCopula(cop, x, estimate.variance = FALSE), Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/spVineCopula.R 2013-11-11 17:05:37 UTC (rev 111) @@ -204,7 +204,7 @@ } ePred <- integrate(condExp,0,1,subdivisions=10000L,stop.on.error=stop.on.error, ...) - if(ePred$abs.error > 0.01) + if(ePred$abs.error > 0.05) 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) Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/spatio-temporalPreparation.R 2013-11-11 17:05:37 UTC (rev 111) @@ -19,8 +19,8 @@ colnames(data) <- paste(paste("N", (0+prediction):dimDists[2], sep=""),var,sep=".") if (anyDuplicated(rownames(data))>0) rownames <- 1:length(rownames) - new("stNeighbourhood", data=data, distances=distances, locations=STxDF, - dataLocs=ST, index=index, prediction=prediction, var=var, + 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)]) } @@ -48,36 +48,52 @@ timeSpan <- min(t.lags) if(missing(ST) && !prediction) ST=stData - if(is.na(timeSteps)) - timeSteps <- length(stData at time)+timeSpan stopifnot(is(ST,"ST")) - nLocs <- length(ST at sp)*timeSteps - 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.") - - if(prediction) - nghbrs <- getNeighbours(stData[,1], ST, var, spSize, prediction, min.dist) - else + + if(!prediction) { + if(is.na(timeSteps)) { + timeSteps <- length(stData at time)+timeSpan + reSample <- function() (1-timeSpan):length(stData at time) + } else { + 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) + } else { + nLocs <- length(ST) + nghbrs <- getNeighbours(stData[,1], ST at sp, var, spSize, prediction, 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 <- NULL + 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)) + + nTimeInst <- length(reSample()) + for(i in 1:nrow(nghbrs at index)){ # i <- 1 - tmpInst <- sample((1-timeSpan):length(stData at time), timeSteps) # draw random time steps for each neighbourhood - tmpData <- matrix(stData[nghbrs at index[i,], tmpInst, var]@data[[1]], - ncol=spSize, byrow=T) # retrieve the top level data - tmpInd <- matrix(rep(tmpInst,spSize-1),ncol=spSize-1) - for(t in t.lags[-1]) { - tmpData <- cbind(tmpData, matrix(stData[nghbrs at index[i,][-1], - tmpInst+t,var]@data[[1]], - ncol=spSize-1, byrow=T)) - tmpInd <- cbind(tmpInd, matrix(rep(tmpInst+t,spSize-1),ncol=spSize-1)) + 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)) { + 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 <- rbind(stNeighData, tmpData) # bind data row-wise + 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 @@ -90,10 +106,12 @@ stInd[(i-1)*timeSteps+1:timeSteps,,2] <- tmpInd } - if (prediction) + if (prediction) { dataLocs <- stData - else + stNeighData <- stNeighData[,-1] + } else { dataLocs <- NULL + } return(stNeighbourhood(as.data.frame(stNeighData), stDists, stData, ST, stInd, prediction, var)) } Modified: pkg/R/stCopula.R =================================================================== --- pkg/R/stCopula.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/stCopula.R 2013-11-11 17:05:37 UTC (rev 111) @@ -5,18 +5,25 @@ ## constructor ## ################# -stCopula <- function(components, distances, t.lags, stDepFun, unit="m", t.res="day") { - 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)){ - spCopList <- append(spCopList, getSpCop(components[[i]], distances[[i]], i)) - } +stCopula <- function(components, t.lags, distances=NA, stDepFun, unit="m", t.res="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)) + spCopList <- components } else { - for(i in 1:length(t.lags)){ - spCopList <- append(spCopList, spCopula(components[[i]], distances[[i]], unit=unit)) + 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)){ + spCopList <- append(spCopList, getSpCop(components[[i]], distances[[i]], i)) + } + } else { + for(i in 1:length(t.lags)){ + spCopList <- append(spCopList, spCopula(components[[i]], distances[[i]], unit=unit)) + } } } Modified: pkg/R/stVineCopula.R =================================================================== --- pkg/R/stVineCopula.R 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/R/stVineCopula.R 2013-11-11 17:05:37 UTC (rev 111) @@ -173,7 +173,7 @@ 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,], stVine) + condSecVine <- condStVine(as.numeric(predNeigh at data[i,]), dists[i,,,drop=F], stVine) xVals <- attr(condSecVine,"xVals") density <- condSecVine(xVals) Modified: pkg/man/condStVine.Rd =================================================================== --- pkg/man/condStVine.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/condStVine.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -35,27 +35,29 @@ \code{\linkS4class{stVineCopula}}, \code{\link{condSpVine}} } \examples{ -## the spatial version -data(spCopDemo) +# a spatio-temporal C-vine copula (with independent copulas in the upper vine) -calcKTauPol <- fitCorFun(bins, degree=3) +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") -spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"), - frankCopula(1), normalCopula(0), claytonCopula(0), - claytonCopula(0), claytonCopula(0), claytonCopula(0), - claytonCopula(0), indepCopula()), - distances=bins$meanDists, - spDepFun=calcKTauPol, unit="m") +stCop <- stCopula(components=list(spCopT0, spCopT1), + t.lags=-(0:1)) -spVineCop <- spVineCopula(spCop, vineCopula(4L)) +stVineCop <- stVineCopula(stCop, vineCopula(4L)) -dists <- list(c(473, 124, 116, 649)) +dists <- array(c(150, 250, 150, 250,0,0,-1,-1),dim=c(1,4,2)) condVar <- c(0.29, 0.55, 0.05, 0.41) -condDensity <- condSpVine(condVar,dists,spVineCop) +condDensity <- condStVine(condVar,dists,stVineCop) curve(condDensity) -mtext(paste("Dists:",paste(round(dists[[1]],0),collapse=", ")),line=0) -mtext(paste("Cond.:",paste(round(condVar,2),collapse=", ")),line=1) } \keyword{ distribution } \ No newline at end of file Modified: pkg/man/getStNeighbours.Rd =================================================================== --- pkg/man/getStNeighbours.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/getStNeighbours.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -42,11 +42,18 @@ See \code{\link{stNeighbourhood}} for the native constructor of a \code{\linkS4class{stNeighbourhood}} class. The pure spatial version can be found at \code{\link{getNeighbours}}. } \examples{ -## the spatial version: library(sp) -spdf <- data.frame(x=c(112,154,212,289,345),y=c(124,198,85,168,346),measure=rlnorm(5)) -coordinates(spdf) <- ~x+y +library(spacetime) -getNeighbours(spdf,size=4) +sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) +time <- Sys.time()+60*60*24*c(0,1,2) +data <- data.frame(var1=runif(6)) + +stData <- STFDF(sp, time, data) +stQuerry <- STF(SpatialPoints(matrix(c(181000,181200,333600,333600),2)), + time[2:3]) + +getStNeighbours(stData=stData, ST=stQuerry, prediction=TRUE, spSize=3, + t.lags=-(0:1)) } \keyword{ spatial } \ No newline at end of file Modified: pkg/man/loglikByCopulasLags.Rd =================================================================== --- pkg/man/loglikByCopulasLags.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/loglikByCopulasLags.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -38,7 +38,7 @@ calcKTauPol <- fitCorFun(bins, degree=3) -loglikTau <- loglikByCopulasLags(bins, calcKTauPol) +loglikTau <- loglikByCopulasLags(bins, calcCor=calcKTauPol) loglikTau$loglik } Modified: pkg/man/spCopPredict.Rd =================================================================== --- pkg/man/spCopPredict.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/spCopPredict.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -58,7 +58,7 @@ meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1) -predMeuseNeigh <- getNeighbours(meuse[1:4,], meuse.grid[c(9:12,15:19,24:28,34:38),], +predMeuseNeigh <- getNeighbours(meuse[1:4,], meuse.grid[c(9:12,16:19,25:28),], "rtZinc", 5L, TRUE, -1) qMar <- function(x) { @@ -67,10 +67,12 @@ predMedian <- spCopPredict(predMeuseNeigh, spVineCop, list(q=qMar), "quantile", p=0.5) +\dontrun{ spplot(predMedian,"quantile.0.5", sp.layout=list("sp.points", meuse, pch = 19, col = "red"), col.regions=bpy.colors()) } +} \keyword{ distribution } \keyword{ prediction } Modified: pkg/man/spVineCopula.Rd =================================================================== --- pkg/man/spVineCopula.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/spVineCopula.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -35,6 +35,7 @@ distances=bins$meanDists, spDepFun=calcKTauPol, unit="m") +library(VineCopula) RVM <- RVineMatrix(matrix(c(1,0,0,2,2,0,3,3,3),3,byrow=TRUE)) spVineCopula(spCop, vineCopula(RVM)) } Modified: pkg/man/stCopPredict.Rd =================================================================== --- pkg/man/stCopPredict.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/stCopPredict.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -32,44 +32,39 @@ \code{\link{condStVine}} and \code{\link{spCopPredict}} for the spatial version. } \examples{ -## the spatial version -data(spCopDemo) +library(sp) +library(spacetime) -calcKTauPol <- fitCorFun(bins, degree=3) +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") -spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"), - frankCopula(1), normalCopula(0), claytonCopula(0), - claytonCopula(0), claytonCopula(0), claytonCopula(0), - claytonCopula(0), indepCopula()), - distances=bins$meanDists, - spDepFun=calcKTauPol, unit="m") +stCop <- stCopula(components=list(spCopT0, spCopT1), + t.lags=-(0:1)) -spVineCop <- spVineCopula(spCop, vineCopula(4L)) +stVineCop <- stVineCopula(stCop, vineCopula(4L)) -library(sp) -data(meuse.grid) -coordinates(meuse.grid) <- ~x+y -gridded(meuse.grid) <- TRUE +sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) +time <- Sys.time()+60*60*24*c(0,1,2) +data <- data.frame(var1=runif(6)) -data(meuse) -coordinates(meuse) <- ~x+y +stData <- STFDF(sp, time, data) +stQuerry <- STF(SpatialPoints(matrix(c(181000,181200,333600,333600),2)), + time[2:3]) -meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1) +stNeigh <- getStNeighbours(stData=stData, ST=stQuerry, prediction=TRUE, spSize=3, + t.lags=-(0:1)) -predMeuseNeigh <- getNeighbours(meuse[1:4,], meuse.grid[c(9:12,15:19,24:28,34:38),], - "rtZinc", 5L, TRUE, -1) - -qMar <- function(x) { - qlnorm(x,mean(log(meuse$zinc)),sd(log(meuse$zinc))) +stCopPredict(stNeigh, stVineCop, list(q=qunif), "quantile", 0.5) } -predMedian <- spCopPredict(predMeuseNeigh, spVineCop, list(q=qMar), "quantile", p=0.5) - -spplot(predMedian,"quantile.0.5", - sp.layout=list("sp.points", meuse, pch = 19, col = "red"), - col.regions=bpy.colors()) -} - \keyword{ distribution } \keyword{ prediction } \keyword{ spatial } Modified: pkg/man/stCopula.Rd =================================================================== --- pkg/man/stCopula.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/stCopula.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -7,25 +7,17 @@ Constructor of a bivariate spatio-temporal copula \code{\linkS4class{stCopula}}. } \usage{ -stCopula(components, distances, t.lags, stDepFun, unit="m", t.res="day") +stCopula(components, t.lags, distances=NA, stDepFun, unit="m", t.res="day") } \arguments{ - \item{components}{ -A list of bivariate spatial copulas (\code{\linkS4class{spCopula}}) to be used at each temporal lag. + \item{components}{A list of bivariate spatial copulas (\code{\linkS4class{spCopula}}) to be used at each temporal lag. Or a list of with lists of the spatial components per temporal lag together with the argument \code{distances}.} + \item{t.lags}{The temporal lags used in the spatio-temporal copula.} + \item{distances}{This and the follwoing 2 argumewnts are only neccessary when the provided \code{components} argument is not yet a list of \code{\linkS4class{spCopula}}s: A vector of the mean distances of the spatial lag classes.} + \item{stDepFun}{A list of spatial dependence functions; one per temporal lag. This argument is only needed when components is not yet a list of \code{\linkS4class{spCopula}}s.} + \item{unit}{The spatial unit, default: m (meters). This argument is only needed when components is not yet a list of \code{\linkS4class{spCopula}}s.} + \item{t.res}{The temporal resolution, default: day} } - \item{distances}{ -A vector of the mean distances of the spatial lag classes. -} -\item{t.lags}{The temporal lags used in the spatio-temporal copula.} - \item{stDepFun}{ -A list of spatial dependence functions; one per temporal lag. -} - \item{unit}{ -The spatial unit, default: m (meters) -} -\item{t.res}{The temporal resolution, default: day} -} \value{ An instance of the spatio-temporal Copula class \code{\linkS4class{stCopula}}. } @@ -37,16 +29,23 @@ \code{\link{spCopula}} } \examples{ -data(spCopDemo) +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") -calcKTauPol <- fitCorFun(bins, degree=3) - -spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"), - frankCopula(1), normalCopula(0), claytonCopula(0), - claytonCopula(0), claytonCopula(0), claytonCopula(0), - claytonCopula(0), indepCopula()), - distances=bins$meanDists, - spDepFun=calcKTauPol, unit="m") +stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), + t.lags=-(0:2)) } \keyword{spcopula} \keyword{copula} Modified: pkg/man/stNeighbourhood.Rd =================================================================== --- pkg/man/stNeighbourhood.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/stNeighbourhood.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -25,16 +25,19 @@ \code{\linkS4class{stNeighbourhood}}, \code{\link{getStNeighbours}} } \examples{ -## the spatial version library(sp) -spdf <- data.frame(x=c(112,154,212,289),y=c(124,198,85,168),measure=rlnorm(4)) -coordinates(spdf) <- ~x+y +library(spacetime) -neigh <- getNeighbours(spdf,size=4) -neigh +sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) +time <- Sys.time()+60*60*24*c(0,1,2) +data <- data.frame(var1=runif(6)) -# rebuilding neigh -neighbourhood(neigh at data, neigh at distances, neigh at index, spdf, NULL, neigh at prediction, neigh at var) +stData <- STFDF(sp, time, data) +stQuerry <- STF(SpatialPoints(matrix(c(181000,181200,333600,333600),2)), + time[2:3]) + +getStNeighbours(stData=stData, ST=stQuerry, prediction=TRUE, spSize=3, + t.lags=-(0:1)) } \keyword{spatio-temporal} \ No newline at end of file Modified: pkg/man/stVineCopula.Rd =================================================================== --- pkg/man/stVineCopula.Rd 2013-10-24 11:37:56 UTC (rev 110) +++ pkg/man/stVineCopula.Rd 2013-11-11 17:05:37 UTC (rev 111) @@ -20,21 +20,28 @@ Benedikt Graeler } \examples{ -## the spatial version -# a spatial C-vine copula (with independent dummy copulas in the upper vine) -data(spCopDemo) +# a spatio-temporal C-vine copula (with independent copulas in the upper vine) -calcKTauPol <- fitCorFun(bins, degree=3) +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") -spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"), - frankCopula(1), normalCopula(0), claytonCopula(0), - claytonCopula(0), claytonCopula(0), claytonCopula(0), - claytonCopula(0), indepCopula()), - distances=bins$meanDists, - spDepFun=calcKTauPol, unit="m") +stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), + t.lags=-(0:2)) -RVM <- RVineMatrix(matrix(c(1,0,0,2,2,0,3,3,3),3,byrow=TRUE)) -spVineCopula(spCop, vineCopula(RVM)) +library(VineCopula) +stVineCopula(stCop, vineCopula(9L)) } \keyword{ mulitvariate } \keyword{ distribution } \ No newline at end of file Modified: thoughts-Ben/tawn3pCopula-stub.R =================================================================== --- thoughts-Ben/tawn3pCopula-stub.R 2013-10-24 11:37:56 UTC (rev 110) +++ thoughts-Ben/tawn3pCopula-stub.R 2013-11-11 17:05:37 UTC (rev 111) @@ -9,11 +9,35 @@ beta <- param[2] theta <- param[3] (1-beta)*(t) + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta) -# 1-beta + (beta-alpha)*t + ((alpha*t)^theta + (beta*(1-t))^theta)^(1/theta) + } -curve(Atawn3p) +ATawn <- function(copula, w) { + Atawn3p(w,copula at parameters) +} +setMethod("A",signature("tawn3pCopula"),ATawn) + +dAduTawn <- function(copula, w) { + alpha <- copula at parameters[1] + beta <- copula at parameters[2] + theta <- copula at parameters[3] + + # 1st derivative + p1 <- (alpha*(alpha*(-(w-1)))^(theta-1)-beta*(beta*w)^(theta-1)) + p2 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-1) + + # 2nd derivative + p3 <- (alpha*(-(w-1)))^(theta-2) + p4 <- (beta*w)^(theta-2) + p5 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-2) + + data.frame(der1=alpha-beta-p1*p2, + der2=alpha^2*beta^2*(theta-1)*p3*p4*p5) +} + +setMethod("dAdu",signature("tawn3pCopula"),dAduTawn) + tawn3pCopula <- function (param = c(0.5, 0.5, 2)) { # A(t) = (1-beta)*(1-t) + (1-alpha)*t + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta) # C(u1,u2) = exp(log(u1*u2) * A(log(u2)/log(u1*u2))) @@ -70,54 +94,57 @@ persp(tawn3pCopula(c(0.25, 0.75, 2)), dCopula) persp(tawn3pCopula(c(0.5, 1, 20)), pCopula) -plot(1-rtTriples[,c(1,3)]) - -dCopula(c(0.15,0.95), tawn3pCopula(c(0.5, 0.5, 2))) - - -tawnFit <- fitCopula(tawn3pCopula(), 1-as.matrix(rtTriples[,c(1,3)]), hideWarnings=F,estimate.variance=F, +tawnFit <- fitCopula(tawn3pCopula(c(0.25, 0.75, 2)), 1-as.matrix(rtTriples[,c(1,3)]), hideWarnings=F,estimate.variance=F, start=c(0.9, 1, 8), method="mpl", lower=c(0,0,1), upper=c(1, 1, 10), optim.method="L-BFGS-B",) tawnFit at loglik # 742 -tawnFit at copula +tawnCop <- tawnFit at copula -fitCopula(gumbelCopula(5),1-as.matrix(rtTriples[,c(1,3)]))@loglik # 723 +par(mfrow=c(2,2)) +plot(rCopula(500,tawn3pCopula(c(tawnCop$par2, 1, tawnCop$par))),asp=1) +plot(rCopula(500,tawnFit at copula),asp=1) +plot(rCopula(500,cdfAFunCopula(aGevPar)),asp=1) +plot(1-rtTriples[,c(3,1)], asp=1) -dLeaf <- dCopula(as.matrix(rtTriples[,c(1,3)]), spcopula:::leafCopula()) -sum(log(dLeaf[dLeaf>0])) +# fitCopula(gumbelCopula(5),1-as.matrix(rtTriples[,c(1,3)]))@loglik # 723 +# +# dLeaf <- dCopula(as.matrix(rtTriples[,c(1,3)]), spcopula:::leafCopula()) +# sum(log(dLeaf[dLeaf>0])) +# +# persp(tawnFit at copula, dCopula) +# contour(tawnFit at copula, dCopula, levels=c(0,0.5,1,2,4,8,100), asp=1) +# +# sum(dCopula(as.matrix(rtTriples[,c(1,3)]), cop13, log=T)) +# sum(dCopula(1-as.matrix(rtTriples[,c(1,3)]), tawnFit at copula, log=T)) -persp(tawnFit at copula, dCopula) -contour(tawnFit at copula, dCopula, levels=c(0,0.5,1,2,4,8,100), asp=1) - -sum(dCopula(as.matrix(rtTriples[,c(1,3)]), cop13, log=T)) -sum(dCopula(1-as.matrix(rtTriples[,c(1,3)]), tawnFit at copula, log=T)) - +par(mfrow=c(1,1)) plot(1-as.matrix(rtTriples[,c(1,3)]),asp=1,cex=0.5) curve(x^(tawnFit at copula@parameters[1]),add=T, col="red") abline(0,1,col="grey") -copula:::fitCopula.ml - -tawn3pCopula() - -persp(tawn3pCopula(),dCopula) - - ### -# h(t) +# h(t), TUM thesis eq. (4.11) +library(evd) hist(log(1-rtTriples[,3])/log((1-rtTriples[,1])*(1-rtTriples[,3])),n=20, - xlim=c(0,1), freq=F, add=T, col="blue") + xlim=c(0,1), freq=F, add=F, col="blue") tSmpl <- log(1-rtTriples[,3])/log((1-rtTriples[,1])*(1-rtTriples[,3])) - ((1-rtTriples[,1])-(1-rtTriples[,3]))*(0.5)+0.5 +# ((1-rtTriples[,1])-(1-rtTriples[,3]))*(0.5)+0.5 dlogNorm <- function(x) dlnorm(x, mean(log(tSmpl)), sd(log(tSmpl))) + aGevPar <- fgev(tSmpl)$estimate -dGev <- function(x) dgev(x, 0.46938, 0.05057, 0.01720) -dGamma <- function(x) dgamma(x, 60.40556, 120.92807) - +dGev <- function(x) dgev(x, aGevPar[1], aGevPar[2], aGevPar[3]) + +optFun <- function(param) { + -sum(log(dgamma(tSmpl,param[1],param[2]))) +} +aGammaPar <- optim(c(1,0.5),optFun)$par +dGamma <- function(x) dgamma(x, aGammaPar[1], aGammaPar[2]) + +par(mfrow=c(1,1)) hist(tSmpl, freq=F, xlim=c(0,1), n=20, add=F) curve(dlogNorm, add=T) curve(dGev, add=T, col="red") @@ -131,10 +158,13 @@ Afit <- function(t) { res <- t res[res == 0] <- 1 - intFun <- function(z) (pgev(z, 0.46938, 0.05057, 0.01720)-z)/(z-z^2) + + intFun <- function(z) (pgev(z, aGevPar[1], aGevPar[2], aGevPar[3])-z)/(z-z^2) + for(i in which(res != 1)) { res[i] <- exp(integrate(intFun,0,t[i])$value) } + return(res) } @@ -143,20 +173,143 @@ abline(1, -1, col="grey") curve(Atawn3p,col="red",add=T) +## understanding why some cdfs produce a convex A and some do not: [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 111 From noreply at r-forge.r-project.org Tue Nov 19 09:57:27 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 19 Nov 2013 09:57:27 +0100 (CET) Subject: [spcopula-commits] r112 - pkg/R Message-ID: <20131119085727.AF6201800FB@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-19 09:57:27 +0100 (Tue, 19 Nov 2013) New Revision: 112 Modified: pkg/R/Classes.R pkg/R/cqsCopula.R pkg/R/linkingVineCopula.R pkg/R/partialDerivatives.R pkg/R/spCopula.R pkg/R/spVineCopula.R pkg/R/utilities.R Log: - correction in partial derivative of cqsCopula - typo in spCopula for single distances Modified: pkg/R/Classes.R =================================================================== --- pkg/R/Classes.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/Classes.R 2013-11-19 08:57:27 UTC (rev 112) @@ -129,7 +129,7 @@ nonIndep <- sapply(object at components[-nComp], function(x) class(x) != "indepCopula") for (i in (1:(nComp-1))[nonIndep]) { upParam <- object at calibMoa(object at components[[i]], object at distances[i+1]) - if(is.na(upParam)) { + if(any(is.na(upParam))) { check.upper <- c(check.upper, TRUE) } else { if (class(object at components[[i]]) == "frankCopula" && upParam == 0) { Modified: pkg/R/cqsCopula.R =================================================================== --- pkg/R/cqsCopula.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/cqsCopula.R 2013-11-19 08:57:27 UTC (rev 112) @@ -131,15 +131,13 @@ c0 <- -y v <- solveCubicEq(c3,c2,c1,c0) - - return(v) -# filter <- function(vec){ -# vec <- vec[!is.na(vec)] -# return(vec[vec >= 0 & vec <= 1]) -# } -# -# return(apply(v,1,filter)) + filter <- function(vec){ + vec <- vec[!is.na(vec)] + return(vec[vec >= 0 & vec <= 1]) + } + + return(apply(v,1,filter)) } setMethod("invdduCopula", signature("numeric","cqsCopula","numeric"), invdduCQSec) @@ -180,14 +178,12 @@ u <- solveCubicEq(c3,c2,c1,c0) - return(u) + filter <- function(vec){ + vec <- vec[!is.na(vec)] + return(vec[vec >= 0 & vec <= 1]) + } -# filter <- function(vec){ -# vec <- vec[!is.na(vec)] -# return(vec[vec >= 0 & vec <= 1]) -# } -# -# return(apply(u,1,filter)) + return(apply(u,1,filter)) } setMethod("invddvCopula", signature("numeric","cqsCopula","numeric"), invddvCQSec) @@ -198,7 +194,7 @@ u <- runif(n, min = 0, max = 1) y <- runif(n, min = 0, max = 1) - res <- cbind(u, invdduCQSec(u, copula, y)) + res <- cbind(u, spcopula:::invdduCQSec(u, copula, y)) colnames(res) <- c("u","v") return(res) @@ -304,7 +300,7 @@ fitCQSec.ml <- function(copula, data, start, lower, upper, optim.control, optim.method) { if(length(start)!=2) stop("Start values need to have same length as parameters.") - if (length(copula at fixed)==0) { + if (copula at fixed=="") { optFun <- function(param=c(0,0)) { if(any(param > 1) | param[2] < -1 | param[1] < limA(param[2])) return(100) Modified: pkg/R/linkingVineCopula.R =================================================================== --- pkg/R/linkingVineCopula.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/linkingVineCopula.R 2013-11-19 08:57:27 UTC (rev 112) @@ -19,14 +19,16 @@ constr(c(par,par2)) } -##################################################### +######################################################### ## generic wrapper functions to the VineCopula package ## -##################################################### +######################################################### # density from BiCopPDF linkVineCop.PDF <- function (u, copula, log=FALSE) { param <- copula at parameters - if(length(param)==1) param <- c(param,0) + + if(length(param)==1) + param <- c(param,0) n <- nrow(u) fam <- copula at family @@ -34,8 +36,10 @@ # coplik = .C("LL_mod_seperate", as.integer(fam), as.integer(n), as.double(u[,1]), # as.double(u[,2]), as.double(param[1]), as.double(param[2]), # as.double(rep(0, n)), PACKAGE = "VineCopula")[[7]] - if(log) return(coplik) - else return(exp(coplik)) + if(log) + return(coplik) + else + return(exp(coplik)) } # cdf from BiCopCDF Modified: pkg/R/partialDerivatives.R =================================================================== --- pkg/R/partialDerivatives.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/partialDerivatives.R 2013-11-19 08:57:27 UTC (rev 112) @@ -101,9 +101,23 @@ ## independent copula ## ######################## +## Kendall's tau +################ +setMethod("tau", signature("indepCopula"), function(copula, ...) return(0)) + +## Spearman's rho +################# +setMethod("rho", signature("indepCopula"), function(copula, ...) return(0)) + +## indepCopula as evCopula derivatives of A +########################################### +setMethod("dAdu", signature("indepCopula"), + function(copula, w) { + data.frame(der1=rep(0, length(w)), der2=rep(0, length(w))) + }) + ## partial derivative d/du ########################## - setMethod("dduCopula", signature("numeric","indepCopula"), function(u, copula, ...) { matrix(u,ncol=copula at dimension)[,2] @@ -112,7 +126,6 @@ ## inverse of the partial derivative d/du ######################################### - invdduIndep <- function(u, copula, y){ return(y) } @@ -121,7 +134,6 @@ ## partial derivative d/dv ########################## - setMethod("ddvCopula", signature("numeric","indepCopula"), function(u, copula, ...) { matrix(u,ncol=copula at dimension)[,1] @@ -130,7 +142,6 @@ ## inverse of the partial derivative d/dv ######################################### - invddvIndep <- function(v, copula, y){ return(y) } @@ -144,7 +155,6 @@ ## partial derivative d/du ########################## - dduClayton <- function(u, copula){ rho <- copula at parameters Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/spCopula.R 2013-11-19 08:57:27 UTC (rev 112) @@ -73,10 +73,10 @@ cmpCop <- object at components[[i]] cat(" ", cmpCop at fullname, "at", object at distances[i], paste("[",object at unit,"]",sep=""), "\n") - if (length(cmpCop at parameters) > 0) { - for (i in (1:length(cmpCop at parameters))) - cat(" ", cmpCop at param.names[i], " = ", cmpCop at parameters[i], "\n") - } +# if (length(cmpCop at parameters) > 0) { +# for (i in (1:length(cmpCop at parameters))) +# cat(" ", cmpCop at param.names[i], " = ", cmpCop at parameters[i], "\n") +# } } if(!is.null(object at calibMoa(normalCopula(0),0))) cat("A spatial dependence function is used. \n") } @@ -213,7 +213,7 @@ } else { if(class(lowerCop) != "indepCopula") { lowerParam <- calibPar(lowerCop, h) - lowerCop at parameters[length(lowerParam)] <- lowerParam + lowerCop at parameters[1:length(lowerParam)] <- lowerParam } return(fun(pairs, lowerCop, ...)) } @@ -499,6 +499,7 @@ spearman=fitASC2.irho(cop, bins$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), @@ -507,6 +508,7 @@ spearman=fitCQSec.irho(cop, bins$lagData[[i]], rho=calcCor(bins$meanDists[i]))@copula, stop(paste(calcCor(NULL), "is not yet supported."))) + param <- cop at parameters } else { param <- moa(cop, bins$meanDists[i]) if(!is.na(param)) @@ -515,7 +517,7 @@ } } - if(is.na(param)) + if(any(is.na(param))) tmploglik <- c(tmploglik, NA) else tmploglik <- c(tmploglik, sum(dCopula(bins$lagData[[i]], cop, log=T))) Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/spVineCopula.R 2013-11-19 08:57:27 UTC (rev 112) @@ -186,16 +186,15 @@ # interpolation spCopPredict.expectation <- function(predNeigh, spVine, margin, ..., stop.on.error=F) { -# stopifnot(!is.null(range)) -# stopifnot(is.function(margin$d)) -# stopifnot(is.function(margin$p)) stopifnot(is.function(margin$q)) dists <- calcSpTreeDists(predNeigh,length(spVine at spCop)) predMean <- 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 - cat("[Predicting location ",i,".]\n", sep="") + setTxtProgressBar(pb, i) condSecVine <- condSpVine(as.numeric(predNeigh at data[i,-1]), lapply(dists,function(x) x[i,]), spVine) @@ -203,12 +202,14 @@ margin$q(x)*condSecVine(x) } - ePred <- integrate(condExp,0,1,subdivisions=10000L,stop.on.error=stop.on.error, ...) + ePred <- integrate(condExp,0+.Machine$double.eps,1-.Machine$double.eps,subdivisions=10000L,stop.on.error=stop.on.error, ...) if(ePred$abs.error > 0.05) 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) } + close(pb) + if ("data" %in% slotNames(predNeigh at predLocs)) { res <- predNeigh at predLocs res at data[["expect"]] <- predMean @@ -225,8 +226,9 @@ dists <- calcSpTreeDists(predNeigh,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 - cat("[Predicting location ",i,".]\n", sep="") + setTxtProgressBar(pb, i) condSecVine <- condSpVine(as.numeric(predNeigh at data[i,-1]), lapply(dists,function(x) x[i,]), spVine) @@ -247,6 +249,7 @@ # 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 Modified: pkg/R/utilities.R =================================================================== --- pkg/R/utilities.R 2013-11-11 17:05:37 UTC (rev 111) +++ pkg/R/utilities.R 2013-11-19 08:57:27 UTC (rev 112) @@ -2,7 +2,7 @@ # ranks are automatically removed and NAs are by default randomly distributed -rankTransform <- function(u,v=NULL, ties.method="average") { +rankTransform <- function(u,v=NULL, na.last=TRUE, ties.method="average") { if(!(is.matrix(u) | is.data.frame(u))) { if (is.null(v)) stop("u must either be a matrix with at least 2 columns or u and v must be given.") @@ -10,8 +10,7 @@ u <- cbind(u,v) } - bool <- apply(u,1,function(row) !any(is.na(row))) - res <- apply(u[bool,],2,rank,ties.method=ties.method)/(sum(bool)+1) + res <- apply(u,2,function(x) rank(x,na.last,ties.method)/(sum(!is.na(x))+1)) if(is.data.frame(u)) return(as.data.frame(res)) return(res) From noreply at r-forge.r-project.org Tue Nov 19 16:49:54 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 19 Nov 2013 16:49:54 +0100 (CET) Subject: [spcopula-commits] r113 - in pkg: . R demo man Message-ID: <20131119154954.B24AE184A68@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-19 16:49:54 +0100 (Tue, 19 Nov 2013) New Revision: 113 Added: pkg/R/spatialGaussianCopula.R pkg/man/spGaussCopPredict.Rd pkg/man/spGaussLogLik.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/spatialPreparation.R pkg/demo/spCopula.R pkg/man/rankTransform.Rd Log: - newly implemented spatial Gaussian Copula prediction Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2013-11-19 08:57:27 UTC (rev 112) +++ pkg/DESCRIPTION 2013-11-19 15:49:54 UTC (rev 113) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.1-1 -Date: 2013-10-24 +Date: 2013-11-19 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel", role = "ctb")) @@ -37,4 +37,5 @@ stVineCopula.R utilities.R returnPeriods.R + spatialGaussianCopula.R zzz.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2013-11-19 08:57:27 UTC (rev 112) +++ pkg/NAMESPACE 2013-11-19 15:49:54 UTC (rev 113) @@ -24,6 +24,7 @@ export(qCopula_u) export(condSpVine,spCopPredict) export(condStVine,stCopPredict) +export(spGaussCopPredict, spGaussLogLik) # tweaks # export(setSizeLim) Added: pkg/R/spatialGaussianCopula.R =================================================================== --- pkg/R/spatialGaussianCopula.R (rev 0) +++ pkg/R/spatialGaussianCopula.R 2013-11-19 15:49:54 UTC (rev 113) @@ -0,0 +1,87 @@ +## spatial Gaussian Copula + +# "density" evaluation +spGaussLogLik <- function(corFun, neigh, log=T) { + neighDim <- ncol(neigh at data) + + allDataDists <- spDists(neigh at dataLocs) + + pb <- txtProgressBar(0, nrow(neigh at data), 0, width = getOption("width") - 10, style = 3) + + loglik <- 0 + + for(i in 1:nrow(neigh at data)) { # i <- 2 + setTxtProgressBar(pb, i) + tmpDists <- allDataDists[neigh at index[i,], neigh at index[i,]] + + tmpCor <- corFun(tmpDists) + + tmpGaussCop <- normalCopula(tmpCor[lower.tri(tmpCor)], neighDim, dispstr="un") + + loglik <- loglik + dCopula(as.numeric(neigh at data[i,]), tmpGaussCop, log=T) + } + close(pb) + + if(log) + return(loglik) + else + return(exp(loglik)) +} + +# interpolation based on a valid corelogram function +spGaussCopPredict <- function(corFun, predNeigh, 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) + + pb <- txtProgressBar(0, nrow(predNeigh at data), 0, width = getOption("width") - 10, style = 3) + + predQuantile <- NULL + + for(i in 1:nrow(predNeigh at data)) { # i <- 2 + setTxtProgressBar(pb, i) + tmpDataDists <- allDataDists[predNeigh at index[i,-1], predNeigh at index[i,-1]] + + tmpDists <- rbind(c(0,predNeigh at distances[i,]), + cbind(predNeigh at distances[i,], tmpDataDists)) + tmpCor <- corFun(tmpDists) + + tmpGaussCop <- normalCopula(tmpCor[lower.tri(tmpCor)], neighDim, dispstr="un") + rat <- 50:1 %x% c(1e-06, 1e-05, 1e-04, 0.001) + xVals <- unique(sort(c(rat, 1 - rat, 1:(n - 1)/n))) + nx <- length(xVals) + + condGausCop <- dCopula(cbind(xVals, matrix(rep(as.numeric(predNeigh at data[i,-1]), + length(xVals)), ncol=neighDim-1, byrow=T)), + tmpGaussCop) + + condGausCop <- c(max(0, 2 * condGausCop[1] - condGausCop[2]), condGausCop, + max(0, 2 * condGausCop[nx] - condGausCop[nx - 1])) + int <- sum(diff(c(0, xVals, 1)) * (0.5 * diff(condGausCop) + condGausCop[-(nx + 2)])) + + condVineFun <- approxfun(c(0, xVals, 1), condGausCop/int) + + condGausCop <- condVineFun(xVals) + int <- cumsum(c(0, diff(xVals) * (0.5 * diff(condGausCop) + condGausCop[-nx]))) + lower <- max(which(int <= p)) + m <- (condGausCop[lower + 1] - condGausCop[lower])/(xVals[lower + 1] - xVals[lower]) + b <- condGausCop[lower] + xRes <- -b/m + sign(m) * sqrt(b^2/m^2 + 2 * (p - int[lower])/m) + predQuantile <- c(predQuantile, margin$q(xVals[lower] + xRes)) + } + close(pb) + + if ("data" %in% slotNames(predNeigh at predLocs)) { + res <- predNeigh at 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)) + } +} Modified: pkg/R/spatialPreparation.R =================================================================== --- pkg/R/spatialPreparation.R 2013-11-19 08:57:27 UTC (rev 112) +++ pkg/R/spatialPreparation.R 2013-11-19 15:49:54 UTC (rev 113) @@ -209,7 +209,7 @@ if(cor.method == "fasttau") lagCor <- sapply(lagData, function(x) VineCopula:::fasttau(x[,1], x[,2])) - if(cor.method %in% c("kendall","spearman","perarson")) + if(cor.method %in% c("kendall","spearman","pearson")) lagCor <- sapply(lagData, function(x) cor(x,method=cor.method)[1,2]) if(cor.method == "normVariogram") lagCor <- sapply(lagData, function(x) 1-cor(x,method="pearson")[1,2]) Modified: pkg/demo/spCopula.R =================================================================== --- pkg/demo/spCopula.R 2013-11-19 08:57:27 UTC (rev 112) +++ pkg/demo/spCopula.R 2013-11-19 15:49:54 UTC (rev 113) @@ -85,11 +85,13 @@ meuseSpVine <- fitCopula(spVineCopula(spCop, vineCopula(as.integer(vineDim-1))), meuseNeigh) +# log-likelihood: +meuseSpVine at loglik + meuseSpVine <- meuseSpVine at copula ## # leave-one-out x-validation - time <- proc.time() # ~100 s predMedian <- NULL predMean <- NULL Modified: pkg/man/rankTransform.Rd =================================================================== --- pkg/man/rankTransform.Rd 2013-11-19 08:57:27 UTC (rev 112) +++ pkg/man/rankTransform.Rd 2013-11-19 15:49:54 UTC (rev 113) @@ -7,19 +7,14 @@ performs the rank order transformational } \usage{ -rankTransform(u, v = NULL, ties.method = "average") +rankTransform(u, v = NULL, na.last=TRUE, ties.method = "average") } \arguments{ - \item{u}{ -a matrix or data.frame with at least two columns holding the data or a vector holding the first column of the data + \item{u}{a matrix or data.frame with at least two columns holding the data or a vector holding the first column of the data} + \item{v}{a vector holding the second column of the data} + \item{na.last}{puts \code{NA}s last by default} + \item{ties.method}{How should ties be treated in \code{\link{rank}}?} } - \item{v}{ -a vector holding the second column of the data -} - \item{ties.method}{ -How should ties be treated in \code{\link{rank}}? -} -} \value{ A matrix or data.frame (as provided) with the transformed data. Rows containing any \code{NA} will be dropped. } Added: pkg/man/spGaussCopPredict.Rd =================================================================== --- pkg/man/spGaussCopPredict.Rd (rev 0) +++ pkg/man/spGaussCopPredict.Rd 2013-11-19 15:49:54 UTC (rev 113) @@ -0,0 +1,92 @@ +\name{spGaussCopPredict} +\alias{spGaussCopPredict} +\title{ +spatial prediction using a Gaussian Copula +} +\description{ +This function allows to do spatial prediction using a Gaussian Copula based on the spatial parametrization. +} +\usage{ +spGaussCopPredict(corFun, predNeigh, margin, p = 0.5, ..., n = 1000) +} + +\arguments{ + \item{corFun}{ +A valid correlogram (i.e. producing a valid correlation matrix; e.g. based on a variogram). +} + \item{predNeigh}{ +A \code{\linkS4class{neighbourhood}} object used for prediction. +} + \item{margin}{ +a list containing the marginal distribution. Currently only the entry \code{q} is required defining the quantile function. +} + \item{p}{ +the fraction the quantile function shall be evaluated for. This can be used to calculate besides the median estimate confidence estimates as well. +} + \item{\dots}{ +currently unused +} + \item{n}{ +the approximate number of points used in the linear approximation of the conditional distribution function. +} +} +\details{ +Based on \code{corFun} provided with a distance matrix a Gaussian copula (\code{\linkS4class{normalCopula}}) is generated and conditioned under the data of the neighbouring locations. The 1-dimensional conditional distribution is approximated and evaluated for the given fraction \code{p}. This conditioned fraction is than passed on to the marginal quantile function and evaluated providing an estimate. +} +\value{ +According to the \code{predLocs} slot of the provided \code{\linkS4class{neighbourhood}} a spatial data structure extended with an variable holding the predicted values. +} +\author{ +Benedikt Graeler +} + + +\seealso{ +\code{\link{spCopPredict}} +} +\examples{ +# load data from the Meuse demo +data(spCopDemo) + +# calculate the correlation function based on Kendall's tau +calcKTauPol <- fitCorFun(bins, degree=1) + +# translate Kendall's tau correlation function into Gaussian Copula parameters +# using a linear variogram +meuseGaussCorFun <- function(h) { + res <- pmax(iTau(normalCopula(0), calcKTauPol(0))/658*(658-h),0) + res[h ==0] <- 1 + return(res) +} + +# get some prediction data +library(sp) +data(meuse.grid) +coordinates(meuse.grid) <- ~x+y +gridded(meuse.grid) <- TRUE + +data(meuse) +coordinates(meuse) <- ~x+y + +meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1) + +# obtain the prediction neighbourhoods +predMeuseNeigh <- getNeighbours(meuse[1:4,], meuse.grid[c(9:12,16:19,25:28),], + "rtZinc", 5L, TRUE, -1) + +qMar <- function(x) { + qlnorm(x,mean(log(meuse$zinc)),sd(log(meuse$zinc))) +} + +# predict using the Gaussian Copula +predMedian <- spGaussCopPredict(meuseGaussCorFun, predMeuseNeigh, list(q=qMar)) + +\dontrun{ + spplot(predMedian,"quantile.0.5", + sp.layout=list("sp.points", meuse, pch = 19, col = "red"), + col.regions=bpy.colors()) +} +} + +\keyword{ prediction } +\keyword{ distribution } Added: pkg/man/spGaussLogLik.Rd =================================================================== --- pkg/man/spGaussLogLik.Rd (rev 0) +++ pkg/man/spGaussLogLik.Rd 2013-11-19 15:49:54 UTC (rev 113) @@ -0,0 +1,66 @@ +\name{spGaussLogLik} +\alias{spGaussLogLik} + +\title{ +Density evalaution for a spatial Gaussian Copula +} +\description{ +Evaluates the density for a spatial Gaussian Copula. +} +\usage{ +spGaussLogLik(corFun, neigh, log = T) +} + +\arguments{ + \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{log}{ +Should the log-likelihood be returned? +} +} +\details{ +Evaluates the density for all neioghbourhoods in \code{neigh} and returns the (log)-likelihood. +} +\value{ +The (log)-likelihood value. +} +\author{ +Benedikt Graeler +} + +\examples{ +library(spcopula) + +# load data from the Meuse demo +data(spCopDemo) + +# calculate the correlation function based on Kendall's tau +calcKTauPol <- fitCorFun(bins, degree=1) + +# translate Kendall's tau correlation function into Gaussian Copula parameters +# using a linear variogram +meuseGaussCorFun <- function(h) { + res <- pmax(iTau(normalCopula(0), calcKTauPol(0))/658*(658-h),0) + res[h ==0] <- 1 + return(res) +} + +# get the neighbours +library(sp) +data(meuse) +coordinates(meuse) <- ~x+y + +meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1) + +meuseNeigh <- getNeighbours(meuse, var="rtZinc", size=5L, + prediction=FALSE) + +# calculate the log-likelihood +spGaussLogLik(meuseGaussCorFun, meuseNeigh) +} + +\keyword{ distribution } From noreply at r-forge.r-project.org Wed Nov 20 10:20:38 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 Nov 2013 10:20:38 +0100 (CET) Subject: [spcopula-commits] r114 - pkg/R Message-ID: <20131120092038.A4FCF185606@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-20 10:20:38 +0100 (Wed, 20 Nov 2013) New Revision: 114 Modified: pkg/R/asCopula.R pkg/R/cqsCopula.R Log: - taking care of special cases in asCopula and cqsCopula (i.e. equal parameters) Modified: pkg/R/asCopula.R =================================================================== --- pkg/R/asCopula.R 2013-11-19 15:49:54 UTC (rev 113) +++ pkg/R/asCopula.R 2013-11-20 09:20:38 UTC (rev 114) @@ -79,7 +79,7 @@ u1 <- u[, 1] u2 <- u[, 2] - return( u1 + b*(-1 + u1)*u1*(-1 + 2*u2) - (a - b)*(-1 + u1)^2*u1*u2*(-2 + 3*u2)) + return( u1 + b*(u1-1)*u1*(2*u2-1) - (a - b)*(-1 + u1)^2*u1*u2*(-2 + 3*u2)) } setMethod("ddvCopula", signature("numeric", "asCopula"), @@ -94,56 +94,76 @@ ## inverse partial derivative invdduASC2 <- function (u, copula, y) { - if (length(u)!=length(y)) - stop("Length of u and y differ!") + stopifnot(length(u) == length(y)) a <- copula at parameters[1] b <- copula at parameters[2] -# solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 - usq <- u^2 - c3 <- (a-b)*(-3*usq+4*u-1) - c2 <- (a-b)*(1-4*u+3*usq)+b*(- 1 + 2*u) - c1 <- 1+b*(1-2*u) - c0 <- -y + if (a != b) { # the cubic case + # solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 + usq <- u^2 + c3 <- (a-b)*(-3*usq+4*u-1) + c2 <- (a-b)*(1-4*u+3*usq)+b*(- 1 + 2*u) + c1 <- 1+b*(1-2*u) + c0 <- -y - v <- solveCubicEq(c3,c2,c1,c0) # from cqsCopula.R - - filter <- function(vec) { - vec <- vec[!is.na(vec)] - return(vec[vec >= 0 & vec <= 1]) - } + v <- solveCubicEq(c3,c2,c1,c0) # from cqsCopula.R - return(apply(v,1,filter)) + filter <- function(vec) { + vec <- vec[!is.na(vec)] + return(vec[vec >= 0 & vec <= 1]) + } + + return(apply(v,1,filter)) + } + if(a==0) # and b==0 obvioulsy as well: the independent case + return(y) + + # the qudratic cases remain + v <- y + uR <- u[u != 0.5] + v[u != 0.5] <- (sqrt(4*y[u != 0.5]*(2*b*uR-b)+(-2*b*uR+b+1)^2)+2*b*uR-b-1)/(2*b*(2*uR-1)) + + return(v) } setMethod("invdduCopula", signature("numeric","asCopula","numeric"),invdduASC2) ## inverse partial derivative ddv invddvASC2 <- function (v, copula, y) { - if (length(v)!=length(y)) - stop("Length of v and y differ!") + stopifnot(length(v) == length(y)) - a <- copula at parameters[1] - b <- copula at parameters[2] - -# solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 + a <- copula at parameters[1] + b <- copula at parameters[2] + + if (a != b) { # the cubic case + # solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 vsq <- v^2 c3 <- (a-b)*(2*v-3*vsq) c2 <- (a-b)*(-4*v+6*vsq)+b*(-1+2*v) c1 <- 1+(a-b)*(2*v - 3*vsq)+b*(1-2*v) c0 <- -y -u <- solveCubicEq(c3,c2,c1,c0) # from cqsCopula.R + u <- solveCubicEq(c3,c2,c1,c0) # from cqsCopula.R -filter <- function(vec){ - vec <- vec[!is.na(vec)] - return(vec[vec >= 0 & vec <= 1]) + filter <- function(vec){ + vec <- vec[!is.na(vec)] + return(vec[vec >= 0 & vec <= 1]) + } + + return(apply(u,1,filter)) + } + if(a==0) # and b==0 obvioulsy as well: the independent case + return(y) + + # the qudratic cases remain + u <- y + vR <- v[v != 0.5] + u[v != 0.5] <- (sqrt(4*y[v != 0.5]*(2*b*vR-b)+(-2*b*vR+b+1)^2)+2*b*vR-b-1)/(2*b*(2*vR-1)) + + return(u) } -return(apply(u,1,filter)) -} - setMethod("invddvCopula", signature("numeric","asCopula","numeric"),invddvASC2) ## random number generator Modified: pkg/R/cqsCopula.R =================================================================== --- pkg/R/cqsCopula.R 2013-11-19 15:49:54 UTC (rev 113) +++ pkg/R/cqsCopula.R 2013-11-20 09:20:38 UTC (rev 114) @@ -118,26 +118,37 @@ ## inverse partial derivative ddu # seems to be accurate (1.4e-05 is the max out of 1000 random CQSec-copulas for 1000 random pairs (u,v) each.) invdduCQSec <- function (u, copula, y) { - stopifnot(length(u)==length(y)) + stopifnot(length(u) == length(y)) a <- copula at parameters[1] b <- copula at parameters[2] - # solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 - usq <- u^2 - c3 <- (b-a)*(1-4*u+3*usq) - c2 <- (b-a)*(-2+8*u-6*u^2)-b*(-1+2*u) - c1 <- (b-a)*(1-4*u+3*u^2)-b*(1-2*u)+1 - c0 <- -y - - v <- solveCubicEq(c3,c2,c1,c0) + if (a != b) { # the cubic case + # solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 + usq <- u^2 + c3 <- (b-a)*(1-4*u+3*usq) + c2 <- (b-a)*(-2+8*u-6*u^2)-b*(-1+2*u) + c1 <- (b-a)*(1-4*u+3*u^2)-b*(1-2*u)+1 + c0 <- -y - filter <- function(vec){ - vec <- vec[!is.na(vec)] - return(vec[vec >= 0 & vec <= 1]) + v <- solveCubicEq(c3,c2,c1,c0) + + filter <- function(vec){ + vec <- vec[!is.na(vec)] + return(vec[vec >= 0 & vec <= 1]) + } + + return(apply(v,1,filter)) } - - return(apply(v,1,filter)) + if(a==0) # and b==0 obvioulsy as well: the independent case + return(y) + + # the qudratic cases remain + v <- y + uR <- u[u != 0.5] + v[u != 0.5] <- (-sqrt((-2*b*uR+b-1)^2-4*y[u != 0.5]*(2*b*uR-b))+2*b*uR-b+1)/(2*b*(2*uR-1)) + + return(v) } setMethod("invdduCopula", signature("numeric","cqsCopula","numeric"), invdduCQSec) @@ -162,28 +173,38 @@ setMethod("ddvCopula", signature("matrix","cqsCopula"), ddvCQSec) ## inverse partial derivative ddv -# seems to be accurate (1e-05 is the max out of 5000 random CQSec-copulas for 1000 random pairs (u,v) each. Very most are below 10*.Machine$double.eps) invddvCQSec <- function (v, copula, y) { stopifnot(length(v)==length(y)) a <- copula at parameters[1] b <- copula at parameters[2] - # solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 - vsq <- v^2 - c3 <- (b-a)*(1-4*v+3*vsq) - c2 <- (b-a)*(-2+8*v-6*vsq)-b*(-1+2*v) - c1 <- (b-a)*(1-4*v+3*vsq)-b*(1-2*v)+1 - c0 <- -y - - u <- solveCubicEq(c3,c2,c1,c0) + if (a != b) { # the cubic case + # solving the cubic equation: u^3 * c3 + u^2 * c2 + u * c1 + c0 = 0 + vsq <- v^2 + c3 <- (b-a)*(1-4*v+3*vsq) + c2 <- (b-a)*(-2+8*v-6*vsq)-b*(-1+2*v) + c1 <- (b-a)*(1-4*v+3*vsq)-b*(1-2*v)+1 + c0 <- -y - filter <- function(vec){ - vec <- vec[!is.na(vec)] - return(vec[vec >= 0 & vec <= 1]) + u <- solveCubicEq(c3,c2,c1,c0) + + filter <- function(vec){ + vec <- vec[!is.na(vec)] + return(vec[vec >= 0 & vec <= 1]) + } + + return(apply(u,1,filter)) } - - return(apply(u,1,filter)) + if(a==0) # and b==0 obvioulsy as well: the independent case + return(y) + + # the qudratic cases remain + u <- y + vR <- v[v != 0.5] + u[v != 0.5] <- (-sqrt((-2*b*vR+b-1)^2-4*y[v != 0.5]*(2*b*vR-b))+2*b*vR-b+1)/(2*b*(2*vR-1)) + + return(u) } setMethod("invddvCopula", signature("numeric","cqsCopula","numeric"), invddvCQSec) From noreply at r-forge.r-project.org Wed Nov 20 16:27:22 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 Nov 2013 16:27:22 +0100 (CET) Subject: [spcopula-commits] r115 - in pkg: . R man Message-ID: <20131120152722.58A54185B76@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-20 16:27:22 +0100 (Wed, 20 Nov 2013) New Revision: 115 Removed: pkg/man/getNeighbours.experimental.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/BB7copula.R pkg/R/spatialPreparation.R Log: - made getNeighbours.experimental the "default" - corrected boundaries for r270BB7Copula Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2013-11-20 09:20:38 UTC (rev 114) +++ pkg/DESCRIPTION 2013-11-20 15:27:22 UTC (rev 115) @@ -2,12 +2,12 @@ Type: Package Title: copula driven spatial analysis Version: 0.1-1 -Date: 2013-11-19 +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")) Maintainer: Benedikt Graeler -Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of the spacetime package. Additionally, support for calculating different multivariate return periods is implemented. +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) Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2013-11-20 09:20:38 UTC (rev 114) +++ pkg/NAMESPACE 2013-11-20 15:27:22 UTC (rev 115) @@ -30,7 +30,7 @@ # export(setSizeLim) # spatial -export(getNeighbours,getNeighbours.experimental, getStNeighbours) +export(getNeighbours, getStNeighbours) export(calcBins) export(calcSpTreeDists, dropSpTree) Modified: pkg/R/BB7copula.R =================================================================== --- pkg/R/BB7copula.R 2013-11-20 09:20:38 UTC (rev 114) +++ pkg/R/BB7copula.R 2013-11-20 15:27:22 UTC (rev 115) @@ -225,7 +225,7 @@ 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, -1), + 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.") } Modified: pkg/R/spatialPreparation.R =================================================================== --- pkg/R/spatialPreparation.R 2013-11-20 09:20:38 UTC (rev 114) +++ pkg/R/spatialPreparation.R 2013-11-20 15:27:22 UTC (rev 115) @@ -58,49 +58,49 @@ # returns an neighbourhood object ################################## -getNeighbours <- function(dataLocs, predLocs, var=names(dataLocs)[1], size=5, - 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.") +# getNeighbours <- function(dataLocs, predLocs, var=names(dataLocs)[1], size=5, +# 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.") +# +# 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)) +# } +# - 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.experimental = function (dataLocs, predLocs, var = names(dataLocs)[1], size = 5, +getNeighbours <- function (dataLocs, predLocs, var = names(dataLocs)[1], size = 5, prediction = FALSE, min.dist = 0.01) { stopifnot((!prediction && missing(predLocs)) || (prediction && @@ -142,16 +142,6 @@ predLocs, prediction, var)) } - - - - - - - - - - ############# ## BINNING ## ############# Deleted: pkg/man/getNeighbours.experimental.Rd =================================================================== --- pkg/man/getNeighbours.experimental.Rd 2013-11-20 09:20:38 UTC (rev 114) +++ pkg/man/getNeighbours.experimental.Rd 2013-11-20 15:27:22 UTC (rev 115) @@ -1,49 +0,0 @@ -\name{getNeighbours.experimental} -\alias{getNeighbours.experimental} - -\title{ -Creating Local Neighbourhoods -} -\description{ -This function calculates a local neighbourhood to be used for fitting of spatial/spatio-temporal vine copulas and for prediction using spatial/spatio-temporal vine copulas. -} -\usage{ -getNeighbours.experimental(dataLocs, predLocs, var = names(dataLocs)[1], size = 5, -prediction=FALSE, min.dist = 0.01) -} -\arguments{ - \item{dataLocs}{ -some spatial data frame holding the data used for estimation/prediction -} - \item{predLocs}{ -A spatial object defining the prediction locations, might be missing if the neighbourhood is used for fitting. -} - \item{var}{ -the variable name of interest, by default the first variable is used. -} - \item{size}{ -The size of the neighbourhood including the location of interest (for fitting as well for prediction). -} - \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. -} -} -\value{ -An object of \code{\linkS4class{neighbourhood}}. -} -\author{ -Benedikt Graeler -} - -\seealso{ -See \code{\link{neighbourhood}} for the native constructor of a \code{\linkS4class{neighbourhood}} class. -} -\examples{ -library(sp) -spdf <- data.frame(x=c(112,154,212,289,345),y=c(124,198,85,168,346),measure=rlnorm(5)) -coordinates(spdf) <- ~x+y - -getNeighbours.experimental(spdf,size=4) -} -\keyword{ spatial } \ No newline at end of file From noreply at r-forge.r-project.org Tue Nov 26 14:37:31 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 26 Nov 2013 14:37:31 +0100 (CET) Subject: [spcopula-commits] r116 - in pkg: . R man Message-ID: <20131126133731.651451861BD@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-26 14:37:30 +0100 (Tue, 26 Nov 2013) New Revision: 116 Added: pkg/R/tawnCopula.R pkg/man/tawnT1Copula-class.Rd pkg/man/tawnT1Copula.Rd pkg/man/tawnT2Copula-class.Rd pkg/man/tawnT2Copula.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/linkingVineCopula.R pkg/man/BB1Copula.Rd Log: - added support for the two types of Tawn Copulas recently implemented in VineCopula Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2013-11-20 15:27:22 UTC (rev 115) +++ pkg/DESCRIPTION 2013-11-26 13:37:30 UTC (rev 116) @@ -38,4 +38,5 @@ utilities.R returnPeriods.R spatialGaussianCopula.R + tawnCopula.R zzz.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2013-11-20 15:27:22 UTC (rev 115) +++ pkg/NAMESPACE 2013-11-26 13:37:30 UTC (rev 116) @@ -11,6 +11,8 @@ export(joeBiCopula, surJoeBiCopula, r90JoeBiCopula, r270JoeBiCopula) export(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula) export(surGumbelCopula, r90GumbelCopula, r270GumbelCopula) +export(tawnT1Copula, surTawnT1Copula, r90TawnT1Copula, r270TawnT1Copula) +export(tawnT2Copula, surTawnT2Copula, r90TawnT2Copula, r270TawnT2Copula) export(spCopula, stCopula) export(vineCopula, spVineCopula, stVineCopula) export(neighbourhood, stNeighbourhood) Modified: pkg/R/linkingVineCopula.R =================================================================== --- pkg/R/linkingVineCopula.R 2013-11-20 15:27:22 UTC (rev 115) +++ pkg/R/linkingVineCopula.R 2013-11-26 13:37:30 UTC (rev 116) @@ -1,21 +1,45 @@ copulaFromFamilyIndex <- function(family, par, par2=0) { - constr <- switch(family+1, function(par) indepCopula(), - function(par) normalCopula(par[1]), function(par) tCopula(par[1],df=par[2]), - function(par) claytonCopula(par[1]), function(par) gumbelCopula(par[1]), - function(par) frankCopula(par[1]), function(par) joeBiCopula(par[1]), - BB1Copula, BB6Copula, BB7Copula, BB8Copula, - NULL, NULL, - function(par) surClaytonCopula(par[1]), function(par) surGumbelCopula(par[1]), - NULL, function(par) surJoeBiCopula(par[1]), - surBB1Copula, surBB6Copula, surBB7Copula, surBB8Copula, - NULL, NULL, - function(par) r90ClaytonCopula(par[1]), function(par) r90GumbelCopula(par[1]), - NULL, function(par) r90JoeBiCopula(par[1]), - r90BB1Copula, r90BB6Copula, r90BB7Copula, r90BB8Copula, - NULL, NULL, - function(par) r270ClaytonCopula(par[1]), function(par) r270GumbelCopula(par[1]), - NULL, function(par) r270JoeBiCopula(par[1]), - r270BB1Copula, r270BB6Copula, r270BB7Copula, r270BB8Copula) + constr <- switch(paste("fam",family,sep=""), + fam0 = function(par) indepCopula(), + fam1 = function(par) normalCopula(par[1]), + fam2 = function(par) tCopula(par[1],df=par[2]), + fam3 = function(par) claytonCopula(par[1]), + fam4 = function(par) gumbelCopula(par[1]), + fam5 = function(par) frankCopula(par[1]), + fam6 = function(par) joeBiCopula(par[1]), + fam7 = BB1Copula, + fam8 = BB6Copula, + fam9 = BB7Copula, + fam10 = BB8Copula, + fam13 = function(par) surClaytonCopula(par[1]), + fam14 = function(par) surGumbelCopula(par[1]), + fam16 = function(par) surJoeBiCopula(par[1]), + fam17 = surBB1Copula, + fam18 = surBB6Copula, + fam19 = surBB7Copula, + fam20 = surBB8Copula, + fam23 = function(par) r90ClaytonCopula(par[1]), + fam24 = function(par) r90GumbelCopula(par[1]), + fam26 = function(par) r90JoeBiCopula(par[1]), + fam27 = r90BB1Copula, + fam28 = r90BB6Copula, + fam29 = r90BB7Copula, + fam30 = r90BB8Copula, + fam33 = function(par) r270ClaytonCopula(par[1]), + fam34 = function(par) r270GumbelCopula(par[1]), + fam36 = function(par) r270JoeBiCopula(par[1]), + fam37 = r270BB1Copula, + fam38 = r270BB6Copula, + fam39 = r270BB7Copula, + fam40 = r270BB8Copula, + fam104 = tawnT1Copula, + fam114 = surTawnT1Copula, + fam124 = r90TawnT1Copula, + fam134 = r270TawnT1Copula, + fam204 = tawnT2Copula, + fam214 = surTawnT2Copula, + fam224 = r90TawnT2Copula, + fam234 = r270TawnT2Copula) constr(c(par,par2)) } Added: pkg/R/tawnCopula.R =================================================================== --- pkg/R/tawnCopula.R (rev 0) +++ pkg/R/tawnCopula.R 2013-11-26 13:37:30 UTC (rev 116) @@ -0,0 +1,456 @@ +######################### +## ## +## Tawn type 1 copulas ## +## ## +######################### + +validTawnCopula = function(object) { + if (object at dimension != 2) + return("Only Tawn 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("tawnT1Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +tawnT1Copula <- function (param=c(2,0.5)) { + if (any(is.na(param) | param < c(1,0) | param[1] == Inf | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("tawnT1Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(1, 0), param.upbnd = c(Inf, 1), + family=104, fullname = "Tawn type 1 copula family. Number 104 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","tawnT1Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","tawnT1Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","tawnT1Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","tawnT1Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","tawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","tawnT1Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","tawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","tawnT1Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","tawnT1Copula"), linkVineCop.r) + +setMethod("tau",signature("tawnT1Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("tawnT1Copula"),linkVineCop.tailIndex) + +################################# +## Tawn type 1 survival copula ## +################################# + +setClass("surTawnT1Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +surTawnT1Copula <- function (param=c(2,0.5)) { + if (any(is.na(param) | param < c(1,0) | param[1] == Inf | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("surTawnT1Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(1, 0), param.upbnd = c(Inf, 1), + family=114, fullname = "Survival Tawn type 1 copula family. Number 114 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","surTawnT1Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","surTawnT1Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","surTawnT1Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","surTawnT1Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","surTawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","surTawnT1Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","surTawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","surTawnT1Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","surTawnT1Copula"), linkVineCop.r) + +setMethod("tau",signature("surTawnT1Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("surTawnT1Copula"),linkVineCop.tailIndex) + +####################################### +## Tawn type 1 90 deg. rotate copula ## +####################################### + +setClass("r90TawnT1Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +r90TawnT1Copula <- function (param=c(-2, 0.5)) { + if (any(is.na(param) | param[1] == -Inf | param[1] > -1 | param[2] < 0 | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("r90TawnT1Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(-Inf, 0), param.upbnd = c(-1, 1), + family=124, fullname = "Survival Tawn type 1 copula family. Number 124 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","r90TawnT1Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","r90TawnT1Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","r90TawnT1Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","r90TawnT1Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","r90TawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","r90TawnT1Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","r90TawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","r90TawnT1Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","r90TawnT1Copula"), linkVineCop.r) + +setMethod("tau",signature("r90TawnT1Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("r90TawnT1Copula"),linkVineCop.tailIndex) + +######################################## +## Tawn type 1 270 deg. rotate copula ## +######################################## + +setClass("r270TawnT1Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +r270TawnT1Copula <- function (param=c(-2, 0.5)) { + if (any(is.na(param) | param[1] == -Inf | param[1] > -1 | param[2] < 0 | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("r270TawnT1Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(-Inf, 0), param.upbnd = c(-1, 1), + family=134, fullname = "Survival Tawn type 1 copula family. Number 134 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","r270TawnT1Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","r270TawnT1Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","r270TawnT1Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","r270TawnT1Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","r270TawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","r270TawnT1Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","r270TawnT1Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","r270TawnT1Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","r270TawnT1Copula"), linkVineCop.r) + +setMethod("tau",signature("r270TawnT1Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("r270TawnT1Copula"),linkVineCop.tailIndex) + +######################### +## ## +## Tawn type 2 copulas ## +## ## +######################### + +setClass("tawnT2Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +tawnT2Copula <- function (param=c(2,0.5)) { + if (any(is.na(param) | param < c(1,0) | param[1] == Inf | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("tawnT2Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(1, 0), param.upbnd = c(Inf, 1), + family=204, fullname = "Tawn type 2 copula family. Number 204 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","tawnT2Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","tawnT2Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","tawnT2Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","tawnT2Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","tawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","tawnT2Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","tawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","tawnT2Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","tawnT2Copula"), linkVineCop.r) + +setMethod("tau",signature("tawnT2Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("tawnT2Copula"),linkVineCop.tailIndex) + +################################# +## Tawn type 1 survival copula ## +################################# + +setClass("surTawnT2Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +surTawnT2Copula <- function (param=c(2,0.5)) { + if (any(is.na(param) | param < c(1,0) | param[1] == Inf | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("surTawnT2Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(1, 0), param.upbnd = c(Inf, 1), + family=214, fullname = "Survival Tawn type 2 copula family. Number 214 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","surTawnT2Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","surTawnT2Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","surTawnT2Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","surTawnT2Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","surTawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","surTawnT2Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","surTawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","surTawnT2Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","surTawnT2Copula"), linkVineCop.r) + +setMethod("tau",signature("surTawnT2Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("surTawnT2Copula"),linkVineCop.tailIndex) + +####################################### +## Tawn type 1 90 deg. rotate copula ## +####################################### + +setClass("r90TawnT2Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +r90TawnT2Copula <- function (param=c(-2, 0.5)) { + if (any(is.na(param) | param[1] == -Inf | param[1] > -1 | param[2] < 0 | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("r90TawnT2Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(-Inf, 0), param.upbnd = c(-1, 1), + family=224, fullname = "Survival Tawn type 2 copula family. Number 224 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","r90TawnT2Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","r90TawnT2Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","r90TawnT2Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","r90TawnT2Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","r90TawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","r90TawnT2Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","r90TawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","r90TawnT2Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","r90TawnT2Copula"), linkVineCop.r) + +setMethod("tau",signature("r90TawnT2Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("r90TawnT2Copula"),linkVineCop.tailIndex) + +######################################## +## Tawn type 1 270 deg. rotate copula ## +######################################## + +setClass("r270TawnT2Copula", + representation = representation("copula", family="numeric"), + validity = validTawnCopula, + contains = list("copula") +) + +# constructor +r270TawnT2Copula <- function (param=c(-2, 0.5)) { + if (any(is.na(param) | param[1] == -Inf | param[1] > -1 | param[2] < 0 | param[2] > 1)) + stop(paste("Parameter values out of bounds: param1: [1,Inf), param2: [0,1].")) + new("r270TawnT2Copula", dimension = as.integer(2), parameters = param, + param.names = c("param1", "param2"), param.lowbnd = c(-Inf, 0), param.upbnd = c(-1, 1), + family=234, fullname = "Survival Tawn type 2 copula family. Number 234 in VineCopula.") +} + +## density ## +setMethod("dCopula", signature("numeric","r270TawnT2Copula"), + function(u, copula, log) { + linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log) + }) +setMethod("dCopula", signature("matrix","r270TawnT2Copula"), + function(u, copula, log) linkVineCop.PDF(u, copula, log)) + +## jcdf ## +setMethod("pCopula", signature("numeric","r270TawnT2Copula"), + function(u, copula, ...) { + linkVineCop.CDF(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("pCopula", signature("matrix","r270TawnT2Copula"), linkVineCop.CDF) + +## partial derivatives ## +# ddu +setMethod("dduCopula", signature("numeric","r270TawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("dduCopula", signature("matrix","r270TawnT2Copula"), linkVineCop.ddu) + +# ddv +setMethod("ddvCopula", signature("numeric","r270TawnT2Copula"), + function(u, copula, ...) { + linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula) + }) +setMethod("ddvCopula", signature("matrix","r270TawnT2Copula"), linkVineCop.ddv) + +## random number generator +setMethod("rCopula", signature("numeric","r270TawnT2Copula"), linkVineCop.r) + +setMethod("tau",signature("r270TawnT2Copula"),linkVineCop.tau) +setMethod("tailIndex",signature("r270TawnT2Copula"),linkVineCop.tailIndex) Modified: pkg/man/BB1Copula.Rd =================================================================== --- pkg/man/BB1Copula.Rd 2013-11-20 15:27:22 UTC (rev 115) +++ pkg/man/BB1Copula.Rd 2013-11-26 13:37:30 UTC (rev 116) @@ -5,10 +5,10 @@ \alias{r270BB1Copula} \title{ -Constructor of the BB1 family and its derivatives +Constructor of the BB1 family and rotated versions thereof } \description{ -Constructs an object of the \code{\linkS4class{BB1Copula}} (survival \code{sur}, 90 degree rotated \code{r90} and 270 degree rotated \code{r270}) family for a given parameter. +Constructs an object of the \code{\linkS4class{BB1Copula}} (survival \code{sur}, 90 degree rotated \code{r90} and 270 degree rotated \code{r270}) family for given parameters. } \usage{ BB1Copula(param) @@ -39,4 +39,7 @@ persp(surBB1Copula(c(1,1.5)),dCopula, zlim=c(0,10)) persp(r90BB1Copula(c(-1,-1.5)),dCopula, zlim=c(0,10)) persp(r270BB1Copula(c(-1,-1.5)),dCopula, zlim=c(0,10)) -} \ No newline at end of file +} + +\keyword{ distribution } +\keyword{ copula } Added: pkg/man/tawnT1Copula-class.Rd =================================================================== --- pkg/man/tawnT1Copula-class.Rd (rev 0) +++ pkg/man/tawnT1Copula-class.Rd 2013-11-26 13:37:30 UTC (rev 116) @@ -0,0 +1,76 @@ +\name{tawnT1Copula-class} +\Rdversion{1.1} +\docType{class} +\alias{tawnT1Copula-class} +\alias{dduCopula,matrix,tawnT1Copula-method} +\alias{dduCopula,numeric,tawnT1Copula-method} +\alias{ddvCopula,matrix,tawnT1Copula-method} +\alias{ddvCopula,numeric,tawnT1Copula-method} + +\alias{surTawnT1Copula-class} +\alias{dduCopula,matrix,surTawnT1Copula-method} +\alias{dduCopula,numeric,surTawnT1Copula-method} +\alias{ddvCopula,matrix,surTawnT1Copula-method} +\alias{ddvCopula,numeric,surTawnT1Copula-method} + +\alias{r90TawnT1Copula-class} +\alias{dduCopula,matrix,r90TawnT1Copula-method} +\alias{dduCopula,numeric,r90TawnT1Copula-method} +\alias{ddvCopula,matrix,r90TawnT1Copula-method} +\alias{ddvCopula,numeric,r90TawnT1Copula-method} + +\alias{r270TawnT1Copula-class} +\alias{dduCopula,matrix,r270TawnT1Copula-method} +\alias{dduCopula,numeric,r270TawnT1Copula-method} +\alias{ddvCopula,matrix,r270TawnT1Copula-method} +\alias{ddvCopula,numeric,r270TawnT1Copula-method} + +\title{Class \code{"tawnT1Copula"}} +\description{ +S4-class representation of the Tawn Copula family of type 1 and rotated versions there of. +} +\section{Objects from the Class}{ +Objects can be created by calls of the form \code{new("tawnT1Copula", ...)}, or through the explicit constructors \code{\link{tawnT1Copula}}, \code{\link{surTawnT1Copula}}, \code{\link{r90TawnT1Copula}} and \code{\link{r270TawnT1Copula}} respectively.} + +\section{Slots}{ + \describe{ + \item{\code{family}:}{Object of class \code{"numeric"} providing the unique number in VineCopula.} + \item{\code{dimension}:}{Object of class \code{"integer"} and fixed to \code{2L}.} + \item{\code{parameters}:}{Object of class \code{"numeric"} representing the two parameters.} + \item{\code{param.names}:}{Object of class \code{"character"} providing the names of the parameters.} + \item{\code{param.lowbnd}:}{Object of class \code{"numeric"} providing the lower bounds of the parameters.} + \item{\code{param.upbnd}:}{Object of class \code{"numeric"} providing the upper bounds of the parameters.} + \item{\code{fullname}:}{Object of class \code{"character"} providing a textual summary of the copula class.} + } +} +\section{Extends}{ +Class \code{"\linkS4class{copula}"}, directly. +Class \code{"\linkS4class{Copula}"}, by class "copula", distance 2. +} +\section{Methods}{ + \describe{ + \item{dCopula}{\code{signature(u = "matrix", copula = "tawnT1Copula")}: ... } + \item{dCopula}{\code{signature(u = "numeric", copula = "tawnT1Copula")}: ... } + \item{dduCopula}{\code{signature(u = "matrix", copula = "tawnT1Copula")}: ... } + \item{dduCopula}{\code{signature(u = "numeric", copula = "tawnT1Copula")}: ... } + \item{ddvCopula}{\code{signature(u = "matrix", copula = "tawnT1Copula")}: ... } + \item{ddvCopula}{\code{signature(u = "numeric", copula = "tawnT1Copula")}: ... } + \item{pCopula}{\code{signature(u = "matrix", copula = "tawnT1Copula")}: ... } + \item{pCopula}{\code{signature(u = "numeric", copula = "tawnT1Copula")}: ... } + \item{rCopula}{\code{signature(n = "numeric", copula = "tawnT1Copula")}: ... } + \item{tailIndex}{\code{signature(copula = "tawnT1Copula")}: ... } + \item{tau}{\code{signature(copula = "tawnT1Copula")}: ... } + } +} + +\author{ +Benedikt Graeler +} + +\seealso{ +\code{\linkS4class{tawnT2Copula}} and the package \code{\link{VineCopula-package}} for implementation details. +} +\examples{ +showClass("tawnT1Copula") +} +\keyword{classes} Added: pkg/man/tawnT1Copula.Rd =================================================================== --- pkg/man/tawnT1Copula.Rd (rev 0) +++ pkg/man/tawnT1Copula.Rd 2013-11-26 13:37:30 UTC (rev 116) @@ -0,0 +1,44 @@ +\name{tawnT1Copula} +\alias{tawnT1Copula} +\alias{surTawnT1Copula} +\alias{r90TawnT1Copula} +\alias{r270TawnT1Copula} + +\title{ +Constructor of the Tawn type 1 family and rotated versions thereof +} +\description{ +Constructs an object of the \code{\linkS4class{tawnT1Copula}} (survival \code{sur}, 90 degree rotated \code{r90} and 270 degree rotated \code{r270}) family for given parameters. +} +\usage{ +tawnT1Copula(param = c(2, 0.5)) +surTawnT1Copula(param = c(2, 0.5)) +r90TawnT1Copula(param = c(-2, 0.5)) +r270TawnT1Copula(param = c(-2, 0.5)) +} + +\arguments{ + \item{param}{ +The parameter \code{param} defines the copula through \code{param1} and \code{param2}. +} +} + +\value{ +One of the Tawn type 1 copula classes (\code{\linkS4class{tawnT1Copula}}, \code{\linkS4class{surTawnT1Copula}}, \code{\linkS4class{r90TawnT1Copula}}, \code{\linkS4class{r270TawnT1Copula}}). +} + +\author{ +Benedikt Graeler +} + +\seealso{ +\code{\link{tawnT2Copula}} and the package \code{\link{VineCopula-package}} for implementation details. +} +\examples{ +persp(tawnT1Copula(),dCopula, zlim=c(0,10)) +persp(surTawnT1Copula(),dCopula, zlim=c(0,10)) +persp(r90TawnT1Copula(),dCopula, zlim=c(0,10)) +persp(r270TawnT1Copula(),dCopula, zlim=c(0,10)) +} +\keyword{ distribution } +\keyword{ copula } Added: pkg/man/tawnT2Copula-class.Rd =================================================================== --- pkg/man/tawnT2Copula-class.Rd (rev 0) +++ pkg/man/tawnT2Copula-class.Rd 2013-11-26 13:37:30 UTC (rev 116) @@ -0,0 +1,76 @@ +\name{tawnT2Copula-class} +\Rdversion{1.1} +\docType{class} +\alias{tawnT2Copula-class} +\alias{dduCopula,matrix,tawnT2Copula-method} +\alias{dduCopula,numeric,tawnT2Copula-method} +\alias{ddvCopula,matrix,tawnT2Copula-method} +\alias{ddvCopula,numeric,tawnT2Copula-method} + +\alias{surTawnT2Copula-class} +\alias{dduCopula,matrix,surTawnT2Copula-method} +\alias{dduCopula,numeric,surTawnT2Copula-method} +\alias{ddvCopula,matrix,surTawnT2Copula-method} +\alias{ddvCopula,numeric,surTawnT2Copula-method} + +\alias{r90TawnT2Copula-class} +\alias{dduCopula,matrix,r90TawnT2Copula-method} +\alias{dduCopula,numeric,r90TawnT2Copula-method} +\alias{ddvCopula,matrix,r90TawnT2Copula-method} +\alias{ddvCopula,numeric,r90TawnT2Copula-method} + +\alias{r270TawnT2Copula-class} +\alias{dduCopula,matrix,r270TawnT2Copula-method} +\alias{dduCopula,numeric,r270TawnT2Copula-method} +\alias{ddvCopula,matrix,r270TawnT2Copula-method} +\alias{ddvCopula,numeric,r270TawnT2Copula-method} + +\title{Class \code{"tawnT2Copula"}} +\description{ +S4-class representation of the Tawn Copula family of type 2 and rotated versions there of. +} +\section{Objects from the Class}{ +Objects can be created by calls of the form \code{new("tawnT2Copula", ...)}, or through the explicit constructors \code{\link{tawnT2Copula}}, \code{\link{surTawnT2Copula}}, \code{\link{r90TawnT2Copula}} and \code{\link{r270TawnT2Copula}} respectively. +} +\section{Slots}{ + \describe{ + \item{\code{family}:}{Object of class \code{"numeric"} providing the unique number in VineCopula.} + \item{\code{dimension}:}{Object of class \code{"integer"} and fixed to \code{2L}.} + \item{\code{parameters}:}{Object of class \code{"numeric"} representing the two parameters.} + \item{\code{param.names}:}{Object of class \code{"character"} providing the names of the parameters.} + \item{\code{param.lowbnd}:}{Object of class \code{"numeric"} providing the lower bounds of the parameters.} + \item{\code{param.upbnd}:}{Object of class \code{"numeric"} providing the upper bounds of the parameters.} + \item{\code{fullname}:}{Object of class \code{"character"} providing a textual summary of the copula class.} + } +} +\section{Extends}{ +Class \code{"\linkS4class{copula}"}, directly. +Class \code{"\linkS4class{Copula}"}, by class "copula", distance 2. +} +\section{Methods}{ + \describe{ + \item{dCopula}{\code{signature(u = "matrix", copula = "tawnT2Copula")}: ... } + \item{dCopula}{\code{signature(u = "numeric", copula = "tawnT2Copula")}: ... } + \item{dduCopula}{\code{signature(u = "matrix", copula = "tawnT2Copula")}: ... } + \item{dduCopula}{\code{signature(u = "numeric", copula = "tawnT2Copula")}: ... } + \item{ddvCopula}{\code{signature(u = "matrix", copula = "tawnT2Copula")}: ... } + \item{ddvCopula}{\code{signature(u = "numeric", copula = "tawnT2Copula")}: ... } + \item{pCopula}{\code{signature(u = "matrix", copula = "tawnT2Copula")}: ... } + \item{pCopula}{\code{signature(u = "numeric", copula = "tawnT2Copula")}: ... } + \item{rCopula}{\code{signature(n = "numeric", copula = "tawnT2Copula")}: ... } + \item{tailIndex}{\code{signature(copula = "tawnT2Copula")}: ... } + \item{tau}{\code{signature(copula = "tawnT2Copula")}: ... } + } +} + +\author{ +Benedikt Graeler +} + +\seealso{ +\code{\linkS4class{tawnT1Copula}} and the package \code{\link{VineCopula-package}} for implementation details. +} +\examples{ +showClass("tawnT2Copula") +} +\keyword{classes} Added: pkg/man/tawnT2Copula.Rd =================================================================== --- pkg/man/tawnT2Copula.Rd (rev 0) +++ pkg/man/tawnT2Copula.Rd 2013-11-26 13:37:30 UTC (rev 116) @@ -0,0 +1,44 @@ +\name{tawnT2Copula} +\alias{tawnT2Copula} +\alias{surTawnT2Copula} [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 116 From noreply at r-forge.r-project.org Wed Nov 27 16:21:32 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 27 Nov 2013 16:21:32 +0100 (CET) Subject: [spcopula-commits] r117 - pkg/R Message-ID: <20131127152132.65CC91801C7@r-forge.r-project.org> Author: ben_graeler Date: 2013-11-27 16:21:31 +0100 (Wed, 27 Nov 2013) New Revision: 117 Modified: pkg/R/spVineCopula.R Log: - adopted dSpvine for new neighbourhood index structure Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2013-11-26 13:37:30 UTC (rev 116) +++ pkg/R/spVineCopula.R 2013-11-27 15:21:31 UTC (rev 117) @@ -102,7 +102,7 @@ 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,spTree+i)],1, + h1 <- cbind(h1,apply(data at index[,c(spTree+1,spTree+i+1)],1, function(x) spDists(data at dataLocs[x,])[1,2])) } }