From noreply at r-forge.r-project.org Mon Mar 17 14:57:06 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 17 Mar 2014 14:57:06 +0100 (CET) Subject: [spcopula-commits] r129 - / pkg/R pkg/man Message-ID: <20140317135706.5D3131865EF@r-forge.r-project.org> Author: ben_graeler Date: 2014-03-17 14:57:05 +0100 (Mon, 17 Mar 2014) New Revision: 129 Added: pkg/man/loglikByCopulasStLags.Rd Modified: / pkg/R/utilities.R Log: - new function loglikByCopulasStLags Property changes on: ___________________________________________________________________ Modified: svn:ignore - .Rd2pdf6724 .Rhistory .Rproj.user Meuse_spcopula_estimation.R pkg.Rcheck pkg.pdf spcopula.Rcheck spcopula.Rproj + .Rd2pdf6724 .Rhistory .Rproj.user Meuse_spcopula_estimation.R pkg.Rcheck pkg.pdf spcopula.Rcheck spcopula.Rproj spCopDemo_old_Mar_2013.RData .RData inst Modified: pkg/R/utilities.R =================================================================== --- pkg/R/utilities.R 2014-02-21 14:27:50 UTC (rev 128) +++ pkg/R/utilities.R 2014-03-17 13:57:05 UTC (rev 129) @@ -18,7 +18,7 @@ ## dependencePlot <- function(var=NULL, smpl, bandwidth=0.075, - main="Stength of dependece", + main="Stength of dependence", transformation=function (x) x, ...) { if(is.null(var)) { if (ncol(smpl)>2) { Added: pkg/man/loglikByCopulasStLags.Rd =================================================================== --- pkg/man/loglikByCopulasStLags.Rd (rev 0) +++ pkg/man/loglikByCopulasStLags.Rd 2014-03-17 13:57:05 UTC (rev 129) @@ -0,0 +1,48 @@ +\name{loglikByCopulasStLags} +\alias{loglikByCopulasStLags} + +\title{Log-likelihoods by copula family and spatio-temporal lag class} + +\description{This function works through a set of copula family and evaluates the best fitting one for each spatiao-temporal lag.} + +\usage{ +loglikByCopulasStLags(stBins, data, families = c(normalCopula(), + tCopula(), + claytonCopula(), + frankCopula(), + gumbelCopula()), + calcCor, lagSub = 1:length(stBins$meanDists)) +} + +\arguments{ + \item{stBins}{a spatio-temporal bining typically prodsuced with \code{\link{calcBins}}.} + \item{data}{the spatial data set used to derive the bins from for data retrieval.} + \item{families}{A vector of representatives of the bivariate copula families that should be investigated.} + \item{calcCor}{a two place function tuning the copulas' parameters. Typically, the output of the \code{\link{fitCorFun}} function. Its either based on Kendall's tau, Spearman's rho or the identity. This parameter might be "missing" for static convex spatial copulas.} + \item{lagSub}{A set of indices indicating which of the bins to use.} +} + +\value{A list containing the result of \code{\link{loglikByCopulasLags}} per temporal lag: i.e. a list containing a matrix (\code{loglik}) of spatial lags (rows) and copula family names (columns) holding the calculated log-likelihood value and a list of the corresponding copula fits.} + +\author{Benedikt Graeler} + +\seealso{\code{\link{calcBins}}, \code{\link{loglikByCopulasLags}}} + +\examples{ +# the spatial case +# load spatial data +library(sp) +data(meuse) +coordinates(meuse) <- ~x+y + +# drop margins +meuse$marZinc <- plnorm(meuse$zinc, mean(log(meuse$zinc)), sd(log(meuse$zinc))) + +# load parts of the workspace from demo(spCopula) +data(spCopDemo) + +calcKTauPol <- fitCorFun(bins, degree=3) + +loglikTau <- loglikByCopulasLags(bins, meuse, calcCor=calcKTauPol) +loglikTau$loglik +} From noreply at r-forge.r-project.org Tue Mar 18 10:32:19 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 18 Mar 2014 10:32:19 +0100 (CET) Subject: [spcopula-commits] r130 - in pkg: R man Message-ID: <20140318093219.E312F186D6B@r-forge.r-project.org> Author: ben_graeler Date: 2014-03-18 10:32:19 +0100 (Tue, 18 Mar 2014) New Revision: 130 Modified: pkg/R/partialDerivatives.R pkg/R/spCopula.R pkg/man/dependencePlot.Rd pkg/man/invdduCopula-methods.Rd pkg/man/invddvCopula-methods.Rd Log: - add invddu and inddv methods for bivariate spatial copulas Modified: pkg/R/partialDerivatives.R =================================================================== --- pkg/R/partialDerivatives.R 2014-03-17 13:57:05 UTC (rev 129) +++ pkg/R/partialDerivatives.R 2014-03-18 09:32:19 UTC (rev 130) @@ -6,7 +6,7 @@ ## inverse partial derivatives # numerical standard function -invdduCopula <- function(u, copula, y, tol=.Machine$double.eps^0.5) { +invdduCopula <- function(u, copula, y, ..., tol=.Machine$double.eps^0.5) { if (length(u) != length(y)) stop("Length of u and y differ!") message("Numerical evaluation of invddu takes place.") @@ -21,7 +21,7 @@ setGeneric("invdduCopula") -invddvCopula <- function(v, copula, y, tol=.Machine$double.eps^0.5) { +invddvCopula <- function(v, copula, y, ..., tol=.Machine$double.eps^0.5) { if (length(v) != length(y)) stop("Length of v and y differ!") message("Numerical evaluation of invddv takes place.") Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2014-03-17 13:57:05 UTC (rev 129) +++ pkg/R/spCopula.R 2014-03-18 09:32:19 UTC (rev 130) @@ -358,10 +358,34 @@ setMethod("dduCopula", signature("numeric","spCopula"), function(u, copula, ...) dduSpCopula(matrix(u,ncol=copula at dimension),copula, ...) ) +invdduSpCopula <- function(u, copula, y, h, tol=.Machine$double.eps^0.5) { + message("invdduCopula is numerically evalauted.") + + nElem <- length(u) + stopifnot(nElem == length(y)) + stopifnot(length(h) == 1 | length(h)==nElem) + + optFun <- function(u, v, y, h) abs(dduSpCopula(cbind(rep(u, length(v)), v), copula, h)-y) + + optMe <- function(aU, aY, aH) optimise(function(v) optFun(u=aU, v, y=aY, h=aH), c(0,1))$minimum + + if(length(h) == 1 & nElem > 1) + h <- rep(h, nElem) + + rV <- numeric(nElem) + for (i in 1:nElem) { + rV[i] <- optMe(u[i], y[i], h[i]) + } + + return(rV) +} + +setMethod("invdduCopula", signature("numeric", "spCopula"), invdduSpCopula) + ## ddvSpCopula ############### -ddvSpCopula <- function (u, copula, h, block=1) { +ddvSpCopula <- function (u, copula, h) { if (missing(h)) stop("Point pairs need to be provided with their separating distance h.") if(length(h)>1 && length(h)!=nrow(u)) @@ -389,7 +413,31 @@ setMethod("ddvCopula", signature("numeric","spCopula"), function(u, copula, ...) ddvSpCopula(matrix(u,ncol=copula at dimension),copula, ...) ) +invddvSpCopula <- function(v, copula, y, h, tol=.Machine$double.eps^0.5) { + message("invddvCopula is numerically evalauted.") + + nElem <- length(v) + stopifnot(nElem == length(y)) + stopifnot(length(h) == 1 | length(h)==nElem) + + optFun <- function(u, v, y, h) abs(ddvSpCopula(cbind(u, rep(v, length(u))), copula, h)-y) + + optMe <- function(aV, aY, aH) optimise(function(u) optFun(u, v=aV, y=aY, h=aH), c(0,1))$minimum + + if(length(h) == 1 & nElem > 1) + h <- rep(h, nElem) + + rU <- numeric(nElem) + for (i in 1:nElem) { + rU[i] <- optMe(v[i], y[i], h[i]) + } + + return(rU) +} +setMethod("invddvCopula", signature("numeric", "spCopula"), invddvSpCopula) + + ############# ## ## ## FITTING ## Modified: pkg/man/dependencePlot.Rd =================================================================== --- pkg/man/dependencePlot.Rd 2014-03-17 13:57:05 UTC (rev 129) +++ pkg/man/dependencePlot.Rd 2014-03-18 09:32:19 UTC (rev 130) @@ -7,7 +7,7 @@ Plots a kernel smoothed scatter plot of the provided rank-transformed sample. The work is done by the function \code{\link{panel.smoothScatter}}. } \usage{ -dependencePlot(var = NULL, smpl, bandwidth = 0.075, main="Stength of dependece", +dependencePlot(var = NULL, smpl, bandwidth = 0.075, main="Stength of dependence", transformation = function(x) x, ...) } %- maybe also 'usage' for other objects documented here. Modified: pkg/man/invdduCopula-methods.Rd =================================================================== --- pkg/man/invdduCopula-methods.Rd 2014-03-17 13:57:05 UTC (rev 129) +++ pkg/man/invdduCopula-methods.Rd 2014-03-18 09:32:19 UTC (rev 130) @@ -6,6 +6,8 @@ \alias{invdduCopula,numeric,frankCopula,numeric-method} \alias{invdduCopula,numeric,indepCopula,numeric-method} \alias{invdduCopula,numeric,normalCopula,numeric-method} +\alias{invdduCopula,numeric,spCopula,ANY-method} + \title{Methods for Function \code{invdduCopula} in Package \pkg{spcopula}} \description{ Methods for function \code{invdduCopula} in package \pkg{spcopula} Modified: pkg/man/invddvCopula-methods.Rd =================================================================== --- pkg/man/invddvCopula-methods.Rd 2014-03-17 13:57:05 UTC (rev 129) +++ pkg/man/invddvCopula-methods.Rd 2014-03-18 09:32:19 UTC (rev 130) @@ -6,6 +6,8 @@ \alias{invddvCopula,numeric,frankCopula,numeric-method} \alias{invddvCopula,numeric,indepCopula,numeric-method} \alias{invddvCopula,numeric,normalCopula,numeric-method} +\alias{invddvCopula,numeric,spCopula,ANY-method} + \title{Methods for Function \code{invddvCopula} in Package \pkg{spcopula}} \description{ Methods for function \code{invddvCopula} in package \pkg{spcopula} From noreply at r-forge.r-project.org Tue Mar 18 12:48:50 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 18 Mar 2014 12:48:50 +0100 (CET) Subject: [spcopula-commits] r131 - in pkg: . R man tests tests/Examples Message-ID: <20140318114850.3F9BD186AAE@r-forge.r-project.org> Author: ben_graeler Date: 2014-03-18 12:48:49 +0100 (Tue, 18 Mar 2014) New Revision: 131 Added: pkg/tests/ pkg/tests/Examples/ pkg/tests/Examples/spcopula-Ex.Rout.save pkg/tests/spCopulaTest.R pkg/tests/spCopulaTest.Rout.save pkg/tests/stCopulaTest.R pkg/tests/stCopulaTest.Rout.save Modified: pkg/DESCRIPTION pkg/R/stCopula.R pkg/man/condCovariate.Rd pkg/man/getStNeighbours.Rd pkg/man/invdduCopula-methods.Rd pkg/man/invddvCopula-methods.Rd pkg/man/reduceNeighbours.Rd pkg/man/spCopula.Rd pkg/man/stCopPredict.Rd pkg/man/stNeighbourhood.Rd Log: - added tests and tests/Examples - added invdduCopula and invddvCopula methods for bivariate spatio-temporal copulas Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/DESCRIPTION 2014-03-18 11:48:49 UTC (rev 131) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-02-21 +Date: 2014-03-18 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) Modified: pkg/R/stCopula.R =================================================================== --- pkg/R/stCopula.R 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/R/stCopula.R 2014-03-18 11:48:49 UTC (rev 131) @@ -129,7 +129,7 @@ tDist <- unique(h[,2]) if(any(is.na(match(tDist,copula at tlags)))) - stop("Prediction time(s) do(es) not math the modelled time slices.") + stop("Prediction time(s) do(es) not match the modelled time slices.") if (length(tDist)==1) { res <- dduSpCopula(u, copula at spCopList[[match(tDist, copula at tlags)]], h[,1]) @@ -148,7 +148,33 @@ function(u, copula, ...) dduStCopula(matrix(u,ncol=2), copula, ...)) setMethod("dduCopula", signature("matrix","stCopula"), dduStCopula) +invdduStCopula <- function(u, copula, y, h, tol=.Machine$double.eps^0.5) { + message("invdduCopula is numerically evalauted.") + + if(!is.matrix(h)) + h <- matrix(h,ncol=2) + + nElem <- length(u) + stopifnot(nElem == length(y)) + stopifnot(nrow(h) == 1 | nrow(h)==nElem) + + optFun <- function(u, v, y, h) abs(dduStCopula(cbind(rep(u, length(v)), v), copula, h)-y) + + optMe <- function(aU, aY, aH) optimise(function(v) optFun(u=aU, v, y=aY, h=aH), c(0,1))$minimum + + if(nrow(h) == 1 & nElem > 1) + h <- matrix(rep(h,nElem),ncol=2, byrow=T) + + rV <- numeric(nElem) + for (i in 1:nElem) { + rV[i] <- optMe(u[i], y[i], h[i,,drop=FALSE]) + } + + return(rV) +} +setMethod("invdduCopula", signature("numeric", "stCopula"), invdduStCopula) + ## ddvSpCopula ## ################# @@ -160,7 +186,7 @@ tDist <- unique(h[,2]) if(any(is.na(match(tDist,copula at tlags)))) - stop("Prediction time(s) do(es) not math the modelled time slices.") + stop("Prediction time(s) do(es) not match the modelled time slices.") if (length(tDist)==1) { res <- ddvSpCopula(u, copula at spCopList[[match(tDist,copula at tlags)]], h[,1]) @@ -179,6 +205,33 @@ function(u, copula, ...) ddvStCopula(matrix(u,ncol=2), copula, ...)) setMethod("ddvCopula", signature("matrix","stCopula"), ddvStCopula) +invddvStCopula <- function(v, copula, y, h, tol=.Machine$double.eps^0.5) { + message("invdduCopula is numerically evalauted.") + + if(!is.matrix(h)) + h <- matrix(h,ncol=2) + + nElem <- length(v) + stopifnot(nElem == length(y)) + stopifnot(nrow(h) == 1 | nrow(h)==nElem) + + optFun <- function(u, v, y, h) abs(ddvStCopula(cbind(u, rep(v, length(u))), copula, h)-y) + + optMe <- function(aV, aY, aH) optimise(function(u) optFun(u, v=aV, y=aY, h=aH), c(0,1))$minimum + + if(nrow(h) == 1 & nElem > 1) + h <- matrix(rep(h,nElem),ncol=2, byrow=T) + + rU <- numeric(nElem) + for (i in 1:nElem) { + rU[i] <- optMe(v[i], y[i], h[i,,drop=FALSE]) + } + + return(rU) +} + +setMethod("invddvCopula", signature("numeric", "stCopula"), invddvStCopula) + # log-likelihood by copula for all spatio-temporal lags Modified: pkg/man/condCovariate.Rd =================================================================== --- pkg/man/condCovariate.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/condCovariate.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -29,7 +29,7 @@ library(spacetime) sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) -time <- Sys.time()+60*60*24*c(0,1,2) +time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2) data <- data.frame(var=runif(6)) data$coVar <- invdduCopula(data$var, gumbelCopula(7), runif(6)) Modified: pkg/man/getStNeighbours.Rd =================================================================== --- pkg/man/getStNeighbours.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/getStNeighbours.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -45,7 +45,7 @@ library(spacetime) sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) -time <- Sys.time()+60*60*24*c(0,1,2) +time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2) data <- data.frame(measure=runif(6)) stData <- STFDF(sp, time, data) Modified: pkg/man/invdduCopula-methods.Rd =================================================================== --- pkg/man/invdduCopula-methods.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/invdduCopula-methods.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -7,6 +7,7 @@ \alias{invdduCopula,numeric,indepCopula,numeric-method} \alias{invdduCopula,numeric,normalCopula,numeric-method} \alias{invdduCopula,numeric,spCopula,ANY-method} +\alias{invdduCopula,numeric,stCopula,ANY-method} \title{Methods for Function \code{invdduCopula} in Package \pkg{spcopula}} \description{ @@ -14,19 +15,24 @@ } \section{Methods}{ \describe{ - +\item{\code{signature(u = "ANY", copula = "ANY", y = "ANY")}}{ +The inverse of the partial derivative of a copula is evaluated. For a given \code{u} and \code{y} a \code{v} is returned such that C(u,v)=y. In case no closed form is known, the evaluation is done numerically using \code{\link{optimise}}.} +\item{\code{signature(u = "numeric", copula = "asCopula", y = "numeric")}}{ +Closed form evaluation of \code{invdduCopula} for the \code{\linkS4class{asCopula}}.} \item{\code{signature(u = "numeric", copula = "claytonCopula", y = "numeric")}}{ -%% ~~describe this method here~~ -} +Closed form evaluation of \code{invdduCopula} for the \code{\linkS4class{claytonCopula}}.} +\item{\code{signature(u = "numeric", copula = "cqsCopula", y = "numeric")}}{ +Closed form evaluation of \code{invdduCopula} for the \code{\linkS4class{cqsCopula}}.} \item{\code{signature(u = "numeric", copula = "frankCopula", y = "numeric")}}{ -%% ~~describe this method here~~ -} +Closed form evaluation of \code{invdduCopula} for the \code{\linkS4class{frankCopula}}.} \item{\code{signature(u = "numeric", copula = "indepCopula", y = "numeric")}}{ -%% ~~describe this method here~~ -} -\item{\code{signature(u = "numeric", copula = "normalCopula", y = "ANY")}}{ -%% ~~describe this method here~~ -} +Closed form evaluation of \code{invdduCopula} for the \code{\linkS4class{indepCopula}}.} +\item{\code{signature(u = "numeric", copula = "normalCopula", y = "numeric")}}{ +Closed form evaluation of \code{invdduCopula} for the \code{\linkS4class{normalCopula}}.} +\item{\code{signature(u = "numeric", copula = "spCopula", y = "ANY")}}{ +Numerical evaluation of \code{invdduCopula} for the \code{\linkS4class{spCopula}}.} +\item{\code{signature(u = "numeric", copula = "stCopula", y = "ANY")}}{ +Numerical evaluation of \code{invdduCopula} for the \code{\linkS4class{stCopula}}.} }} \keyword{methods} \keyword{inverse partial derivatives} \ No newline at end of file Modified: pkg/man/invddvCopula-methods.Rd =================================================================== --- pkg/man/invddvCopula-methods.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/invddvCopula-methods.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -7,6 +7,7 @@ \alias{invddvCopula,numeric,indepCopula,numeric-method} \alias{invddvCopula,numeric,normalCopula,numeric-method} \alias{invddvCopula,numeric,spCopula,ANY-method} +\alias{invddvCopula,numeric,stCopula,ANY-method} \title{Methods for Function \code{invddvCopula} in Package \pkg{spcopula}} \description{ @@ -14,19 +15,24 @@ } \section{Methods}{ \describe{ - +\item{\code{signature(u = "ANY", copula = "ANY", y = "ANY")}}{ +The inverse of the partial derivative of a copula is evaluated. For a given \code{u} and \code{y} a \code{v} is returned such that C(u,v)=y. In case no closed form is known, the evaluation is done numerically using \code{\link{optimise}}.} +\item{\code{signature(u = "numeric", copula = "asCopula", y = "numeric")}}{ +Closed form evaluation of \code{invddvCopula} for the \code{\linkS4class{asCopula}}.} \item{\code{signature(u = "numeric", copula = "claytonCopula", y = "numeric")}}{ -%% ~~describe this method here~~ -} +Closed form evaluation of \code{invddvCopula} for the \code{\linkS4class{claytonCopula}}.} +\item{\code{signature(u = "numeric", copula = "cqsCopula", y = "numeric")}}{ +Closed form evaluation of \code{invddvCopula} for the \code{\linkS4class{cqsCopula}}.} \item{\code{signature(u = "numeric", copula = "frankCopula", y = "numeric")}}{ -%% ~~describe this method here~~ -} +Closed form evaluation of \code{invddvCopula} for the \code{\linkS4class{frankCopula}}.} \item{\code{signature(u = "numeric", copula = "indepCopula", y = "numeric")}}{ -%% ~~describe this method here~~ -} -\item{\code{signature(u = "numeric", copula = "normalCopula", y = "ANY")}}{ -%% ~~describe this method here~~ -} +Closed form evaluation of \code{invddvCopula} for the \code{\linkS4class{indepCopula}}.} +\item{\code{signature(u = "numeric", copula = "normalCopula", y = "numeric")}}{ +Closed form evaluation of \code{invddvCopula} for the \code{\linkS4class{normalCopula}}.} +\item{\code{signature(u = "numeric", copula = "spCopula", y = "ANY")}}{ +Numerical evaluation of \code{invddvCopula} for the \code{\linkS4class{spCopula}}.} +\item{\code{signature(u = "numeric", copula = "stCopula", y = "ANY")}}{ +Numerical evaluation of \code{invddvCopula} for the \code{\linkS4class{stCopula}}.} }} \keyword{methods} \keyword{inverse partial derivatives} \ No newline at end of file Modified: pkg/man/reduceNeighbours.Rd =================================================================== --- pkg/man/reduceNeighbours.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/reduceNeighbours.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -39,7 +39,7 @@ library(spacetime) sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) -time <- Sys.time()+60*60*24*c(0,1,2,3,4) +time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2,3,4) data <- data.frame(var1=runif(10)) stData <- STFDF(sp, time, data) Modified: pkg/man/spCopula.Rd =================================================================== --- pkg/man/spCopula.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/spCopula.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -42,10 +42,10 @@ 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()), +spCop <- spCopula(components=list(normalCopula(), tCopula(), + frankCopula(), normalCopula(), claytonCopula(), + claytonCopula(), claytonCopula(), claytonCopula(), + claytonCopula(), indepCopula()), distances=bins$meanDists, spDepFun=calcKTauPol, unit="m") } Modified: pkg/man/stCopPredict.Rd =================================================================== --- pkg/man/stCopPredict.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/stCopPredict.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -54,7 +54,7 @@ stVineCop <- stVineCopula(stCop, vineCopula(4L)) sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) -time <- Sys.time()+60*60*24*c(0,1,2) +time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2) data <- data.frame(var1=runif(6)) stData <- STFDF(sp, time, data) Modified: pkg/man/stNeighbourhood.Rd =================================================================== --- pkg/man/stNeighbourhood.Rd 2014-03-18 09:32:19 UTC (rev 130) +++ pkg/man/stNeighbourhood.Rd 2014-03-18 11:48:49 UTC (rev 131) @@ -28,7 +28,7 @@ library(spacetime) sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) -time <- Sys.time()+60*60*24*c(0,1,2) +time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2) data <- data.frame(var1=runif(6)) stData <- STFDF(sp, time, data) Added: pkg/tests/Examples/spcopula-Ex.Rout.save =================================================================== --- pkg/tests/Examples/spcopula-Ex.Rout.save (rev 0) +++ pkg/tests/Examples/spcopula-Ex.Rout.save 2014-03-18 11:48:49 UTC (rev 131) @@ -0,0 +1,2704 @@ + +R version 3.1.0 alpha (2014-03-13 r65184) -- "Unsuffered Consequences" +Copyright (C) 2014 The R Foundation for Statistical Computing +Platform: x86_64-w64-mingw32/x64 (64-bit) + +R is free software and comes with ABSOLUTELY NO WARRANTY. +You are welcome to redistribute it under certain conditions. +Type 'license()' or 'licence()' for distribution details. + + Natural language support but running in an English locale + +R is a collaborative project with many contributors. +Type 'contributors()' for more information and +'citation()' on how to cite R or R packages in publications. + +Type 'demo()' for some demos, 'help()' for on-line help, or +'help.start()' for an HTML browser interface to help. +Type 'q()' to quit R. + +> pkgname <- "spcopula" +> source(file.path(R.home("share"), "R", "examples-header.R")) +> options(warn = 1) +> options(pager = "console") +> library('spcopula') +Loading required package: copula +Loading required package: VineCopula +> +> base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') +> cleanEx() +> nameEx("asCopula-class") +> ### * asCopula-class +> +> flush(stderr()); flush(stdout()) +> +> ### Name: asCopula-class +> ### Title: Class '"asCopula"' +> ### Aliases: asCopula-class dduCopula,matrix,asCopula-method +> ### dduCopula,numeric,asCopula-method ddvCopula,matrix,asCopula-method +> ### ddvCopula,numeric,asCopula-method fitCopula,asCopula-method +> ### invdduCopula,numeric,asCopula,numeric-method +> ### invddvCopula,numeric,asCopula,numeric-method +> ### Keywords: classes asymmetric copula copula +> +> ### ** Examples +> +> showClass("asCopula") +Class "asCopula" [package "spcopula"] + +Slots: + +Name: dimension parameters param.names param.lowbnd param.upbnd +Class: integer numeric character numeric numeric + +Name: fullname +Class: character + +Extends: +Class "copula", directly +Class "Copula", by class "copula", distance 2 +> +> +> +> cleanEx() +> nameEx("asCopula") +> ### * asCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: asCopula +> ### Title: Constructor of an asymmetric copula with cubic and quadratic +> ### sections (Nelsen 2006). +> ### Aliases: asCopula +> ### Keywords: asymmetric copula cubic quadratic sections +> +> ### ** Examples +> +> persp(asCopula(c(-2,1)),dCopula) +> +> +> +> cleanEx() +> nameEx("calcBins") +> ### * calcBins +> +> flush(stderr()); flush(stdout()) +> +> ### Name: calcBins +> ### Title: A function calculating the spatial/spatio-temporal bins +> ### Aliases: calcBins calcBins-methods calcBins,Spatial-method +> ### calcBins,STFDF-method +> ### Keywords: spatial preparation spatio-temporal preparation +> +> ### ** Examples +> +> library(sp) +> data(meuse) +> coordinates(meuse) = ~x+y +> meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1) +> +> ## lag classes ## +> bins <- calcBins(meuse, var="rtZinc", nbins=10, cutoff=800) +> +> +> +> cleanEx() + +detaching 'package:sp' + +> nameEx("composeSpCopula") +> ### * composeSpCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: composeSpCopula +> ### Title: Composing a bivariate Spatial Copula +> ### Aliases: composeSpCopula +> ### Keywords: spatial multivariate distribution +> +> ### ** Examples +> +> composeSpCopula(c(1,1,2,3),families=list(frankCopula(.4), gumbelCopula(1.6),gumbelCopula(1.4)), ++ bins=data.frame(meanDists=c(500,1000,1500,2000,2500)),range=2250) +Spatial Copula: distance dependent convex combination of bivariate copulas +Dimension: 2 +Copulas: + Frank copula family; Archimedean copula at 500 [m] + Frank copula family; Archimedean copula at 1000 [m] + Gumbel copula family; Archimedean copula; Extreme value copula at 1500 [m] + Gumbel copula family; Archimedean copula; Extreme value copula at 2000 [m] +> +> +> +> cleanEx() +> nameEx("condCovariate") +> ### * condCovariate +> +> flush(stderr()); flush(stdout()) +> +> ### Name: condCovariate +> ### Title: Conditioning of a Covariate +> ### Aliases: condCovariate +> +> ### ** Examples +> +> library(sp) +> library(spacetime) +> +> sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) +> time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2) +> data <- data.frame(var=runif(6)) +> data$coVar <- invdduCopula(data$var, gumbelCopula(7), runif(6)) +Numerical evaluation of invddu takes place. +> +> stData <- STFDF(sp, time, data) +> stQuerry <- STF(SpatialPoints(matrix(c(181000,181200,333600,333600),2)), ++ time[2:3]) +> +> stNeigh <- getStNeighbours(stData=stData, ST=stQuerry, ++ spSize=3, tlags=-(0:1), ++ var="var", coVar="coVar", prediction=TRUE) +> +> condCovariate(stNeigh, function(x) gumbelCopula(7)) +[1] 2.558620e-05 5.677942e-09 6.178627e-02 1.765568e-01 +> +> +> +> cleanEx() + +detaching 'package:spacetime', 'package:sp' + +> nameEx("condSpVine") +> ### * condSpVine +> +> flush(stderr()); flush(stdout()) +> +> ### Name: condSpVine +> ### Title: Conditions a spatial vine copula for conditional prediction +> ### Aliases: condSpVine +> ### Keywords: distribution +> +> ### ** Examples +> +> data(spCopDemo) +> +> calcKTauPol <- fitCorFun(bins, degree=3) + +Call: +lm(formula = lagCor ~ poly(meanDists, degree), data = bins) + +Coefficients: + (Intercept) poly(meanDists, degree)1 poly(meanDists, degree)2 + 0.20756 -0.58268 0.16262 +poly(meanDists, degree)3 + -0.02181 + +Sum of squared residuals: 0.006621988 +> +> 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") +The parameters of the components will be recalculated according to the provided spDepFun where possible. +In case no 1-1 relation is known, the copula as in components is used. +parameter at boundary ==> returning indepCopula() +parameter at boundary ==> returning indepCopula() +parameter at boundary ==> returning indepCopula() +parameter at boundary ==> returning indepCopula() +parameter at boundary ==> returning indepCopula() +> +> spVineCop <- spVineCopula(spCop, vineCopula(4L)) +> +> dists <- list(c(473, 124, 116, 649)) +> condVar <- c(0.29, 0.55, 0.05, 0.41) +> condDensity <- condSpVine(condVar,dists,spVineCop) +> +> curve(condDensity) +> mtext(paste("Dists:",paste(round(dists[[1]],0),collapse=", ")),line=0) +> mtext(paste("Cond.:",paste(round(condVar,2),collapse=", ")),line=1) +> +> +> +> cleanEx() +> nameEx("condStCoVarVine") +> ### * condStCoVarVine +> +> flush(stderr()); flush(stdout()) +> +> ### Name: condStCoVarVine +> ### Title: conditional distribution function of spatio-temporal covariate +> ### vine copula +> ### Aliases: condStCoVarVine +> +> ### ** Examples +> +> spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), ++ claytonCopula(2), claytonCopula(1), ++ claytonCopula(0.5), indepCopula()), ++ distances=c(100,200,300,400,500,600), ++ unit="km") +> spCopT1 <- spCopula(components=list(claytonCopula(4), claytonCopula(2), ++ claytonCopula(1), claytonCopula(0.5), ++ indepCopula()), ++ distances=c(100,200,300,400,500), ++ unit="km") +> spCopT2 <- spCopula(components=list(claytonCopula(2), claytonCopula(1), ++ claytonCopula(0.5), indepCopula()), ++ distances=c(100,200,300,400), ++ unit="km") +> +> stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), ++ tlags=-(0:2)) +> +> # only a constant copula ius used for the covariate +> stCVVC <- stCoVarVineCopula(function(x) gumbelCopula(7), stCop, vineCopula(5L)) +> +> dists <- array(c(150, 250, 150, 250,0,0,-1,-1),dim=c(1,4,2)) +> condVar <- c(0.95, 0.29, 0.55, 0.05, 0.41) +> +> condDensity <- condStCoVarVine(condVar, dists, stCVVC, c(1,1)) +> curve(condDensity) +> +> +> +> cleanEx() +> nameEx("condStVine") +> ### * condStVine +> +> flush(stderr()); flush(stdout()) +> +> ### Name: condStVine +> ### Title: Conditions a spatio-temporal vine copula for conditional +> ### prediction +> ### Aliases: condStVine +> ### Keywords: distribution +> +> ### ** Examples +> +> # a spatio-temporal C-vine copula (with independent copulas in the upper vine) +> +> spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), ++ claytonCopula(2), claytonCopula(1), ++ claytonCopula(0.5), indepCopula()), ++ distances=c(100,200,300,400,500,600), ++ unit="km") +> spCopT1 <- spCopula(components=list(claytonCopula(4), claytonCopula(2), ++ claytonCopula(1), claytonCopula(0.5), ++ indepCopula()), ++ distances=c(100,200,300,400,500), ++ unit="km") +> +> stCop <- stCopula(components=list(spCopT0, spCopT1), ++ tlags=-(0:1)) +> +> stVineCop <- stVineCopula(stCop, vineCopula(4L)) +> +> 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 <- condStVine(condVar,dists,stVineCop) +> curve(condDensity) +> +> +> +> cleanEx() +> nameEx("cqsCopula-class") +> ### * cqsCopula-class +> +> flush(stderr()); flush(stdout()) +> +> ### Name: cqsCopula-class +> ### Title: Class '"cqsCopula"' +> ### Aliases: cqsCopula-class dduCopula,matrix,cqsCopula-method +> ### dduCopula,numeric,cqsCopula-method ddvCopula,matrix,cqsCopula-method +> ### ddvCopula,numeric,cqsCopula-method fitCopula,cqsCopula-method +> ### invdduCopula,numeric,cqsCopula,numeric-method +> ### invddvCopula,numeric,cqsCopula,numeric-method +> ### Keywords: classes copula +> +> ### ** Examples +> +> showClass("cqsCopula") +Class "cqsCopula" [package "spcopula"] + +Slots: + +Name: fixed dimension parameters param.names param.lowbnd +Class: character integer numeric character numeric + +Name: param.upbnd fullname +Class: numeric character + +Extends: +Class "copula", directly +Class "Copula", by class "copula", distance 2 +> +> +> +> cleanEx() +> nameEx("cqsCopula") +> ### * cqsCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: cqsCopula +> ### Title: Constructor of a symmetric copula with cubic quadratic sections. +> ### Aliases: cqsCopula +> ### Keywords: copula cubic quadratic sections +> +> ### ** Examples +> +> persp(cqsCopula(c(-2,1)),dCopula) +> +> +> +> cleanEx() +> nameEx("criticalLevel") +> ### * criticalLevel +> +> flush(stderr()); flush(stdout()) +> +> ### Name: criticalLevel +> ### Title: Calculating the critical level for a given Kendall Return Period +> ### Aliases: criticalLevel +> ### Keywords: survival multivariate +> +> ### ** Examples +> +> criticalLevel(getKendallDistr(frankCopula(.7)), KRP=c(10,100,1000)) +[1] 0.6244540 0.8801567 0.9620758 +> +> +> +> cleanEx() +> nameEx("criticalPair") +> ### * criticalPair +> +> flush(stderr()); flush(stdout()) +> +> ### Name: criticalPair +> ### Title: Calculate Critical Pairs +> ### Aliases: criticalPair +> ### Keywords: ~kwd1 ~kwd2 +> +> ### ** Examples +> +> v <- criticalPair(frankCopula(0.7), 0.9, u=.97, 1) +> pCopula(c(0.97, v),frankCopula(0.7)) +[1] 0.9 +> +> +> +> cleanEx() +> nameEx("criticalTriple") +> ### * criticalTriple +> +> flush(stderr()); flush(stdout()) +> +> ### Name: criticalTriple +> ### Title: calculate critical triples +> ### Aliases: criticalTriple +> ### Keywords: multivariate distribution +> +> ### ** Examples +> +> w <- criticalTriple(frankCopula(0.7,dim=3), 0.9, c(.97,.97), c(1,2)) +> +> # check the triple +> pCopula(c(0.97, 0.97, w), frankCopula(0.7, dim=3)) +[1] 0.9 +> +> +> +> +> cleanEx() +> nameEx("dduCopula") +> ### * dduCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: dduCopula +> ### Title: partial derivatives of copulas +> ### Aliases: dduCopula ddvCopula +> ### Keywords: partial derivative conditional probabilities +> +> ### ** Examples +> +> #################################### +> ## Asymmetric vs. Gaussian copula ## +> #################################### +> +> asCop <- asCopula(c(-2,1)) +> asCopSmpl <- rCopula(100,asCop) +> +> unitScatter(smpl=asCopSmpl) +> +> # conditional probabilities of an asymmetric copula given u +> asGivenU <- dduCopula(asCopSmpl,asCop) +> +> # vs. conditional probabilities of an asymmetric copula given v +> asGivenV <- ddvCopula(asCopSmpl[,c(2,1)],asCop) +> unitScatter(smpl=cbind(asGivenU, asGivenV)) +> +> normalCop <- normalCopula(.6) +> normCopSmpl <- rCopula(100,normalCop) +> +> unitScatter(smpl=normCopSmpl) +> +> # conditional probabilities of a Gaussian copula given u +> normGivenU <- dduCopula(normCopSmpl,normalCop) +> +> # vs. conditional probabilities of a Gaussian copula given v +> normGivenV <- ddvCopula(normCopSmpl[,c(2,1)],normalCop) +> unitScatter(smpl=cbind(normGivenU, normGivenV)) +> +> +> +> cleanEx() +> nameEx("dependencePlot") +> ### * dependencePlot +> +> flush(stderr()); flush(stdout()) +> +> ### Name: dependencePlot +> ### Title: Kernel smoothed scatter plot +> ### Aliases: dependencePlot +> ### Keywords: plot +> +> ### ** Examples +> +> ## Not run: dependencePlot(smpl=rCopula(500,asCopula(c(-1,1)))) +> +> +> +> cleanEx() +> nameEx("empiricalCopula-class") +> ### * empiricalCopula-class +> +> flush(stderr()); flush(stdout()) +> +> ### Name: empiricalCopula-class +> ### Title: Class '"empiricalCopula"' +> ### Aliases: empiricalCopula-class +> ### Keywords: classes +> +> ### ** Examples +> +> showClass("empiricalCopula") +Class "empiricalCopula" [package "spcopula"] + +Slots: + +Name: sample dimension parameters param.names param.lowbnd +Class: matrix integer numeric character numeric + +Name: param.upbnd fullname +Class: numeric character + +Extends: +Class "copula", directly +Class "Copula", by class "copula", distance 2 +> +> +> +> cleanEx() +> nameEx("empiricalCopula") +> ### * empiricalCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: empiricalCopula +> ### Title: Constructor of an empirical copula class +> ### Aliases: empiricalCopula +> ### Keywords: multivariate +> +> ### ** Examples +> +> empCop <- empiricalCopula(rCopula(500,frankCopula(0.7))) +> str(empCop) +Formal class 'empiricalCopula' [package "spcopula"] with 7 slots + ..@ sample : num [1:500, 1:2] 0.266 0.372 0.573 0.908 0.202 ... + ..@ dimension : int 2 + ..@ parameters : num NA + ..@ param.names : chr "unknown" + ..@ param.lowbnd: num NA + ..@ param.upbnd : num NA + ..@ fullname : chr "Unkown empirical copula based on a sample." +> +> empCop <- empiricalCopula(copula=frankCopula(0.7)) +Note: the copula will be empirically represented by a sample of size: 1e+05 +> str(empCop) +Formal class 'empiricalCopula' [package "spcopula"] with 7 slots + ..@ sample : num [1:100000, 1:2] 0.531 0.685 0.383 0.955 0.118 ... + ..@ dimension : int 2 + ..@ parameters : num 0.7 + ..@ param.names : chr "param" + ..@ param.lowbnd: num -Inf + ..@ param.upbnd : num Inf + ..@ fullname : chr "Empirical copula derived from Frank copula family; Archimedean copula" +> +> empCop <- empiricalCopula(rCopula(500,frankCopula(0.7)), frankCopula(0.7)) +> str(empCop) +Formal class 'empiricalCopula' [package "spcopula"] with 7 slots + ..@ sample : num [1:500, 1:2] 0.8219 0.2413 0.0371 0.2891 0.7464 ... + ..@ dimension : int 2 + ..@ parameters : num 0.7 + ..@ param.names : chr "param" + ..@ param.lowbnd: num -Inf + ..@ param.upbnd : num Inf + ..@ fullname : chr "Empirical copula derived from Frank copula family; Archimedean copula" +> +> # the empirical value +> pCopula(c(0.3, 0.5), empCop) +[1] 0.156 +> +> # the theoretical value +> pCopula(c(0.3, 0.5), frankCopula(0.7)) +[1] 0.1682671 +> +> +> +> cleanEx() +> nameEx("fitCorFun") +> ### * fitCorFun +> +> flush(stderr()); flush(stdout()) +> +> ### Name: fitCorFun +> ### Title: Automated fitting of a correlation function to the correlogram +> ### Aliases: fitCorFun +> ### Keywords: correlogram spcopula +> +> ### ** Examples +> +> # a simplified bins object (from demo(spcopula)) +> bins <- list(meanDists=c(64, 128, 203, 281, 361, 442, 522, 602, 681, 760), ++ lagCor=c(0.57, 0.49, 0.32, 0.29, 0.15, 0.14, 0.10, -0.00, 0.03, -0.01)) +> attr(bins,"cor.method") <- "kendall" +> +> # plot the correlogram +> plot(lagCor~meanDists,bins) +> +> # fit and plot a linear model +> calcKTauLin <- fitCorFun(bins, degree=1, cutoff=600) + +Call: +lm(formula = lagCor ~ poly(meanDists, degree), data = bins) + +Coefficients: + (Intercept) poly(meanDists, degree) + 0.2943 -0.4284 + +Sum of squared residuals: 0.01381904 +> curve(calcKTauLin,0, 1000, col="red",add=TRUE) +> +> # fit and plot a polynomial model +> calcKTauPol <- fitCorFun(bins, degree=5) + +Call: +lm(formula = lagCor ~ poly(meanDists, degree), data = bins) + +Coefficients: + (Intercept) poly(meanDists, degree)1 poly(meanDists, degree)2 + 0.208000 -0.581940 0.161524 +poly(meanDists, degree)3 poly(meanDists, degree)4 poly(meanDists, degree)5 + -0.023774 0.004097 0.011434 + +Sum of squared residuals: 0.006503102 +> curve(calcKTauPol,0, 1000, col="purple",add=TRUE) +> +> +> +> cleanEx() +> nameEx("fitSpCopula") +> ### * fitSpCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: fitSpCopula +> ### Title: Spatial Copula Fitting +> ### Aliases: fitSpCopula +> ### Keywords: spatial multivariate distribution +> +> ### ** Examples +> +> # reload some spatial data +> library(sp) +> data(meuse) +> coordinates(meuse) <- ~x+y +> +> # drop margins +> meuse$marZinc <- plnorm(meuse$zinc, mean(log(meuse$zinc)), sd(log(meuse$zinc))) +> +> # load data from a provided binning +> data(spCopDemo) +> +> fitSpCopula(bins, meuse, 600) + +Call: +lm(formula = lagCor ~ poly(meanDists, degree), data = bins) + +Coefficients: + (Intercept) poly(meanDists, degree)1 poly(meanDists, degree)2 + 0.294212 -0.428150 0.100339 +poly(meanDists, degree)3 + 0.007255 + +Sum of squared residuals: 0.003770511 +Normal copula family + + | + | | 0% + | + |======= | 10% + | + |============== | 20% + | + |===================== | 30% + | + |============================ | 40% + | + |=================================== | 50% + | + |========================================== | 60% + | + |================================================= | 70% + | + |======================================================== | 80% + | + |=============================================================== | 90% + | + |======================================================================| 100% +t copula family [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 131 From noreply at r-forge.r-project.org Mon Mar 24 20:35:13 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Mar 2014 20:35:13 +0100 (CET) Subject: [spcopula-commits] r132 - in pkg: . R data demo man tests/Examples Message-ID: <20140324193513.A3E62187001@r-forge.r-project.org> Author: ben_graeler Date: 2014-03-24 20:35:13 +0100 (Mon, 24 Mar 2014) New Revision: 132 Added: pkg/data/EU_RB.RData pkg/demo/stCoVarVineCop.R pkg/man/EU_RB.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/returnPeriods.R pkg/R/spCopula.R pkg/demo/00Index pkg/man/qCopula_u.Rd pkg/tests/Examples/spcopula-Ex.Rout.save Log: - added demo and smaller data set for JSS paper in preparation - added qCopula_v along the lines of qCopula_u - spcopula-Ex.Rout.save has been updated accordingly Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/DESCRIPTION 2014-03-24 19:35:13 UTC (rev 132) @@ -2,7 +2,7 @@ Type: Package Title: copula driven spatial analysis Version: 0.2-0 -Date: 2014-03-18 +Date: 2014-03-24 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) @@ -12,6 +12,7 @@ LazyLoad: yes Depends: copula (>= 0.999-7), VineCopula (>= 1.2-1), R (>= 2.15.0) Imports: sp, spacetime (>= 1.0-9), methods +Suggests: evd URL: http://r-forge.r-project.org/projects/spcopula/ Collate: Classes.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/NAMESPACE 2014-03-24 19:35:13 UTC (rev 132) @@ -16,7 +16,7 @@ export(fitCopula) export(dduCopula,ddvCopula) export(invdduCopula, invddvCopula) -export(qCopula_u) +export(qCopula_u, qCopula_v) export(condSpVine,spCopPredict) export(condStVine,stCopPredict) export(condStCoVarVine, condCovariate) Modified: pkg/R/returnPeriods.R =================================================================== --- pkg/R/returnPeriods.R 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/R/returnPeriods.R 2014-03-24 19:35:13 UTC (rev 132) @@ -125,6 +125,44 @@ setMethod("qCopula_u", signature("copula"), qCopula_u.def) +setGeneric("qCopula_v",function(copula,p,v,...) {standardGeneric("qCopula_v")}) + +qCopula_v.def <- function(copula,p,v, tol=.Machine$double.eps^.5) { # sample=NULL + dim <- copula at dimension + if(length(p) != length(v)) stop("Length of p and v differ!") + + params <- NULL + for(i in 1:length(p)) { # i <- 1 + if (v[i] < p[i]) { + params <- rbind(params,rep(NA,dim-1)) + } else { + if (dim == 2) { + params <- rbind(params, + optimize(function(u) abs(pCopula(cbind(u, rep(v[i],length(u))),copula)-p[i]), + c(p,1), tol=tol)$minimum) + } else { + opt <- optim(par=rep(p[i],dim-1), + function(uw) abs(pCopula(c(uw[1],v[i],uw[2]), copula)-p[i]), + lower=rep(p[i],dim-1), upper=rep(1,dim-1), method="L-BFGS-B") + params <- rbind(params, opt$par) + } + } + } + + if (dim == 2) { + return(cbind(params,v)) + } else { + if (is.matrix(params)) + return(cbind(params[,1], v, params[,2])) + else + return(cbind(params[1], v, params[2])) + } + +} + +setMethod("qCopula_v", signature("copula"), qCopula_v.def) + + ## kendall distribution # empirical default Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/R/spCopula.R 2014-03-24 19:35:13 UTC (rev 132) @@ -521,7 +521,9 @@ cor.method, weighted) } - corFun <- function(h, time, tlags=sort(tlags,decreasing=TRUE)) { + tlsort <- sort(tlags,decreasing=TRUE) + + corFun <- function(h, time, tlags=tlsort) { t <- which(tlags==time) calcKTau[[time]](h) } Added: pkg/data/EU_RB.RData =================================================================== (Binary files differ) Property changes on: pkg/data/EU_RB.RData ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Modified: pkg/demo/00Index =================================================================== --- pkg/demo/00Index 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/demo/00Index 2014-03-24 19:35:13 UTC (rev 132) @@ -3,3 +3,4 @@ pureSpVineCopula A demo illustrating the estiamtion of a pure spatial vine copula for a SpatialPointsDataFrame. stVineCopFit A demo corresponding to the vignette estimating a spatio-temporal vine copula. tailDepFunctions A demo illustrating the empirical tail dependece function with parametric parametric tail dependence functions for different families of copulas. +stCoVarVineCop A demo redoing the estimation of spatio-temporal covariate vine copula as it is illustrated in a paper to be submitted to JSS. The demo uses a temporal subset and a reduced felxibility yielding a different spatio-temporal covariate vine copula stCVVC. Added: pkg/demo/stCoVarVineCop.R =================================================================== --- pkg/demo/stCoVarVineCop.R (rev 0) +++ pkg/demo/stCoVarVineCop.R 2014-03-24 19:35:13 UTC (rev 132) @@ -0,0 +1,171 @@ +# demo related to the JSS paper +## +library(evd) + +data(EU_RB) + +# estimate a GEV at each location for PM10 and EMEP +parPM10 <- matrix(NA, length(EU_RB at sp), 3) +parEMEP <- matrix(NA, length(EU_RB at sp), 3) + +marPM10 <- matrix(NA, length(EU_RB at sp), 61) +marEMEP <- matrix(NA, length(EU_RB at sp), 61) + +for (loc in 1:length(EU_RB at sp)) { + parPM10[loc, 1:3] <- fgev(EU_RB[loc,,"PM10",drop=F]@data[[1]])$estimate + parEMEP[loc, 1:3] <- fgev(EU_RB[loc,,"EMEP",drop=F]@data[[1]])$estimate + + marPM10[loc,] <- pgev(EU_RB[loc,,"PM10",drop=F]@data[[1]], parPM10[loc,1], parPM10[loc,2], parPM10[loc,3]) + marEMEP[loc,] <- pgev(EU_RB[loc,,"EMEP",drop=F]@data[[1]], parEMEP[loc,1], parEMEP[loc,2], parEMEP[loc,3]) +} + +EU_RB at data$marPM10 <- as.vector(marPM10) +EU_RB at data$marEMEP <- as.vector(marEMEP) + +######################################## +## correlation between EMEP and PM10? ## +######################################## + +# monCor <- NULL +# monCop <- NULL +# for(month in c("2005-01", "2005-02", "2005-03", "2005-04", +# "2005-05", "2005-06", "2005-07", "2005-08", +# "2005-09", "2005-10", "2005-11", "2005-12")) { +# +# smpl <- cbind(EU_RB_2005[,month,"marPM10"]@data[[1]], +# EU_RB_2005[,month,"marEMEP"]@data[[1]]) +# bool <- !apply(smpl,1,function(row) any(is.na(row))) +# smpl <- smpl[bool,] +# +# monCor <- c(monCor, VineCopula:::fasttau(smpl[,1], smpl[,2])) +# monCop <- append(monCop,list(BiCopSelect(smpl[,1], smpl[,2], familyset=c(2,4)))) +# } +# +# plot(monCor) +# +# table(sapply(monCop, function(x) x$family)) + +dayCor <- numeric(61) +for(day in 1:61) { + smpl <- cbind(EU_RB[,day, "marPM10"]@data[[1]], + EU_RB[,day, "marEMEP"]@data[[1]]) + bool <- !apply(smpl,1,function(row) any(is.na(row))) + smpl <- smpl[bool,] + + dayCor[day] <- TauMatrix(smpl)[1,2] +} + +weekCor <- numeric(9) +weekCop <- NULL +for(week in 1:9) { + smpl <- cbind(EU_RB[,pmin((week-1)*7+1:7,61), "marPM10"]@data[[1]], + EU_RB[,pmin((week-1)*7+1:7,61), "marEMEP"]@data[[1]]) + bool <- !apply(smpl,1,function(row) any(is.na(row))) + smpl <- smpl[bool,] + + weekCor[week] <- TauMatrix(smpl)[1,2] + weekCop <- append(weekCop,list(BiCopSelect(smpl[,1], smpl[,2], familyset=1:6))) +} + + +par(mar=c(5.1, 4.1, 4.1,6)) +plot(dayCor, type="l", col="gray", xlab="day in 2005-06-01::2005-07-31", + ylab="Kendall's tau", main="correlation structure of PM10 and EMEP over time") +points(rep(weekCor,each=7), type="s", col="red") +segments(0:8*7+1,sapply(weekCop, function(x) x$family)/10, 1:9*7+1, sapply(weekCop, function(x) x$family)/10) +axis(4,at=1:6/10, labels=c("Gauss", "Student", "Clayton", "Gumbel", "Frank", "Joe"),las=2) +mtext("copula family",4,4.5) + +############################# +# the paper starts here ... # +############################# + +# define the coVariate Copula function +coVarCop <- function(stInd) { + week <- min(ceiling(stInd[2]/7), 9) + copulaFromFamilyIndex(weekCop[[week]]$family, weekCop[[week]]$par, + weekCop[[week]]$par2) +} + +## spatio-temporal copula +# binning +stBins <- calcBins(EU_RB, "marPM10", nbins=20, tlags=-(0:2)) +stDepFun <- fitCorFun(stBins, rep(3, 5), tlags=-(0:4)) + + +## +fiveColors <- c("#fed976", "#feb24c", "#fd8d3c", "#f03b20", "#bd0026") +par(mar=c(4.1, 4.1, 2.1, 1.1)) +plot(stBins$meanDists/1000, stBins$lagCor[1,], + ylim=c(0,0.7), xlab="distance [km]", ylab="correlation [Kendall's tau]", + col=fiveColors[5]) +points(stBins$meanDists/1000, stBins$lagCor[2,], col=fiveColors[3]) +points(stBins$meanDists/1000, stBins$lagCor[3,], col=fiveColors[1]) +abline(h=0) +abline(h=0.025,col="grey") + +which(tlags==time) + +fun1 <- function(x) stDepFun(x*1000, 1, 5:1) +curve(fun1, 0, 1600, add=T, col=fiveColors[5]) +fun2 <- function(x) stDepFun(x*1000, 2, 5:1) +curve(fun2, 0, 1600, add=T, col=fiveColors[3]) +fun3 <- function(x) stDepFun(x*1000, 3, 5:1) +curve(fun3, 0, 1600, add=T, col=fiveColors[1]) + +legend("topright",c("same day", "1 day before", "2 days before"), + lty=1, pch=1, col=fiveColors[c(5,3,1)]) +title("Spatio-Temporal Dependence Structure") +## + +families <- c(normalCopula(), tCopula(), + claytonCopula(), frankCopula(), gumbelCopula(), + joeBiCopula()) + +loglikTau <- loglikByCopulasStLags(stBins, EU_RB, families, stDepFun) + +bestFitTau <- lapply(loglikTau, + function(x) apply(apply(x$loglik[,1:6], 1, rank), + 2, which.max)) + +bestFitTau + +# define the spatio-temporal copula components +listDists <- NULL +listDists[[1]] <- stBins$meanDists[sort(unique(c(which(diff(bestFitTau$loglik1)!=0), + which(diff(bestFitTau$loglik1)!=0)+1,1,20)))] +listDists[[2]] <- stBins$meanDists[sort(unique(c(which(diff(bestFitTau$loglik2)!=0), + which(diff(bestFitTau$loglik2)!=0)+1,1,20)))] +listDists[[3]] <- stBins$meanDists[sort(unique(c(which(diff(bestFitTau$loglik3)!=0), + which(diff(bestFitTau$loglik3)!=0)+1,1,20)))] + +listCops <- NULL +listCops[[1]] <- families[bestFitTau$loglik1[sort(unique(c(which(diff(bestFitTau$loglik1)!=0), + which(diff(bestFitTau$loglik1)!=0)+1,1,20)))]] +listCops[[2]] <- families[bestFitTau$loglik2[sort(unique(c(which(diff(bestFitTau$loglik2)!=0), + which(diff(bestFitTau$loglik2)!=0)+1,1,20)))]] +listCops[[3]] <- families[bestFitTau$loglik3[sort(unique(c(which(diff(bestFitTau$loglik3)!=0), + which(diff(bestFitTau$loglik3)!=0)+1,1,20)))]] + +stBiCop <- stCopula(components = listCops, distances = listDists, + tlags=-c(0:2), stDepFun=stDepFun) + + +## get the neighbours +stNeigh <- getStNeighbours(EU_RB, spSize=9, var="marPM10", coVar="marEMEP", + tlags=-(0:2), timeSteps=20, min.dist=10) +stRedNeigh <- reduceNeighbours(stNeigh, stDepFun, 5) + +# condition on the spatio-temporal tree +condData <- dropStTree(stRedNeigh, EU_RB, stBiCop) + +# condition the covariate on the observed phenomenon +condCoVa <- condCovariate(stRedNeigh, coVarCop) + +secTreeData <- cbind(condCoVa, as.matrix(condData at data)) + +vineFit <- fitCopula(vineCopula(6L), secTreeData, method=list(familyset=1:6)) + +stCVVC <- stCoVarVineCopula(coVarCop, stBiCop, vineFit at copula) + +stCVVC \ No newline at end of file Added: pkg/man/EU_RB.Rd =================================================================== --- pkg/man/EU_RB.Rd (rev 0) +++ pkg/man/EU_RB.Rd 2014-03-24 19:35:13 UTC (rev 132) @@ -0,0 +1,55 @@ +\name{EU_RB} +\alias{EU_RB} +\docType{data} +\title{ +Daily mean PM10 concentrations over Europe in June and July 2005 +} +\description{ +Daily mean PM10 concentrations over Europe in June and July 2005 +} +\usage{data(EU_RB)} +\format{ + The format is: +Formal class 'STSDF' [package "spacetime"] with 5 slots + ..@ data :'data.frame': 11834 obs. of 2 variables: + .. ..$ PM10: num [1:11834] 14 9.7 7.8 21.9 11.2 9 11 6.1 7.4 7.4 ... + .. ..$ EMEP: num [1:11834] 11.62 5.02 3.94 3.82 7.01 ... + ..@ index : int [1:11834, 1:2] 1 2 3 4 5 6 7 8 9 10 ... + ..@ sp :Formal class 'SpatialPointsDataFrame' [package "sp"] with 5 slots + .. .. ..@ data :'data.frame': 194 obs. of 1 variable: + .. .. .. ..$ station_altitude: int [1:194] 525 581 918 560 172 117 665 1137 330 330 ... + .. .. ..@ coords.nrs : num(0) + .. .. ..@ coords : num [1:194, 1:2] 4592866 4761515 4658756 4690954 4799839 ... + .. .. .. ..- attr(*, "dimnames")=List of 2 + .. .. .. .. ..$ : NULL + .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" + .. .. ..@ bbox : num [1:2, 1:2] 2749697 1647732 6412269 4604814 + .. .. .. ..- attr(*, "dimnames")=List of 2 + .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" + .. .. .. .. ..$ : chr [1:2] "min" "max" + .. .. ..@ proj4string:Formal class 'CRS' [package "sp"] with 1 slots + .. .. .. .. ..@ projargs: chr " +proj=laea +lat_0=52 +lon_0=10 +x_0=4321000 +y_0=3210000 +ellps=GRS80 +units=m +no_defs" + ..@ time :An ?xts? object on 2005-06-01/2005-07-31 containing: + Data: int [1:61, 1] 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 ... + - attr(*, "dimnames")=List of 2 + ..$ : NULL + ..$ : chr "..1" + Indexed by objects of class: [POSIXct,POSIXt] TZ: GMT + xts Attributes: + NULL + ..@ endTime: POSIXct[1:61], format: "2005-06-02 02:00:00" "2005-06-03 02:00:00" "2005-06-04 02:00:00" ... +} +\source{ +Obtained from the european Air Qualtiy airbase http://acm.eionet.europa.eu/databases/airbase/. +} +\references{ +http://acm.eionet.europa.eu/databases/airbase/ + +Graeler, B., L. E. Gerharz, & E. Pebesma (2012): Spatio-temporal analysis and interpolation of PM10 measurements in Europe. ETC/ACM Technical Paper 2011/10, January 2012. +http://acm.eionet.europa.eu/reports/ETCACM_TP_2011_10_spatio-temp_AQinterpolation +} +\examples{ +data(EU_RB) +str(EU_RB) +} +\keyword{datasets} Modified: pkg/man/qCopula_u.Rd =================================================================== --- pkg/man/qCopula_u.Rd 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/man/qCopula_u.Rd 2014-03-24 19:35:13 UTC (rev 132) @@ -2,14 +2,18 @@ \alias{qCopula_u} \alias{qCopula_u,copula-method} +\alias{qCopula_v} +\alias{qCopula_v,copula-method} + \title{ -The inverse of a bivariate copula given u +The inverse of a bivariate copula given u or v } \description{ -The inverse of a bivariate copula is calculated for a given u. +The inverse of a bivariate copula is calculated for a given u or v respectively. } \usage{ qCopula_u(copula, p, u, ...) +qCopula_v(copula, p, v, ...) } \arguments{ \item{copula}{ @@ -21,6 +25,9 @@ \item{u}{ the conditioning variable u } + \item{v}{ +the conditioning variable v +} \item{\dots}{ Passed on to \code{\link{optim}} in the background. } @@ -29,7 +36,7 @@ The evaluation is done numerically using either \code{\link{optim}} or \code{\link{optimise}}. } \value{ -A matrix having the same number of rows as \code{u} providing u and the other arguments. +A matrix having the same number of rows as the length of \code{u} or \code{v} respectively. } \author{ Benedikt Graeler @@ -38,6 +45,9 @@ \examples{ uv <- qCopula_u(asCopula(c(-1,1)), p=rep(0.9,10), u=runif(10,0.9,1)) pCopula(uv,asCopula(c(-1,1)))-0.9 + +uv <- qCopula_v(asCopula(c(-1,1)), p=rep(0.9,10), v=runif(10,0.9,1)) +pCopula(uv,asCopula(c(-1,1)))-0.9 } \keyword{ distribution } Modified: pkg/tests/Examples/spcopula-Ex.Rout.save =================================================================== --- pkg/tests/Examples/spcopula-Ex.Rout.save 2014-03-18 11:48:49 UTC (rev 131) +++ pkg/tests/Examples/spcopula-Ex.Rout.save 2014-03-24 19:35:13 UTC (rev 132) @@ -27,6 +27,51 @@ > > base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') > cleanEx() +> nameEx("EU_RB") +> ### * EU_RB +> +> flush(stderr()); flush(stdout()) +> +> ### Name: EU_RB +> ### Title: Daily mean PM10 concentrations over Europe in June and July 2005 +> ### Aliases: EU_RB +> ### Keywords: datasets +> +> ### ** Examples +> +> data(EU_RB) +> str(EU_RB) +Formal class 'STFDF' [package "spacetime"] with 4 slots + ..@ data :'data.frame': 11834 obs. of 2 variables: + .. ..$ PM10: num [1:11834] 14 9.7 7.8 21.9 11.2 9 11 6.1 7.4 7.4 ... + .. ..$ EMEP: num [1:11834] 11.62 5.02 3.94 3.82 7.01 ... + ..@ sp :Formal class 'SpatialPointsDataFrame' [package "sp"] with 5 slots + .. .. ..@ data :'data.frame': 194 obs. of 1 variable: + .. .. .. ..$ station_altitude: int [1:194] 525 581 918 560 172 117 665 1137 330 330 ... + .. .. ..@ coords.nrs : num(0) + .. .. ..@ coords : num [1:194, 1:2] 4592866 4761515 4658756 4690954 4799839 ... + .. .. .. ..- attr(*, "dimnames")=List of 2 + .. .. .. .. ..$ : NULL + .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" + .. .. ..@ bbox : num [1:2, 1:2] 2749697 1647732 6412269 4604814 + .. .. .. ..- attr(*, "dimnames")=List of 2 + .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" + .. .. .. .. ..$ : chr [1:2] "min" "max" + .. .. ..@ proj4string:Formal class 'CRS' [package "sp"] with 1 slots + .. .. .. .. ..@ projargs: chr " +proj=laea +lat_0=52 +lon_0=10 +x_0=4321000 +y_0=3210000 +ellps=GRS80 +units=m +no_defs" + ..@ time :An 'xts' object on 2005-06-01/2005-07-31 containing: + Data: int [1:61, 1] 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 ... + - attr(*, "dimnames")=List of 2 + ..$ : NULL + ..$ : chr "..1" + Indexed by objects of class: [POSIXct,POSIXt] TZ: GMT + xts Attributes: + NULL + ..@ endTime: POSIXct[1:61], format: "2005-06-02 02:00:00" "2005-06-03 02:00:00" ... +> +> +> +> cleanEx() > nameEx("asCopula-class") > ### * asCopula-class > @@ -1403,8 +1448,9 @@ > flush(stderr()); flush(stdout()) > > ### Name: qCopula_u -> ### Title: The inverse of a bivariate copula given u -> ### Aliases: qCopula_u qCopula_u,copula-method +> ### Title: The inverse of a bivariate copula given u or v +> ### Aliases: qCopula_u qCopula_u,copula-method qCopula_v +> ### qCopula_v,copula-method > ### Keywords: distribution multivariate > > ### ** Examples @@ -1414,8 +1460,13 @@ [1] -5.285787e-09 -1.979502e-10 7.899040e-09 -5.241861e-09 2.531447e-09 [6] 8.471355e-09 -6.502292e-09 -1.261782e-09 3.313125e-09 7.337630e-09 > +> uv <- qCopula_v(asCopula(c(-1,1)), p=rep(0.9,10), v=runif(10,0.9,1)) +> pCopula(uv,asCopula(c(-1,1)))-0.9 + [1] -1.033849e-09 4.513519e-09 8.776860e-09 2.134065e-09 3.399305e-09 + [6] 4.947090e-09 2.469908e-10 4.513539e-09 6.891024e-09 -3.606405e-09 > > +> > cleanEx() > nameEx("rankTransform") > ### * rankTransform @@ -2692,7 +2743,7 @@ > ### > options(digits = 7L) > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n") -Time elapsed: 14.21 0.18 14.52 NA NA +Time elapsed: 15.31 0.21 15.71 NA NA > grDevices::dev.off() null device 1 From noreply at r-forge.r-project.org Tue Mar 25 14:44:06 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 25 Mar 2014 14:44:06 +0100 (CET) Subject: [spcopula-commits] r133 - pkg/demo Message-ID: <20140325134406.616EB185183@r-forge.r-project.org> Author: ben_graeler Date: 2014-03-25 14:44:05 +0100 (Tue, 25 Mar 2014) New Revision: 133 Modified: pkg/demo/stCoVarVineCop.R Log: - updated demo/stCoVarVineCop.R Modified: pkg/demo/stCoVarVineCop.R =================================================================== --- pkg/demo/stCoVarVineCop.R 2014-03-24 19:35:13 UTC (rev 132) +++ pkg/demo/stCoVarVineCop.R 2014-03-25 13:44:05 UTC (rev 133) @@ -1,7 +1,12 @@ -# demo related to the JSS paper -## +###################################################################### +# demo related to a paper (in preparation for JSS) +# Different than the study presented in the above paper, only a tempo- +# ral subset of the European air quality data is used and the set of +# copula family candidates is limited. These chnages have been neces- +# sary to maintain the "runability" of this demo. +###################################################################### +library(spcopula) library(evd) - data(EU_RB) # estimate a GEV at each location for PM10 and EMEP @@ -26,25 +31,6 @@ ## correlation between EMEP and PM10? ## ######################################## -# monCor <- NULL -# monCop <- NULL -# for(month in c("2005-01", "2005-02", "2005-03", "2005-04", -# "2005-05", "2005-06", "2005-07", "2005-08", -# "2005-09", "2005-10", "2005-11", "2005-12")) { -# -# smpl <- cbind(EU_RB_2005[,month,"marPM10"]@data[[1]], -# EU_RB_2005[,month,"marEMEP"]@data[[1]]) -# bool <- !apply(smpl,1,function(row) any(is.na(row))) -# smpl <- smpl[bool,] -# -# monCor <- c(monCor, VineCopula:::fasttau(smpl[,1], smpl[,2])) -# monCop <- append(monCop,list(BiCopSelect(smpl[,1], smpl[,2], familyset=c(2,4)))) -# } -# -# plot(monCor) -# -# table(sapply(monCop, function(x) x$family)) - dayCor <- numeric(61) for(day in 1:61) { smpl <- cbind(EU_RB[,day, "marPM10"]@data[[1]], @@ -104,8 +90,6 @@ abline(h=0) abline(h=0.025,col="grey") -which(tlags==time) - fun1 <- function(x) stDepFun(x*1000, 1, 5:1) curve(fun1, 0, 1600, add=T, col=fiveColors[5]) fun2 <- function(x) stDepFun(x*1000, 2, 5:1)