From noreply at r-forge.r-project.org  Fri May  3 17:23:07 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri,  3 May 2013 17:23:07 +0200 (CEST)
Subject: [spcopula-commits] r95 - / pkg pkg/R pkg/man
Message-ID: <20130503152307.E494B185498@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-05-03 17:23:07 +0200 (Fri, 03 May 2013)
New Revision: 95

Added:
   pkg/man/calcSpTreeDists.Rd
   pkg/man/dropSpTree.Rd
Modified:
   pkg/DESCRIPTION
   pkg/NAMESPACE
   pkg/R/BB1copula.R
   pkg/R/BB6copula.R
   pkg/R/BB7copula.R
   pkg/R/BB8copula.R
   pkg/R/Classes.R
   pkg/R/ClaytonGumbelCopula.R
   pkg/R/asCopula.R
   pkg/R/cqsCopula.R
   pkg/R/joeBiCopula.R
   pkg/R/linkingVineCopula.R
   pkg/R/partialDerivatives.R
   pkg/R/spCopula.R
   pkg/R/spVineCopula.R
   pkg/R/spatialPreparation.R
   pkg/R/utilities.R
   pkg/man/BB8Copula-class.Rd
   pkg/man/calcBins.Rd
   pkg/man/condSpVine.Rd
   pkg/man/cqsCopula-class.Rd
   pkg/man/cqsCopula.Rd
   pkg/man/loglikByCopulasLags.Rd
   pkg/man/neighbourhood-class.Rd
   pkg/man/neighbourhood.Rd
   pkg/man/spCopPredict.Rd
   pkg/man/spVineCopula-class.Rd
   pkg/man/spVineCopula.Rd
   spcopula_0.1-1.tar.gz
   spcopula_0.1-1.zip
Log:
- multilevel spatial copulas!

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/DESCRIPTION	2013-05-03 15:23:07 UTC (rev 95)
@@ -2,7 +2,7 @@
 Type: Package
 Title: copula driven spatial analysis
 Version: 0.1-1
-Date: 2013-04-23
+Date: 2013-05-03
 Author: Benedikt Graeler
 Maintainer: Benedikt Graeler <ben.graeler at uni-muenster.de>
 Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of the spacetime package. Additionally, support for calculating different multivariate return periods is implemented.

Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/NAMESPACE	2013-05-03 15:23:07 UTC (rev 95)
@@ -27,6 +27,7 @@
 # spatial
 export(getNeighbours)
 export(calcBins)
+export(calcSpTreeDists, dropSpTree)
 
 # fitting
 export(fitCorFun, loglikByCopulasLags, fitSpCopula, composeSpCopula)

Modified: pkg/R/BB1copula.R
===================================================================
--- pkg/R/BB1copula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/BB1copula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -25,7 +25,7 @@
 )
 
 # constructor
-BB1Copula <- function (param) {
+BB1Copula <- function (param=c(1,1)) {
   if (any(is.na(param) | param >= c(Inf,Inf) | param[1] <= 0 | param[2] < 1))
     stop(paste("Parameter values out of bounds: theta: (0,Inf), delta: [1,Inf)."))
   new("BB1Copula", dimension = as.integer(2), parameters = param, 
@@ -38,7 +38,8 @@
           function(u, copula, log) {
             linkVineCop.PDF(matrix(u,ncol=copula at dimension),copula, log)
           })
-setMethod("dCopula", signature("matrix","BB1Copula"), function(u, copula, log) linkVineCop.PDF(u, copula, log))
+setMethod("dCopula", signature("matrix","BB1Copula"), 
+          function(u, copula, log) linkVineCop.PDF(u, copula, log))
 
 ## jcdf ##
 setMethod("pCopula", signature("numeric","BB1Copula"), 
@@ -95,7 +96,7 @@
 )
 
 # constructor
-surBB1Copula <- function (param) {
+surBB1Copula <- function (param=c(1,1)) {
   if (any(is.na(param) | param >= c(Inf,Inf) | param[1] <= 0 | param[2] < 1))
     stop(paste("Parameter values out of bounds: theta: (0,Inf), delta: [1,Inf)."))
   new("surBB1Copula", dimension = as.integer(2), parameters = param, 
@@ -162,7 +163,7 @@
 )
 
 # constructor
-r90BB1Copula <- function (param) {
+r90BB1Copula <- function (param=c(-1,-1)) {
   if (any(is.na(param) | param[1] >= 0 | param[2] > -1 | param <= c(-Inf,-Inf)))
     stop(paste("Parameter values out of bounds: theta: (-Inf,0), delta: (-Inf,-1]."))
   new("r90BB1Copula", dimension = as.integer(2), parameters = param, 
@@ -216,7 +217,7 @@
 )
 
 # constructor
-r270BB1Copula <- function (param) {
+r270BB1Copula <- function (param=c(-1,-1)) {
   if (any(is.na(param) | param[1] >= 0 | param[2] > -1 | param <= c(-Inf,-Inf)))
     stop(paste("Parameter values out of bounds: theta: (-Inf,0), delta: (-Inf,-1]."))
   new("r270BB1Copula", dimension = as.integer(2), parameters = param, 

Modified: pkg/R/BB6copula.R
===================================================================
--- pkg/R/BB6copula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/BB6copula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -27,7 +27,7 @@
 )
 
 # constructor
-BB6Copula <- function (param) {
+BB6Copula <- function (param=c(1,1)) {
   if (any(is.na(param) | param >= c(Inf, Inf) | param < c(1,1)))
     stop("Parameter value(s) out of bound(s): theta: [1,Inf), delta: [1,Inf).")
   new("BB6Copula", dimension = as.integer(2), parameters = param, 
@@ -98,7 +98,7 @@
 )
 
 # constructor
-surBB6Copula <- function (param) {
+surBB6Copula <- function (param=c(1,1)) {
   if (any(is.na(param) | param >= c(Inf, Inf) | param < c(1,1)))
     stop("Parameter value(s) out of bound(s): theta: [1,Inf), delta: [1,Inf).")
   new("surBB6Copula", dimension = as.integer(2), parameters = param, 
@@ -165,7 +165,7 @@
 )
 
 # constructor
-r90BB6Copula <- function (param) {
+r90BB6Copula <- function (param=c(-1,-1)) {
   if (any(is.na(param) | param > c(-1,-1) | param <= c(-Inf,-Inf)))
     stop("Parameter value out of bound: theta: (-Inf,1], delta: (-Inf,1].")
   new("r90BB6Copula", dimension = as.integer(2), parameters = param, 
@@ -219,7 +219,7 @@
 )
 
 # constructor
-r270BB6Copula <- function (param) {
+r270BB6Copula <- function (param=c(-1,-1)) {
   if (any(is.na(param) | param > c(-1,-1) | param <= c(-Inf,-Inf)))
     stop("Parameter value out of bound: theta: (-Inf,1], delta: (-Inf,1].")
   new("r270BB6Copula", dimension = as.integer(2), parameters = param, 

Modified: pkg/R/BB7copula.R
===================================================================
--- pkg/R/BB7copula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/BB7copula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -25,7 +25,7 @@
 )
 
 # constructor
-BB7Copula <- function (param) {
+BB7Copula <- function (param=c(1,1)) {
   if (any(is.na(param) | param >= c(Inf, Inf) | param[1] < 1 | param[2] <= 0))
     stop(paste("Parameter values out of bounds: theta: [1,Inf), delta: (0,Inf)."))
   new("BB7Copula", dimension = as.integer(2), parameters = param,
@@ -98,7 +98,7 @@
 )
 
 # constructor
-surBB7Copula <- function (param) {
+surBB7Copula <- function (param=c(1,1)) {
   if (any(is.na(param) | param >= c(Inf, Inf) | param[1] < 1 | param[2] <= 0))
     stop(paste("Parameter values out of bounds: theta: [1,Inf), delta: (0,Inf)."))
   new("surBB7Copula", dimension = as.integer(2), parameters = param, 
@@ -167,7 +167,7 @@
 )
 
 # constructor
-r90BB7Copula <- function (param) {
+r90BB7Copula <- function (param=c(-1,-1)) {
   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("r90BB7Copula", dimension = as.integer(2), parameters = param, 
@@ -221,7 +221,7 @@
 )
 
 # constructor
-r270BB7Copula <- function (param) {
+r270BB7Copula <- function (param=c(-1,-1)) {
   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, 

Modified: pkg/R/BB8copula.R
===================================================================
--- pkg/R/BB8copula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/BB8copula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -27,7 +27,7 @@
 )
 
 # constructor
-BB8Copula <- function (param) {
+BB8Copula <- function (param=c(1,1)) {
   if (any(is.na(param)) | param[1] >= Inf | param[2] > 1 | param[1] < 1 | param[2] <= 0)
     stop("Parameter value out of bound: theta: [1,Inf), delta: (0,1].")
   new("BB8Copula", dimension = as.integer(2), parameters = param, 
@@ -98,7 +98,7 @@
 )
 
 # constructor
-surBB8Copula <- function (param) {
+surBB8Copula <- function (param=c(1,1)) {
   if (any(is.na(param)) | param[1] >= Inf | param[2] > 1 | param[1] < 1 | param[2] <= 0)
     stop("Parameter value out of bound: theta: [1,Inf), delta: (0,1].")
   new("surBB8Copula", dimension = as.integer(2), parameters = param,
@@ -165,7 +165,7 @@
 )
 
 # constructor
-r90BB8Copula <- function (param) {
+r90BB8Copula <- function (param=c(-1,-1)) {
   if (any(is.na(param) | param[1] > -1 | param[2] >= 0 | param[1] <= -Inf | param[2] < -1))
     stop("Parameter value out of bound: theta: (-Inf,-1], delta: [-1,0).")
   new("r90BB8Copula", dimension = as.integer(2), parameters = param, 
@@ -219,7 +219,7 @@
 )
 
 # constructor
-r270BB8Copula <- function (param) {
+r270BB8Copula <- function (param=c(-1,-1)) {
   val <- new("r270BB8Copula", dimension = as.integer(2), parameters = param, param.names = c("theta", "delta"), param.lowbnd = c(-Inf, -1), param.upbnd = c(-1, 0), family=40, fullname = "270 deg rotated BB8 copula family. Number 40 in CDVine.")
   val
 }
@@ -257,4 +257,32 @@
 setMethod("rCopula", signature("numeric","r270BB8Copula"), linkVineCop.r)
 
 setMethod("tau",signature("r270BB8Copula"),linkVineCop.tau)
-setMethod("tailIndex",signature("r270BB8Copula"),linkVineCop.tailIndex)
\ No newline at end of file
+setMethod("tailIndex",signature("r270BB8Copula"),linkVineCop.tailIndex)
+
+### et union
+
+setClassUnion("twoParamBiCop",c("BB1Copula","BB6Copula","BB7Copula","BB8Copula",
+                                "surBB1Copula","surBB6Copula","surBB7Copula","surBB8Copula",
+                                "r90BB1Copula","r90BB6Copula","r90BB7Copula","r90BB8Copula",
+                                "r270BB1Copula","r270BB6Copula","r270BB7Copula","r270BB8Copula"))
+
+fitCopula.twoParamBiCop <- function(copula, data, method = "mpl", 
+                                    estimate.variance = FALSE) {
+  stopifnot(method=="mpl")
+  fit <- BiCopEst(data[,1], data[,2], copula at family, "mle",
+                  se=estimate.variance)
+  
+  if(!estimate.variance) {
+    fit$se <- NA
+    fit$se2 <- NA
+  }
+  
+  copFit <- copulaFromFamilyIndex(copula at family, fit$par, fit$par2)
+  new("fitCopula", estimate = c(fit$par, fit$par2), var.est = cbind(fit$se, fit$se2), 
+      method = "estimation based on 'maximum pseudo-likelihood' via BiCopEst", 
+      loglik = sum(dCopula(data, copFit, log=T)),
+      fitting.stats=list(convergence = as.integer(NA)), nsample = nrow(data),
+      copula=copFit)
+}
+
+setMethod("fitCopula", signature("twoParamBiCop"), fitCopula.twoParamBiCop)
\ No newline at end of file

Modified: pkg/R/Classes.R
===================================================================
--- pkg/R/Classes.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/Classes.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -17,9 +17,18 @@
 
 # the lower bound of the parameter a dependening on the parameter b
 limA <- function (b) {
-  (b-3-sqrt(9+6*b-3*b^2))/2
+  stopifnot(abs(b) <= 1)
+  0.5*(-sqrt(-3*b^2+6*b+9)+b-3)
 }
 
+# the lower and upper bound of the parameter b dependening on the parameter a
+limB <- function (a) {
+  stopifnot(a <=1 & a >= -3)
+  if(a>-2)
+    return(c(-1,1))
+  pmax(pmin(0.5*(c(-1,1)*(sqrt(3)*sqrt(-a^2-2*a+3))+a+3),1),-1)
+}
+
 setClass("asCopula",
   representation = representation("copula"),
   validity = validAsCopula,
@@ -29,10 +38,29 @@
 ####
 ## a symmetric copula with cubic and quadratic sections
 
-validCqsCopula <- validAsCopula
+validCqsCopula <- function(object) {
+  if (object at dimension != 2)
+    return("Only copulas with cubic quadratic sections 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")
+  if (any(is.na(param) | param > upper | param < lower))
+    return("Parameter value out of bound")
+  if (length(object at fixed >0)){
+    if(!("a" %in% object at fixed | "b" %in% object at fixed))
+      return("The slot fixed may only refer to \"a\" or \"b\".")
+    if ("a" %in% object at fixed & "b" %in% object at fixed)
+      return("Only one of the parameters may be kept fixed.")
+  }
+  else return (TRUE)
+}
 
 setClass("cqsCopula",
-  representation = representation("copula"),
+  representation = representation("copula",fixed="character"),
   validity = validCqsCopula,
   contains = list("copula")
 )
@@ -91,7 +119,8 @@
 #                             assings valid parameters to the copulas involved
 
 validSpCopula <- function(object) {
-  if (length(object at components) != length(object at distances)) return("Length of components does not equal length of distances. \n Note: The last distance must give the range and it is automatically associated with the indepenence copula.")
+  if (length(object at components) != length(object at distances)) 
+    return("Length of components does not equal length of distances. \n Note: The last distance must give the range and it is automatically associated with the indepenence copula.")
   check.upper <- NULL
   check.lower <- NULL
   
@@ -146,7 +175,7 @@
     return("Number of provided copulas does not match given dimension.")
   if(!any(unlist(lapply(object at copulas,function(x) is(x,"copula")))))
     return("Not all provided copulas in your list are indeed copulas.")
-  else return (TRUE)
+  return (TRUE)
 }
 
 setOldClass("RVineMatrix")
@@ -163,13 +192,22 @@
 ## Spatial Vine Copula ##
 #########################
 
-validSpVineCopula <- function(object) {
-  return(validObject(object at spCop)&validObject(object at vineCop))
+validMixedSpVineCopula <- function(object) {
+  return(all(sapply(object at spCop,validSpCopula) & validObject(object at topCop)))
 }
 
-setClass("spVineCopula", representation("copula",spCop="spCopula",vineCop="vineCopula"),
-         validity = validSpVineCopula, contains=list("copula"))
+setClass("mixedSpVineCopula", representation("copula", spCop="list", topCop="copula"),
+         validity = validMixedSpVineCopula, contains=list("copula"))
 
+validPureSpVineCopula <- function(object) {
+  return(all(sapply(object at spCop,validSpCopula)))
+}
+
+setClass("pureSpVineCopula", representation("copula", spCop="list"),
+         validity = validPureSpVineCopula, contains=list("copula"))
+
+setClassUnion("spVineCopula",c("mixedSpVineCopula","pureSpVineCopula"))
+
 ########################################
 ## spatial classes providing the data ##
 ########################################
@@ -193,19 +231,30 @@
 validNeighbourhood <- function(object) {
   sizeN <- ncol(object at distances)+1
   nVars <- length(object at var)
-  if (nrow(object at data) != nrow(object at distances)) return("Data and distances have unequal number of rows.")
-  if (ncol(object at data) %% (sizeN-object at prediction) != 0) return("Data and distances have non matching number of columns.")
-  if (nrow(object at data) != nrow(object at index)) return("Data and index have unequal number of rows.")
-  if (ncol(object at distances) != ncol(object at index)) return("Data and index have unequal number of columns.")
-  if (ncol(object at data) != (sizeN-object at prediction) * nVars) return(paste("Number of columns in data does not equal the product of the neighbourhood's size (",sizeN,") with number of variables (",nVars,").",sep=""))
-  else return(TRUE)
+  if (object at prediction & is.null(object at dataLocs))
+    return("The locations of the data have to provided for the estimation procedure.")
+  if (nrow(object at data) != nrow(object at distances)) 
+    return("Data and distances have unequal number of rows.")
+  if (ncol(object at data) %% (sizeN-object at prediction) != 0) 
+    return("Data and distances have non matching number of columns.")
+  if (nrow(object at data) != nrow(object at index)) 
+    return("Data and index have unequal number of rows.")
+  if (ncol(object at distances) != ncol(object at index)) 
+    return("Data and index have unequal number of columns.")
+  if (ncol(object at data) != (sizeN-object at prediction) * nVars) 
+    return(paste("Number of columns in data does not equal the product of the neighbourhood's size (",sizeN,") with number of variables (",nVars,").",sep=""))
+  else 
+    return(TRUE)
 }
 
+setClassUnion("optionalDataLocs",c("NULL","Spatial"))
+
 setClass("neighbourhood",
          representation = representation(data = "data.frame", 
                                          distances="matrix", 
                                          index="matrix",
-                                         locations="Spatial", 
+                                         locations="Spatial",
+                                         dataLocs="optionalDataLocs",
                                          var="character", 
                                          prediction="logical"),
          validity = validNeighbourhood, contains = list("Spatial"))

Modified: pkg/R/ClaytonGumbelCopula.R
===================================================================
--- pkg/R/ClaytonGumbelCopula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/ClaytonGumbelCopula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -30,7 +30,7 @@
 )
 
 # constructor
-surClaytonCopula <- function (param) {
+surClaytonCopula <- function (param=1) {
   new("surClaytonCopula", dimension = as.integer(2), parameters = param, param.names = c("theta"),
       param.lowbnd = 0, param.upbnd = Inf, family=13, 
       fullname = "Survival Clayton copula family. Number 13 in CDVine.")
@@ -54,14 +54,14 @@
 # ddu
 setMethod("dduCopula", signature("numeric","surClaytonCopula"), 
           function(u, copula, log) {
-            linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula, log)
+            linkVineCop.ddu(matrix(u,ncol=copula at dimension),copula)
           })
 setMethod("dduCopula", signature("matrix","surClaytonCopula"), linkVineCop.ddu)
 
 # ddv
 setMethod("ddvCopula", signature("numeric","surClaytonCopula"), 
           function(u, copula, log) {
-            linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula, log)
+            linkVineCop.ddv(matrix(u,ncol=copula at dimension),copula)
           })
 setMethod("ddvCopula", signature("matrix","surClaytonCopula"), linkVineCop.ddv)
 
@@ -104,7 +104,7 @@
 )
 
 # constructor
-r90ClaytonCopula <- function (param) {
+r90ClaytonCopula <- function (param=-1) {
   new("r90ClaytonCopula", dimension = as.integer(2), parameters = param, param.names = c("theta", "delta"),
       param.lowbnd = -Inf, param.upbnd = 0, family=23, 
       fullname = "90 deg rotated Clayton copula family. Number 23 in CDVine.")
@@ -164,7 +164,7 @@
 )
 
 # constructor
-r270ClaytonCopula <- function (param) {
+r270ClaytonCopula <- function (param=-1) {
   new("r270ClaytonCopula", dimension = as.integer(2), parameters = param, param.names = c("theta", "delta"), 
       param.lowbnd = -Inf, param.upbnd = 0, family=33, 
       fullname = "270 deg rotated Clayton copula family. Number 33 in CDVine.")
@@ -245,7 +245,7 @@
          )
 
 # constructor
-surGumbelCopula <- function (param) {
+surGumbelCopula <- function (param=1) {
   new("surGumbelCopula", dimension = as.integer(2), parameters = param, param.names = c("theta"),
       param.lowbnd = 1, param.upbnd = Inf, family=14, 
       fullname = "Survival Gumbel copula family. Number 14 in CDVine.")
@@ -320,7 +320,7 @@
          )
 
 # constructor
-r90GumbelCopula <- function (param) {
+r90GumbelCopula <- function (param=-1) {
   new("r90GumbelCopula", dimension = as.integer(2), parameters = param, param.names = c("theta", "delta"),
       param.lowbnd = -Inf, param.upbnd = -1, family=24, 
       fullname = "90 deg rotated Gumbel copula family. Number 24 in CDVine.")
@@ -380,7 +380,7 @@
          )
 
 # constructor
-r270GumbelCopula <- function (param) {
+r270GumbelCopula <- function (param=-1) {
   new("r270GumbelCopula", dimension = as.integer(2), parameters = param, param.names = c("theta", "delta"), 
       param.lowbnd = -Inf, param.upbnd = -1, family=34, 
       fullname = "270 deg rotated Gumbel copula family. Number 34 in CDVine.")

Modified: pkg/R/asCopula.R
===================================================================
--- pkg/R/asCopula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/asCopula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -6,7 +6,7 @@
 # (see Example 3.16 in: Nelsen, Roger B. (2006): An Introduction to Copulas, second edition, Springer)
 
 # constructor
-asCopula <- function (param) {
+asCopula <- function (param=c(0,0)) {
   val <- new("asCopula", dimension = as.integer(2), parameters = param, 
              param.names = c("a", "b"), param.lowbnd = c(limA(param[2]), -1),
              param.upbnd = c(1, 1), fullname = "asymmetric copula family with cubic and quadratic sections")

Modified: pkg/R/cqsCopula.R
===================================================================
--- pkg/R/cqsCopula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/cqsCopula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -1,3 +1,6 @@
+## make fitCopula generic
+setGeneric("fitCopula")
+
 ######################################################
 ##                                                  ##
 ## a symmetric copula with cubic quadratic sections ##
@@ -4,16 +7,15 @@
 ##                                                  ##
 ######################################################
 
-cqsCopula <- function (param) {
-    val <- new("cqsCopula", dimension = as.integer(2), parameters = param, 
+cqsCopula <- function (param=c(0,0), fixed=character(0)) {
+  new("cqsCopula", dimension = as.integer(2), parameters = param, 
       param.names = c("a", "b"), param.lowbnd = c(limA(param[2]),-1),
-      param.upbnd = c(1, 1), fullname = "copula family with cubic quadratic sections")
-    val
+      param.upbnd = c(1, 1), 
+      fullname = "copula family with cubic quadratic sections", fixed=fixed)
 }
 
 ## density ##
-
-dCQSec <- function (u, copula) {
+dCQSec <- function (u, copula, log=F) {
   a <- copula at parameters[1]
   b <- copula at parameters[2]
   
@@ -22,17 +24,19 @@
   u1 <- u[, 1]
   u2 <- u[, 2]
   
-  return(pmax(1-b*(1-2*u2)*(1-2*u1)+(b-a)*(1-u2)*(1-3*u2)*(1-u1)*(1-3*u1),0))
+  if (log)
+    return(log(pmax(1-b*(1-2*u2)*(1-2*u1)+(b-a)*(1-u2)*(1-3*u2)*(1-u1)*(1-3*u1),0)))
+  else
+    return(pmax(1-b*(1-2*u2)*(1-2*u1)+(b-a)*(1-u2)*(1-3*u2)*(1-u1)*(1-3*u1),0))
 }
 
 setMethod("dCopula", signature("numeric", "cqsCopula"),
-          function(u, copula, ...) {
-            dCQSec(matrix(u,ncol=copula at dimension), copula)
+          function(u, copula, log) {
+            dCQSec(matrix(u,ncol=copula at dimension), copula, log)
           })
 setMethod("dCopula", signature("matrix", "cqsCopula"), dCQSec)
 
 ## jcdf ##
-
 pCQSec <- function (u, copula) {
     a <- copula at parameters[1]
     b <- copula at parameters[2]
@@ -42,6 +46,7 @@
     u2 <- u[, 2]
 return(u1*u2*(1- b*(1-u1)*(1-u2) + (b-a)*(1-u2)^2*(1-u1)^2))
 }
+
 setMethod("pCopula", signature("numeric", "cqsCopula"),
           function(u, copula, ...) {
             pCQSec(matrix(u,ncol=copula at dimension), copula)
@@ -55,7 +60,7 @@
 solveCubicEq <- function(a,b,c,d){
 eps <- .Machine$double.eps
 
-# using the reduced equation z^3 + 3 * p * z + q = 0 with:
+  # using the reduced equation z^3 + 3 * p * z + q = 0 with:
   p <- 3*a*c-b^2
   q <- 2*b^3-9*a*b*c+27*a^2*d
   D <- q^2+4*p^3
@@ -113,42 +118,43 @@
 ## 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) {
-    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]
 
-    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
 
-# 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)
 
-v <- solveCubicEq(c3,c2,c1,c0)
-
-filter <- function(vec){
-  vec <- vec[!is.na(vec)]
-  return(vec[vec >= 0 & vec <= 1])
+  return(v)
+  
+#   filter <- function(vec){
+#     vec <- vec[!is.na(vec)]
+#     return(vec[vec >= 0 & vec <= 1])
+#   }
+# 
+#   return(apply(v,1,filter))
 }
 
-return(apply(v,1,filter))
-}
-
 setMethod("invdduCopula", signature("numeric","cqsCopula","numeric"), invdduCQSec)
 
 ## partial derivative ddv
 
 ddvCQSec <- function (u, copula) {
-    a <- copula at parameters[1]
-    b <- copula at parameters[2]
-    if (!is.matrix(u)) u <- matrix(u, ncol = 2)
+  a <- copula at parameters[1]
+  b <- copula at parameters[2]
+  if (!is.matrix(u)) u <- matrix(u, ncol = 2)
 
-    u1 <- u[, 1]
-    u2 <- u[, 2]
+  u1 <- u[, 1]
+  u2 <- u[, 2]
 
-return(u1-b*(u1-2*u1*u2-u1^2+2*u1^2*u2)+(b-a)*(u1-2*u1^2+u1^3-4*u1*u2+8*u1^2*u2-4*u1^3*u2+3*u1*u2^2-6*u1^2*u2^2+3*u1^3*u2^2))
+  return(u1-b*(u1-2*u1*u2-u1^2+2*u1^2*u2)+(b-a)*(u1-2*u1^2+u1^3-4*u1*u2+8*u1^2*u2-4*u1^3*u2+3*u1*u2^2-6*u1^2*u2^2+3*u1^3*u2^2))
 }
 
 setMethod("ddvCopula", signature("numeric","cqsCopula"),
@@ -160,29 +166,30 @@
 ## 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) {
-    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]
+  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
+  # 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)
+  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)
 
 ## random number generator
@@ -227,62 +234,73 @@
 #  one of kendall or spearman according to the calculation of moa
 
 fitCQSec.itau <- function(copula, data, estimate.variance, tau=NULL) {
-if(is.null(tau))
-  tau <- VineCopula:::fasttau(data[,1],data[,2])
-esti <- fitCQSec.moa(tau, data, method="itau")
-copula <- cqsCopula(esti)
-return(new("fitCopula",
-  estimate = esti, 
-  var.est = matrix(NA), 
-  method = "Inversion of Kendall's tau and MLE",
-  loglik = sum(log(dCopula(data, copula))),
-  fitting.stats=list(convergence = as.integer(NA)),
-  nsample = nrow(data),
-  copula=copula
-))
-}
+  if(is.null(tau))
+    tau <- VineCopula:::fasttau(data[,1],data[,2])
+  if(copula at fixed=="a")
+    esti <- c(copula at parameters[1], iTauCQSec.a(copula at parameters[1], tau))
+  if(copula at fixed=="b")
+    esti <- c(iTauCQSec.b(copula at parameters[2], tau),copula at parameters[2])
+  else
+    esti <- fitCQSec.moa(tau, data, method="itau")
+  
+  copula <- cqsCopula(esti, fixed=copula at fixed)
 
-fitCQSec.irho <- function(copula, data, estimate.variance){
-rho <- cor(data,method="spearman")[1,2]
-esti <- fitCQSec.moa(rho, data, method="irho")
-copula <- cqsCopula(esti)
-return(new("fitCopula",
-  estimate = esti, 
-  var.est = matrix(NA), 
-  method = "Inversion of Spearman's rho and MLE",
-  loglik = sum(log(dCopula(data, copula))),
-  fitting.stats=list(convergence = as.integer(NA)),
-  nsample = nrow(data),
-  copula=copula
-))
+  new("fitCopula", estimate = esti, var.est = matrix(NA), 
+      method = "Inversion of Kendall's tau and MLE", 
+      loglik = sum(dCopula(data, copula, log=T)),
+      fitting.stats=list(convergence = as.integer(NA)), nsample = nrow(data),
+      copula=copula)
 }
 
-fitCQSec.moa <- function(moa, data, method="itau", tol=.Machine$double.eps^.5) {
-smpl <- as.matrix(data)
 
-iTau <- function(p) {
-  iTauCQSec(p,moa)
-}
+fitCQSec.irho <- function(copula, data, estimate.variance, rho=NULL){
+  if(is.null(rho))
+    rho <- cor(data,method="spearman")[1,2]
+  if(copula at fixed=="a")
+    esti <- c(copula at parameters[1], iRhoCQSec.a(copula at parameters[1],rho))
+  if(copula at fixed=="b")
+    esti <- c(iRhoCQSec.b(copula at parameters[2],rho),copula at parameters[2])
+  else
+    esti <- fitCQSec.moa(rho, data, method="irho")
+  
+  copula <- cqsCopula(esti, fixed=copula at fixed)
 
-iRho <- function(p) {
-  iRhoCQSec(p,moa)
+  new("fitCopula", estimate = esti, var.est = matrix(NA), 
+      method = "Inversion of Spearman's rho and MLE", 
+      loglik = sum(dCopula(data, copula, log=T)),
+      fitting.stats=list(convergence = as.integer(NA)), nsample = nrow(data),
+      copula=copula)
 }
 
-iFun <- switch(method, itau=iTau, irho=iRho)
 
-sec <- function (parameters) {
-res <- NULL
-for(param in parameters) {
-  res <- rbind(res, -sum(log( dCQSec(smpl, cqsCopula(c(iFun(param),param))) )))
-}
-return(res)
-}
 
-b <- optimize(sec,c(-1,1), tol=tol)$minimum
+fitCQSec.moa <- function(moa, data, method="itau", tol=.Machine$double.eps^.5) {
+  smpl <- as.matrix(data)
 
-param <- c(iFun(b),b)
+  iRho.CQS <- function(p) {
+    iRhoCQSec.b(p,moa)
+  }
+  
+  iTau.CQS <- function(p) {
+    iTauCQSec.b(p,moa)
+  }
+  
+  iFun <- switch(method, itau=iTau.CQS, irho=iRho.CQS)
 
-return(param)
+  sec <- function (parameters) {
+    res <- NULL
+    for(param in parameters) {
+      res <- rbind(res, -sum(dCQSec(smpl, cqsCopula(c(iFun(param),param)),log=T)))
+    }
+    
+    return(res)
+  }
+
+  b <- optimize(sec,c(-1,1), tol=tol)$minimum
+
+  param <- c(iFun(b),b)
+
+  return(param)
 }
 
 # maximum log-likelihood estimation of a and b using optim
@@ -290,26 +308,60 @@
 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.")
   
-  optFun <- function(param=c(0,0)) {
-    if(any(param > 1) | param[2] < -1 | param[1] < limA(param[2])) return(1)
-    return(-sum(log( dCQSec(data, cqsCopula(param)) )))
-  }
+  if (length(copula at fixed)==0) {
+    optFun <- function(param=c(0,0)) {
+      if(any(param > 1) | param[2] < -1 | param[1] < limA(param[2])) 
+        return(100)
+      return(-sum(log( dCQSec(data, cqsCopula(param)) )))
+    }
   
-  optimized <- optim(par=start, fn=optFun, method = optim.method, 
-                     lower=lower, upper=upper, control = optim.control)
+    optimized <- optim(par=start, fn=optFun, method = optim.method, 
+                       lower=lower, upper=upper, control = optim.control)
   
-  return(new("fitCopula", estimate = optimized$par, var.est = matrix(NA),
-             method = "Numerical MLE over the full range.",
-             loglik = -optimized$value, fitting.stats= optimized,
-             nsample = nrow(data), copula=cqsCopula(optimized$par)))
+    return(new("fitCopula", estimate = optimized$par, var.est = matrix(NA),
+               method = "Numerical MLE over the full range.",
+               loglik = -optimized$value, fitting.stats= optimized,
+               nsample = nrow(data), copula=cqsCopula(optimized$par)))
+  } else {  
+    optFunFixed <- function(p) {
+      param <- switch(copula at fixed, a=c(copula at parameters[1],p),
+                      b=c(p,copula at parameters[2]))
+      if(any(param > 1) | param[2] < -1 | param[1] < limA(param[2])) 
+        return(100)
+      return(-sum(log( dCQSec(data, cqsCopula(param)) )))
+    }
+  
+    optimized <- optimise(optFunFixed, c(-3,1))
+  
+    optPar <- switch(copula at fixed, a=c(copula at parameters[1],optimized$minimum),
+                     b=c(optimized$minimum,copula at parameters[2]))
+  
+    return(new("fitCopula", estimate = optimized$minimum, var.est = matrix(NA),
+               method = "Numerical MLE over the full range.",
+               loglik = -optimized$objective, fitting.stats=list(),
+               nsample = nrow(data), copula=cqsCopula(optPar)))
+  }
 }
 
 ####
 
-iTauCQSec <- function(b,tau=0) {
-return(min(max(limA(b),(b^2 + 75*b + 450*tau)/(b - 25)),1))
+iTauCQSec.a <- function(a, tau=0) {
+  limits <- limB(a)
+  min(max(limits[1],0.5*(sqrt(a^2-250*a-1800*tau+5626)+a-75)),limits[2])
 }
 
+iTauCQSec.b <- function(b,tau=0) {
+  min(max(limA(b),(b^2 + 75*b + 450*tau)/(b - 25)),1)
+}
+
+setMethod("iTau",signature="cqsCopula",
+          function(copula, tau) {
+            switch(copula at fixed,
+                   a=c(copula at parameters[1],iTauCQSec.a(copula at parameters[1],tau)), 
+                   b=c(iTauCQSec.b(copula at parameters[2],tau),copula at parameters[2]),
+                   stop("iTau may only be used for cqsCopula with one parameter fixed."))
+            })
+
 ####
 
 tauCQSec <- function(copula){
@@ -325,10 +377,23 @@
 # find parameter "a" for parameter "b" under a given measure of association "rho" 
 # it may return a value exceeding the limit of "a" which may result in an invalid copula.
 
-iRhoCQSec <- function(b, rho=0) {
-  return(min(max(limA(b),-3*b - 12*rho),1))
+iRhoCQSec.a <- function(a, rho=0) {
+  limits <- limB(a)
+  min(max(limits[1],-a/3 - 4*rho),limits[2])
 }
 
+iRhoCQSec.b <- function(b, rho=0) {
+  min(max(limA(b),-3*b - 12*rho),1)
+}
+
+setMethod("iRho",signature="cqsCopula",
+          function(copula, rho) {
+            switch(copula at fixed,
+                   a=function(copula, rho) c(a,iRhoCQSec.a(copula at parameters[1],rho)), 
+                   b=function(copula, rho) c(iRhoCQSec.b(copula at parameters[2],rho),b),
+                   stop("iRho may only be used for cqsCopula with one parameter fixed."))
+            })
+
 ####
 
 rhoCQSec <- function(copula){

Modified: pkg/R/joeBiCopula.R
===================================================================
--- pkg/R/joeBiCopula.R	2013-04-23 14:17:11 UTC (rev 94)
+++ pkg/R/joeBiCopula.R	2013-05-03 15:23:07 UTC (rev 95)
@@ -25,7 +25,7 @@
 )
 
 # constructor
-joeBiCopula <- function (param) {
+joeBiCopula <- function (param=2) {
   if (any(is.na(param) | param >= Inf | param <= 1 ))
     stop("Parameter is outside of the allowed interval (1,Inf).")
   new("joeBiCopula", dimension = as.integer(2), parameters = param, param.names = c("theta"),
@@ -104,7 +104,7 @@
 )
 
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/spcopula -r 95

From noreply at r-forge.r-project.org  Tue May 21 10:26:21 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 21 May 2013 10:26:21 +0200 (CEST)
Subject: [spcopula-commits] r96 - / pkg pkg/R pkg/demo pkg/man
Message-ID: <20130521082621.DE6F71851B4@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-05-21 10:26:21 +0200 (Tue, 21 May 2013)
New Revision: 96

Modified:
   pkg/DESCRIPTION
   pkg/R/spVineCopula.R
   pkg/R/spatialPreparation.R
   pkg/R/vineCopulas.R
   pkg/demo/MRP.R
   pkg/demo/spCopula.R
   pkg/man/loglikByCopulasLags.Rd
   pkg/man/neighbourhood-class.Rd
   spcopula_0.1-1.tar.gz
   spcopula_0.1-1.zip
Log:
- bug fixes in the spatial copula demo spCopula.R

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/DESCRIPTION	2013-05-21 08:26:21 UTC (rev 96)
@@ -2,13 +2,13 @@
 Type: Package
 Title: copula driven spatial analysis
 Version: 0.1-1
-Date: 2013-05-03
+Date: 2013-05-21
 Author: Benedikt Graeler
 Maintainer: Benedikt Graeler <ben.graeler at uni-muenster.de>
 Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of the spacetime package. Additionally, support for calculating different multivariate return periods is implemented.
 License: GPL-2
 LazyLoad: yes
-Depends: copula (>= 0.999-5), spacetime (>= 1.0-2), VineCopula, methods, R (>= 2.15.0)
+Depends: copula (>= 0.999-6), spacetime (>= 1.0-2), VineCopula, methods, R (>= 2.15.0)
 URL: http://r-forge.r-project.org/projects/spcopula/
 Collate:
   Classes.R

Modified: pkg/R/spVineCopula.R
===================================================================
--- pkg/R/spVineCopula.R	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/R/spVineCopula.R	2013-05-21 08:26:21 UTC (rev 96)
@@ -238,7 +238,7 @@
     xVals <- attr(condSecVine,"xVals")
     density <- condSecVine(xVals)
     nx <- length(xVals)
-    int <- cumsum(c(0,diff(xVals)*(p*diff(density)+density[-nx])))
+    int <- cumsum(c(0,diff(xVals)*(0.5*diff(density)+density[-nx])))
     lower <- max(which(int <= p))
     m <- (density[lower+1]-density[lower])/(xVals[lower+1]-xVals[lower])
     b <- density[lower]
@@ -268,4 +268,41 @@
   switch(method,
          quantile=spCopPredict.quantile(predNeigh, spVine, margin, p),
          expectation=spCopPredict.expectation(predNeigh, spVine, margin, ...))
-}
\ No newline at end of file
+}
+
+# draw from a spatial vine
+# Algorithm 1 from Aas et al. (2006): Pair-copula constructions of multiple dependence
+
+r.spVineCop <- function(n, spVine, h) {
+  spVineDim <- spVine at dimension
+  
+  sims <- NULL
+  for(runs in 1:n) {
+    init <- runif(spVineDim)
+    res <- init[1]
+    v <- matrix(NA,spVineDim,spVineDim)
+    v[1,1] <- init[1]
+    for (i in 2:spVineDim) { # i <- 2
+      v[i,1] <- init[i]
+      for (k in (i-1):1) { # k <- i-1
+        v[i,1] <- uniroot(function(u) {
+                            v[i,1] - ddvCopula(cbind(u,v[k,k]), spVine at spCop[[k]],
+                                               h=h[[k]][i-k])
+                          }, c(0,1))$root
+      }  
+      res <- c(res,v[i,1])
+      if(i==spVineDim)
+        break()
+      for(j in 1:(i-1)) {
+        v[i,j+1] <- ddvCopula(cbind(v[i,j],v[j,j]),spVine at spCop[[k]], h=h[[j]][i-j])
+      }
+    }
+    sims <- rbind(sims,res)
+  }
+  
+  rownames(sims) <- NULL
+  sims
+}
+
+setMethod("rCopula", signature("numeric","spVineCopula"), 
+          function(n, copula, ...) r.spVineCop(n, copula, ...))
\ No newline at end of file

Modified: pkg/R/spatialPreparation.R
===================================================================
--- pkg/R/spatialPreparation.R	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/R/spatialPreparation.R	2013-05-21 08:26:21 UTC (rev 96)
@@ -54,7 +54,7 @@
       prediction=x at prediction)
 }
 
-setMethod("[", signature("neighbourhood"), selectFromNeighbourhood) 
+setMethod("[[", "neighbourhood", selectFromNeighbourhood) 
 
 ## calculate neighbourhood from SpatialPointsDataFrame
 

Modified: pkg/R/vineCopulas.R
===================================================================
--- pkg/R/vineCopulas.R	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/R/vineCopulas.R	2013-05-21 08:26:21 UTC (rev 96)
@@ -77,9 +77,10 @@
           function(u,copula) pvineCopula(as.matrix(u),copula))
 setMethod("pCopula", signature("matrix","vineCopula"), pvineCopula)
 
+## simulation
+
 rRVine <- function(n, copula) {
   RVM <- copula at RVM
-#   class(RVM) <- "RVineMatrix"
   RVineSim(n, RVM)
 }
 

Modified: pkg/demo/MRP.R
===================================================================
--- pkg/demo/MRP.R	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/demo/MRP.R	2013-05-21 08:26:21 UTC (rev 96)
@@ -10,7 +10,7 @@
 cor(triples,method="kendall")
 
 # estiamte the BB7 copula by means of maximum likelihood
-copQV <- fitCopula(BB7Copula(param=c(2,14)), peakVol, method="ml", 
+copQV <- fitCopula(BB7Copula(param=c(2,14)), peakVol, method="mpl", 
                    start=c(2,14), estimate.variance=F)@copula
 copQV
 

Modified: pkg/demo/spCopula.R
===================================================================
--- pkg/demo/spCopula.R	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/demo/spCopula.R	2013-05-21 08:26:21 UTC (rev 96)
@@ -47,30 +47,31 @@
                                             claytonCopula(0), frankCopula(1), 
                                             gumbelCopula(1), joeBiCopula(1.5),
                                             indepCopula()))
-bestFitTau <- apply(apply(loglikTau, 1, rank, na.last=T), 2, 
+bestFitTau <- apply(apply(loglikTau$loglik, 1, rank, na.last=T), 2, 
                     function(x) which(x==7))
-bestFitTau
+colnames(loglikTau$loglik)[bestFitTau]
 
 ## set-up a spatial Copula ##
 spCop <- spCopula(components=list(normalCopula(0), tCopula(0),
                                   frankCopula(1), normalCopula(0), 
-                                  claytonCopula(0), claytonCopula(0), 
                                   claytonCopula(0), claytonCopula(0),
+                                  claytonCopula(0), claytonCopula(0),
                                   claytonCopula(0), indepCopula()),
                   distances=bins$meanDists,
                   spDepFun=calcKTauPol, unit="m")
 
 ## compare spatial copula loglik by lag:
 spLoglik <- NULL
-for(i in 1:length(bins$lags)) { # i <- 8
+for(i in 1:length(bins$lags)) { # i <- 7
+  cat("Lag",i,"\n")
   spLoglik <- c(spLoglik,
-                sum(dCopula(u=bins$lagData[[i]], spCop,log=T,
-                            h=bins$lags[[i]][,3])))
+                sum((dCopula(u=bins$lagData[[i]], spCop,log=T,
+                            h=bins$lags[[i]][,3]))))
 }
 
 plot(spLoglik, ylab="log-likelihood", xlim=c(1,11)) 
-points(loglikTau[cbind(1:10,bestFitTau)], col="green", pch=16)
-points(loglikTau[,1], col="red", pch=5)
+points(loglikTau$loglik[cbind(1:10,bestFitTau)], col="green", pch=16)
+points(loglikTau$loglik[,1], col="red", pch=5)
 legend(6, 50,c("Spatial Copula", "best copula per lag", "Gaussian Copula",
                "number of pairs"), 
        pch=c(1,16,5,50), col=c("black", "green", "red"))
@@ -90,27 +91,14 @@
 ##
 # leave-one-out x-validation
 
-condVine <- function(condVar, dists, n=100) {
-  rat <- 0.2/(1:(n/2))-(0.1/((n+1)/2))
-  xVals <- unique(sort(c(rat,1-rat,1:(n-1)/(n))))
-  xLength <- length(xVals)
-  repCondVar <- matrix(condVar, ncol=length(condVar), nrow=xLength, byrow=T)
-  density <- dCopula(cbind(xVals, repCondVar), meuseSpVine, h=dists)
-  
-  linAppr <- approxfun(c(0,xVals,1), density[c(1,1:xLength,xLength)] ,yleft=0, yright=0)
-  int <- integrate(linAppr,lower=0, upper=1)$value
-  
-  return(function(u) linAppr(u)/int)
-}
-
-time <- proc.time()  # ~30 s
+time <- proc.time()  # ~60 s
 predMedian <- NULL
 predMean <- NULL
-for(loc in 1:nrow(meuseNeigh at data)) { # loc <- 429  predNeigh$data[loc,1]
+for(loc in 1:nrow(meuseNeigh at data)) { # loc <- 145
   cat("Location:",loc,"\n")
-  condSecVine <- condVine(condVar=as.numeric(meuseNeigh at data[loc,-1]), 
-                          dists=meuseNeigh at distances[loc,,drop=F])
-  
+  condSecVine <- condSpVine(condVar=as.numeric(meuseNeigh at data[loc,-1]), 
+                          dists=list(meuseNeigh at distances[loc,,drop=F]),meuseSpVine)
+
   predMedian <- c(predMedian, qMar(optimise(function(x) abs(integrate(condSecVine,0,x)$value-0.5),c(0,1))$minimum))
   
   condExp <-  function(x) {

Modified: pkg/man/loglikByCopulasLags.Rd
===================================================================
--- pkg/man/loglikByCopulasLags.Rd	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/man/loglikByCopulasLags.Rd	2013-05-21 08:26:21 UTC (rev 96)
@@ -22,7 +22,7 @@
 }
 }
 \value{
-A matrix of spatial lags (rows) and copula family names (columns) holding the calculated log-likelihood values.
+A list containing a matrix (\code{loglik}) of spatial lags (rows) and copula family names (columns) holding the calculated log-likelihood value and a list o the corresponding copula fits.
 }
 \author{
 Benedikt Graeler
@@ -38,7 +38,7 @@
 calcKTauPol <- fitCorFun(bins, degree=3)
 
 loglikTau <- loglikByCopulasLags(bins, calcKTauPol)
-loglikTau
+loglikTau$loglik
 }
 
 \keyword{spcopula}

Modified: pkg/man/neighbourhood-class.Rd
===================================================================
--- pkg/man/neighbourhood-class.Rd	2013-05-03 15:23:07 UTC (rev 95)
+++ pkg/man/neighbourhood-class.Rd	2013-05-21 08:26:21 UTC (rev 96)
@@ -3,7 +3,7 @@
 \docType{class}
 \alias{neighbourhood-class}
 \alias{names,neighbourhood-method}
-\alias{[,neighbourhood-method}
+\alias{[[,neighbourhood,ANY,ANY-method}
 
 \title{Class \code{neighbourhood}}
 \description{A class representing a local spatial neighbourhood.}
@@ -32,6 +32,7 @@
     \item{names}{\code{signature(x = "neighbourhood")}: provides the variable names of the neighbourhood. }
     \item{show}{\code{signature(object = "neighbourhood")}: a brief description of the characteristics of the neighbourhood.}
     \item{spplot}{\code{signature(obj = "neighbourhood")}: plots the values of the one or more selected columns (0="central location", 1="closest neighbours", ...) at the coordinates of the central location.}
+    \item{[[}{subsets the selection of neighbourhoods returning a subset of these ("columnwise")}
 	 }
 }
 \author{

Modified: spcopula_0.1-1.tar.gz
===================================================================
(Binary files differ)

Modified: spcopula_0.1-1.zip
===================================================================
(Binary files differ)


From noreply at r-forge.r-project.org  Fri May 24 17:08:19 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Fri, 24 May 2013 17:08:19 +0200 (CEST)
Subject: [spcopula-commits] r97 - / pkg pkg/R pkg/man www
Message-ID: <20130524150819.378CC183CD1@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-05-24 17:08:18 +0200 (Fri, 24 May 2013)
New Revision: 97

Added:
   pkg/R/spatio-temporalPreparation.R
   pkg/R/stVineCopula.R
   pkg/man/condStVine.Rd
   pkg/man/getStNeighbours.Rd
   pkg/man/stCopPredict.Rd
   pkg/man/stCopula.Rd
   pkg/man/stNeighbourhood-class.Rd
   pkg/man/stNeighbourhood.Rd
   pkg/man/stVineCopula-class.Rd
   pkg/man/stVineCopula.Rd
Modified:
   pkg/DESCRIPTION
   pkg/NAMESPACE
   pkg/R/Classes.R
   pkg/R/asCopula.R
   pkg/R/cqsCopula.R
   pkg/R/spCopula.R
   pkg/R/spatialPreparation.R
   pkg/R/stCopula.R
   pkg/man/condSpVine.Rd
   pkg/man/cqsCopula.Rd
   pkg/man/neighbourhood-class.Rd
   pkg/man/neighbourhood.Rd
   pkg/man/spVineCopula.Rd
   pkg/man/stCopula-class.Rd
   spcopula_0.1-1.tar.gz
   spcopula_0.1-1.zip
   www/index.php
Log:
- added full spatio-temporal support (still needs tesating!)

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/DESCRIPTION	2013-05-24 15:08:18 UTC (rev 97)
@@ -2,7 +2,7 @@
 Type: Package
 Title: copula driven spatial analysis
 Version: 0.1-1
-Date: 2013-05-21
+Date: 2013-05-24
 Author: Benedikt Graeler
 Maintainer: Benedikt Graeler <ben.graeler at uni-muenster.de>
 Description: This package provides a framework to analyse via copulas spatial and spatio-temporal data provided in the format of the spacetime package. Additionally, support for calculating different multivariate return periods is implemented.
@@ -20,6 +20,7 @@
   spCopula.R 
   stCopula.R
   spatialPreparation.R
+  spatio-temporalPreparation.R
   wrappingCFunctions.R
   linkingVineCopula.R
   BB1copula.R
@@ -30,5 +31,6 @@
   ClaytonGumbelCopula.R
   vineCopulas.R
   spVineCopula.R
+  stVineCopula.R
   utilities.R
   returnPeriods.R

Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/NAMESPACE	2013-05-24 15:08:18 UTC (rev 97)
@@ -9,8 +9,9 @@
 export(joeBiCopula, surJoeBiCopula, r90JoeBiCopula, r270JoeBiCopula)
 export(surClaytonCopula, r90ClaytonCopula, r270ClaytonCopula)
 export(surGumbelCopula, r90GumbelCopula, r270GumbelCopula)
-export(vineCopula, spVineCopula)
-export(neighbourhood)
+export(spCopula, stCopula)
+export(vineCopula, spVineCopula, stVineCopula)
+export(neighbourhood, stNeighbourhood)
 export(empiricalCopula, genEmpCop)
 
 # general functions
@@ -20,18 +21,18 @@
 export(invdduCopula, invddvCopula)
 export(qCopula_u)
 export(condSpVine,spCopPredict)
+export(condStVine,stCopPredict)
 
 # tweaks
 # export(setSizeLim)
 
 # spatial
-export(getNeighbours)
+export(getNeighbours,getStNeighbours)
 export(calcBins)
 export(calcSpTreeDists, dropSpTree)
 
 # fitting
 export(fitCorFun, loglikByCopulasLags, fitSpCopula, composeSpCopula)
-export(spCopula)
 
 # MRP functions
 export(genEmpKenFun, genInvKenFun)
@@ -39,8 +40,8 @@
 export(criticalPair, criticalTriple)
 
 ## classes
-exportClasses(asCopula, cqsCopula, neighbourhood, empiricalCopula)
-exportClasses(vineCopula, spCopula, stCopula, spVineCopula)
+exportClasses(asCopula, cqsCopula, neighbourhood, stNeighbourhood, empiricalCopula)
+exportClasses(spCopula, stCopula, vineCopula, spVineCopula, stVineCopula)
 
 # wrappers to CDVine
 exportClasses(BB1Copula, surBB1Copula, r90BB1Copula, r270BB1Copula)

Modified: pkg/R/Classes.R
===================================================================
--- pkg/R/Classes.R	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/R/Classes.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -50,7 +50,7 @@
     return("Parameter and lower bound have non-equal length")
   if (any(is.na(param) | param > upper | param < lower))
     return("Parameter value out of bound")
-  if (length(object at fixed >0)){
+  if (object at fixed != ""){
     if(!("a" %in% object at fixed | "b" %in% object at fixed))
       return("The slot fixed may only refer to \"a\" or \"b\".")
     if ("a" %in% object at fixed & "b" %in% object at fixed)
@@ -208,6 +208,17 @@
 
 setClassUnion("spVineCopula",c("mixedSpVineCopula","pureSpVineCopula"))
 
+#################################
+## Spatio-temporal Vine Copula ##
+#################################
+
+validStVineCopula <- function(object) {
+  return(validStCopula(object at stCop) & validObject(object at topCop))
+}
+
+setClass("stVineCopula", representation("copula", stCop="stCopula", topCop="copula"),
+         validity = validStVineCopula, contains=list("copula"))
+
 ########################################
 ## spatial classes providing the data ##
 ########################################
@@ -259,3 +270,32 @@
                                          prediction="logical"),
          validity = validNeighbourhood, contains = list("Spatial"))
 
+## ST neighbourhood
+
+validStNeighbourhood <- function(object) {
+  sizeN <- nrow(object at data)
+  if (object at prediction & is.null(object at dataLocs))
+    return("The spatio-temporal locations of the data have to be provided for the estimation procedure.")
+  dimDists <- dim(object at distances)
+  if (nrow(object at data) != dimDists[1]) 
+    return("Data and distances have unequal number of rows.")
+  dimInd <- dim(object at index)
+  if (nrow(object at data) != dimInd[1]) 
+    return("Data and index have unequal number of rows.")
+  if (dimDists[2] != dimInd[2]) 
+    return("Data and index have unequal number of columns.")
+  else 
+    return(TRUE)
+}
+
+setClassUnion("optionalST",c("NULL","ST"))
+
+setClass("stNeighbourhood",
+         representation = representation(data = "data.frame", 
+                                         distances="array", 
+                                         index="array",
+                                         locations="ST",
+                                         dataLocs="optionalST",
+                                         var="character", 
+                                         prediction="logical"),
+         validity = validStNeighbourhood, contains = list("ST"))
\ No newline at end of file

Modified: pkg/R/asCopula.R
===================================================================
--- pkg/R/asCopula.R	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/R/asCopula.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -184,47 +184,36 @@
 # method
 #  one of kendall or spearman according to the calculation of moa
 
-fitASC2.itau <- function(copula, data, estimate.variance) {
-tau <- cor(data,method="kendall")[1,2]
-esti <- fitASC2.moa(tau, data, method="itau")
-copula <- asCopula(esti)
-return(new("fitCopula",
-           estimate = esti, 
-           var.est = matrix(NA), 
-           loglik = sum(log(dCopula(data, copula))),
-           nsample = nrow(data),
-           method = "Inversion of Kendall's tau and MLE",
-           fitting.stats = list(convergence=as.integer(NA)),
-           copula = copula))
+fitASC2.itau <- function(copula, data, estimate.variance, tau=NULL) {
+  if(is.null(tau))
+    tau <- VineCopula:::fasttau(data[,1],data[,2])
+  esti <- fitASC2.moa(tau, data, method="itau")
+  copula <- asCopula(esti)
+  
+  new("fitCopula", estimate = esti, var.est = matrix(NA), 
+      loglik = sum(log(dCopula(data, copula))), nsample = nrow(data),
+      method = "Inversion of Kendall's tau and MLE", 
+      fitting.stats = list(convergence=as.integer(NA)), copula = copula)
 }
 
-fitASC2.irho <- function(copula, data, estimate.variance){
-rho <- cor(data,method="spearman")[1,2]
-esti <- fitASC2.moa(rho, data, method="itau")
-copula <- asCopula(esti)
-return(new("fitCopula",
-           estimate = esti, 
-           var.est = matrix(NA), 
-           loglik = sum(log(dCopula(data, copula))),
-           nsample = nrow(data),
-           method = "Inversion of Spearman's rho and MLE",
-           fitting.stats = list(convergence=as.integer(NA)),
-           copula = copula))
+fitASC2.irho <- function(copula, data, estimate.variance, rho=NULL){
+  if(is.null(rho))
+    rho <- cor(data,method="spearman")[1,2]
+  esti <- fitASC2.moa(rho, data, method="irho")
+  copula <- asCopula(esti)
+  
+  new("fitCopula", estimate = esti, var.est = matrix(NA), 
+      loglik = sum(log(dCopula(data, copula))), nsample = nrow(data),
+      method = "Inversion of Spearman's rho and MLE",
+      fitting.stats = list(convergence=as.integer(NA)), copula = copula)
 }
 
 fitASC2.moa <- function(moa, data, method="itau", tol=.Machine$double.eps^.5) {
   smpl <- as.matrix(data)
+  iFun <- switch(method, 
+                 itau=function(p) iTauASC2(p,moa),
+                 irho=function(p) iRhoASC2(p,moa))
 
-  iTau <- function(p) {
-    iTauASC2(p,moa)
-  }
-
-  iRho <- function(p) {
-    iRhoASC2(p,moa)
-  }
-
-  iFun <- switch(method, itau=iTau, irho=iRho)
-
   sec <- function (parameters) {
     res <- NULL
     for(param in parameters) {
@@ -235,9 +224,7 @@
 
   b <- optimize(sec,c(-1,1), tol=tol)$minimum
 
-  param <- c(iFun(b),b)
-
-  return(param)
+  return(c(iFun(b),b))
 }
 
 # maximum log-likelihood estimation of a and b using optim

Modified: pkg/R/cqsCopula.R
===================================================================
--- pkg/R/cqsCopula.R	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/R/cqsCopula.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -7,7 +7,7 @@
 ##                                                  ##
 ######################################################
 
-cqsCopula <- function (param=c(0,0), fixed=character(0)) {
+cqsCopula <- function (param=c(0,0), fixed="") {
   new("cqsCopula", dimension = as.integer(2), parameters = param, 
       param.names = c("a", "b"), param.lowbnd = c(limA(param[2]),-1),
       param.upbnd = c(1, 1), 
@@ -272,8 +272,6 @@
       copula=copula)
 }
 
-
-
 fitCQSec.moa <- function(moa, data, method="itau", tol=.Machine$double.eps^.5) {
   smpl <- as.matrix(data)
 
@@ -298,9 +296,7 @@
 
   b <- optimize(sec,c(-1,1), tol=tol)$minimum
 
-  param <- c(iFun(b),b)
-
-  return(param)
+  return(c(iFun(b),b))
 }
 
 # maximum log-likelihood estimation of a and b using optim

Modified: pkg/R/spCopula.R
===================================================================
--- pkg/R/spCopula.R	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/R/spCopula.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -422,18 +422,7 @@
 # cutoff -> maximal distance that should be considered for fitting
 # bounds -> the bounds of the correlation function (typically c(0,1))
 # method -> the measure of association, either "kendall" or "spearman"
-fitCorFun <- function(bins, degree=3, cutoff=NA, bounds=c(0,1), 
-                      cor.method=NULL, weighted=FALSE) {
-  if(is.null(cor.method)) {
-    if(is.null(attr(bins,"cor.method")))
-      stop("Neither the bins arguments has an attribute cor.method nor is the parameter cor.method provided.") 
-    else 
-      cor.method <- attr(bins,"cor.method")
-  } else {
-    if(!is.null(attr(bins,"cor.method")) && cor.method != attr(bins,"cor.method"))
-      stop("The cor.method attribute of the bins argument and the argument cor.method do not match.")
-  }
-
+fitCorFunSng <- function(bins, degree, cutoff, bounds, cor.method, weighted) {
   if (weighted) {
     bins <- as.data.frame(bins[c("np","meanDists","lagCor")])
     if(!is.na(cutoff)) 
@@ -449,6 +438,9 @@
   print(fitCor)
   cat("Sum of squared residuals:",sum(fitCor$residuals^2),"\n")
   
+  if(cor.method=="fasttau") 
+    cor.method <- "kendall"
+  
   function(x) {
     if (is.null(x)) return(cor.method)
     return(pmin(bounds[2], pmax(bounds[1], 
@@ -456,7 +448,33 @@
   }
 }
 
+fitCorFun <- function(bins, degree=3, cutoff=NA, bounds=c(0,1), 
+                      cor.method=NULL, weighted=FALSE){
+  if(is.null(cor.method)) {
+    if(is.null(attr(bins,"cor.method")))
+      stop("Neither the bins arguments has an attribute cor.method nor is the parameter cor.method provided.") 
+    else 
+      cor.method <- attr(bins,"cor.method")
+  } else {
+    if(!is.null(attr(bins,"cor.method")) && cor.method != attr(bins,"cor.method"))
+      stop("The cor.method attribute of the bins argument and the argument cor.method do not match.")
+  }
+  
+  if(is.null(nrow(bins$lagCor)))
+    return(fitCorFunSng(bins, degree, cutoff, bounds, cor.method, weighted))
+  
+  degree <- rep(degree,length.out=nrow(bins$lagCor))
+  calcKTau <- list()
+  for(j in 1:nrow(bins$lagCor)) {
+    calcKTau[[paste("fun",j,sep="")]] <- fitCorFunSng(data.frame(meanDists=bins$meanDists, 
+                                                                 lagCor=bins$lagCor[j,]),
+                                                      degree[j], cutoff, bounds, 
+                                                      cor.method, weighted)
+  }
+  return(calcKTau)
+}
 
+
 # towards b)
   
 ## loglikelihoods for a dynamic spatial copula

Modified: pkg/R/spatialPreparation.R
===================================================================
--- pkg/R/spatialPreparation.R	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/R/spatialPreparation.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -4,8 +4,8 @@
 ##                                                    ##
 ########################################################
 
-## neighbourhood constructor
-############################
+## spatial neighbourhood constructor
+####################################
 
 neighbourhood <- function(data, distances, sp, dataLocs=NULL, index, 
                           prediction, var) {
@@ -54,7 +54,7 @@
       prediction=x at prediction)
 }
 
-setMethod("[[", "neighbourhood", selectFromNeighbourhood) 
+setMethod("[[", signature("neighbourhood","numeric","missing"), selectFromNeighbourhood) 
 
 ## calculate neighbourhood from SpatialPointsDataFrame
 
@@ -84,7 +84,7 @@
   allData <- NULL
   
   for(i in 1:length(locations)) { # i <- 1
-    tempDists <- spDistsN1(spData,locations[i,])
+    tempDists <- spDists(spData,locations[i,])
     tempDists[tempDists < min.dist] <- Inf
     spLocs <- order(tempDists)[1:(size-1)]
     allLocs <- rbind(allLocs, spLocs)

Added: pkg/R/spatio-temporalPreparation.R
===================================================================
--- pkg/R/spatio-temporalPreparation.R	                        (rev 0)
+++ pkg/R/spatio-temporalPreparation.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -0,0 +1,98 @@
+###############################################################
+##                                                           ##
+## functions based on spacetime preparing the use of copulas ##
+##                                                           ##
+###############################################################
+
+## spatio-temporal neighbourhood constructor
+############################################
+
+stNeighbourhood <- function(data, distances, STxDF, ST=NULL,index, 
+                          prediction, var) {
+  data <- as.data.frame(data)
+  sizeN <- nrow(data)
+  dimDists <- dim(distances)
+  
+  stopifnot(dimDists[1]==sizeN)
+  stopifnot(dimDists[2]==ncol(data)-(!prediction))
+  stopifnot(dimDists[3]==2)
+  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,
+      sp=as(STxDF at sp, "Spatial"), time=STxDF at time[1], 
+      endTime=STxDF at endTime[length(STxDF at endTime)])
+}
+
+## show
+showStNeighbourhood <- function(object){
+  cat("A set of spatio-temporal neighbourhoods consisting of", dim(object at distances)[2]+1, "locations each \n")
+  cat("with",nrow(object at data),"rows of observations for:\n")
+  cat(object at var,"\n")
+}
+
+setMethod(show,signature("stNeighbourhood"),showStNeighbourhood)
+
+
+## calculate neighbourhood from SpatialPointsDataFrame
+
+# returns an neighbourhood object
+##################################
+getStNeighbours <- function(stData, ST, var=names(stData at data)[1], spSize=4, 
+                            t.lags=-(0:2), timeSteps=NA, prediction=FALSE, min.dist=0.01) {
+  stopifnot((!prediction && missing(ST)) || (prediction && !missing(ST)))
+  stopifnot(min.dist>0 || prediction)
+  
+  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
+    nghbrs <- getNeighbours(stData[,1], var=var, size=spSize, min.dist=min.dist)
+  
+  stNeighData <- NULL
+  stDists <- array(NA,c(nLocs,(spSize-1)*length(t.lags),2))
+  stInd <- array(NA,c(nLocs,(spSize-1)*length(t.lags),2))
+  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[c(i, 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,], 
+                                              tmpInst+t,var]@data[[1]],
+                                       ncol=spSize-1, byrow=T))
+      tmpInd <- cbind(tmpInd, matrix(rep(tmpInst+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*(spSize-1)),
+                                                      byrow=T, ncol=length(t.lags)*(spSize-1))  # store sp distances
+    stDists[(i-1)*timeSteps+1:timeSteps,,2] <- matrix(rep(rep(t.lags,each=spSize-1),
+                                                          timeSteps),
+                                                      byrow=T, ncol=length(t.lags)*(spSize-1))  # store tmp distances
+    stInd[(i-1)*timeSteps+1:timeSteps,,1] <- matrix(rep(nghbrs at index[i,],
+                                                    timeSteps*(spSize-1)),
+                                                    byrow=T, ncol=length(t.lags)*(spSize-1))
+    stInd[(i-1)*timeSteps+1:timeSteps,,2] <- tmpInd
+  }
+
+  if (prediction)
+    dataLocs <- stData
+  else 
+    dataLocs <- NULL
+  return(stNeighbourhood(as.data.frame(stNeighData), stDists, stData, ST, 
+                         stInd, prediction, var))
+}
\ No newline at end of file

Modified: pkg/R/stCopula.R
===================================================================
--- pkg/R/stCopula.R	2013-05-21 08:26:21 UTC (rev 96)
+++ pkg/R/stCopula.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -1,19 +1,10 @@
-# constructor
-# dimension = "integer"     set to 2
-# parameters = "numeric"    set of parameters
-# param.names = "character" appropriate names
-# param.lowbnd = "numeric"  appropriate lower bounds
-# param.upbnd = "numeric"   appropriate upper bounds
-# fullname = "character"     messgae printed with "show"
-# components="list"         list of copulas (will be automatically supplemented 
-#			      by the independent copula)
-# distances="numeric"       the linking distances + the range (will be assigned
-#			      to the independent copula)
-# unit="character"          measurement unit of distance
-# depFun="function"         a optional spatial dependence function providing 
-#                             Kendalls tau or Spearman's rho to calib* or exact 
-#                             parameters
+######################################
+## Spatio-Temporal Bivariate Copula ##
+######################################
 
+## constructor ##
+#################
+
 stCopula <- function(components, distances, t.lags, stDepFun, unit="m", t.res="day") {
   spCopList <- list()
   
@@ -40,7 +31,9 @@
       spCopList=spCopList, t.lags=t.lags, t.res=t.res)
 }
 
-## show method
+## show method ##
+#################
+
 showStCopula <- function(object) {
   cat(object at fullname, "\n")
   cat("Dimension: ", object at dimension, "\n")
@@ -55,270 +48,126 @@
 
 setMethod("show", signature("stCopula"), showStCopula)
 
-## spatial copula jcdf ##
+## spatial copula cdf ##
+########################
 
-# TODO: add again block support to the spatio-temporal copula
-# u 
-#   list containing two column matrix providing the transformed pairs,  their respective 
-#   separation distances and time steps
-pStCopula <- function (u, copula) {
-  if (!is.list(u) || !length(u)>=3) stop("Point pairs need to be provided with their separating spatial and temproal distances as a list.")
+pStCopula <- function (u, copula, h) {
+  stopifnot(ncol(h)==2)
+  stopifnot(nrow(h)==1 || nrow(h)==nrow(u))
   
-  if(!is.matrix(u[[1]])) u[[1]] <- matrix(u[[1]],ncol=2)
-  n <- nrow(u[[1]])
-  h <- u[[2]]
-  t.dist <- u[[3]]
+  n <- nrow(u)
+  tDist <- unique(h[,2])
   
-  if(length(u)==4) {
-    block <- u[[4]]
-    if (n%%block != 0) stop("The block size is not a multiple of the data length:",n)
-  } else block <- 1
-
-  if(any(is.na(match(t.dist,copula at t.lags)))) 
+  if(any(is.na(match(tDist,copula at t.lags)))) 
     stop("Prediction time(s) do(es) not math the modelled time slices.")
-  if(length(h)>1 & length(h)!=n) 
-    stop("The spatial distance vector must either be of same length as rows in the data pairs or a single value.")
-  if(length(t.dist)>1 & length(t.dist)!=n) 
-    stop("The temporal distances vector must either be of same length as rows in the data pairs or a single value.")
-
-  if (length(t.dist)==1) {
-    res <- pSpCopula(copula at spCopList[[match(t.dist,copula at t.lags)]], 
-                     list(u[[1]], h))
+  
+  if (length(tDist)==1) {
+    res <- pSpCopula(u, copula at spCopList[[match(tDist, copula at t.lags)]], h[,1])
   } else {
-    if(length(h)==1) h <- rep(h,n)
-    res <- NULL
-    for(i in 1:(n%/%block)) {
-      res <- rbind(res, pSpCopula(copula at spCopList[[match(t.dist[i],copula at t.lags)]],
-                                  list(u[[1]][((i-1)*block+1):(i*block),], h[i*block])))
+    res <- numeric(n)
+    for(t in tDist) {
+      tmpInd <- h[,2]==t
+      tmpCop <- copula at spCopList[[match(t, copula at t.lags)]]
+      res[tmpInd] <- pSpCopula(u[tmpInd,], tmpCop, h[tmpInd,1])
     }
   }
-  
-  return(res)
+  res
 }
 
-setMethod("pCopula", signature("numeric","stCopula"), pStCopula)
+setMethod(pCopula, signature("numeric","stCopula"), 
+          function(u, copula, log, ...) pStCopula(matrix(u,ncol=2), copula, ...))
+setMethod(pCopula, signature("matrix","stCopula"), pStCopula)
 
-
 ## spatial Copula density ##
+############################
 
-# u 
-#   three column matrix providing the transformed pairs and their respective 
-#   separation distances
-dStCopula <- function (u, copula) {
-  if (!is.list(u) || !length(u)>=3) stop("Point pairs need to be provided with their separating spatial and temproal distances as a list.")
+dStCopula <- function (u, copula, log, h) {
+  stopifnot(ncol(h)==2)
+  stopifnot(nrow(h)==1 || nrow(h)==nrow(u))
   
-  if(!is.matrix(u[[1]])) u[[1]] <- matrix(u[[1]],ncol=2)
-  n <- nrow(u[[1]])
-  h <- u[[2]]
-  t.dist <- u[[3]]
+  n <- nrow(u)
+  tDist <- unique(h[,2])
   
-  if(length(u)==4) {
-    block <- u[[4]]
-    if (n%%block != 0) stop("The block size is not a multiple of the data length:",n)
-  } else block <- 1
-  
-  if(any(is.na(match(t.dist,copula at t.lags)))) 
+  if(any(is.na(match(tDist,copula at t.lags)))) 
     stop("Prediction time(s) do(es) not math the modelled time slices.")
-  if(length(h)>1 & length(h)!=n) 
-    stop("The spatial distance vector must either be of same length as rows in the data pairs or a single value.")
-  if(length(t.dist)>1 & length(t.dist)!=n) 
-    stop("The temporal distances vector must either be of same length as rows in the data pairs or a single value.")
   
-  if (length(t.dist)==1) {
-    res <- dSpCopula(copula at spCopList[[match(t.dist,copula at t.lags)]], 
-                     list(u[[1]], h))
+  if (length(tDist)==1) {
+    res <- dSpCopula(u, copula at spCopList[[match(tDist, copula at t.lags)]], log, h[,1])
   } else {
-    if(length(h)==1) h <- rep(h,n)
-    res <- NULL
-    for(i in 1:(n%/%block)) {
-      res <- rbind(res, dSpCopula(copula at spCopList[[match(t.dist[i],copula at t.lags)]],
-                                  list(u[[1]][((i-1)*block+1):(i*block),], h[i*block])))
+    res <- numeric(n)
+    for(t in tDist) {
+      tmpInd <- h[,2]==t
+      tmpCop <- copula at spCopList[[match(t, copula at t.lags)]]
+      res[tmpInd] <- dSpCopula(u[tmpInd,], tmpCop, log, h[tmpInd,1])
     }
   }
-  
-  return(res)
+  res
 }
 
-setMethod("dCopula", signature("list","stCopula"), dStCopula)
+setMethod(dCopula, signature("numeric","stCopula"), 
+          function(u, copula, log, ...) dStCopula(matrix(u,ncol=2), copula, log=log, ...))
+setMethod(dCopula, signature("matrix","stCopula"), dStCopula)
 
 
 ## partial derivatives ##
 
-## dduSpCopula
-###############
+## dduSpCopula ##
+#################
 
-dduStCopula <- function (u, copula) {
-  if (!is.list(u) || !length(u)>=3) stop("Point pairs need to be provided with their separating spatial and temproal distances as a list.")
+dduStCopula <- function (u, copula, h) {
+  stopifnot(ncol(h)==2)
+  stopifnot(nrow(h)==1 || nrow(h)==nrow(u))
   
-  if(!is.matrix(u[[1]])) u[[1]] <- matrix(u[[1]],ncol=2)
-  n <- nrow(u[[1]])
-  h <- u[[2]]
-  t.dist <- u[[3]]
+  n <- nrow(u)
+  tDist <- unique(h[,2])
   
-  if(length(u)==4) {
-    t.block <- u[[4]]
-    if (n%%t.block != 0) stop("The block size is not a multiple of the data length:",n)
-  } else t.block <- 1
-  
-  if(any(is.na(match(t.dist,copula at t.lags)))) 
+  if(any(is.na(match(tDist,copula at t.lags)))) 
     stop("Prediction time(s) do(es) not math the modelled time slices.")
-  if(length(h)>1 & length(h)!=n) 
-    stop("The spatial distance vector must either be of same length as rows in the data pairs or a single value.")
-  if(length(t.dist)>1 & length(t.dist)!=n) 
-    stop("The temporal distances vector must either be of same length as rows in the data pairs or a single value.")
   
-  if (length(t.dist)==1) {
-    res <- dduSpCopula(copula at spCopList[[match(t.dist,copula at t.lags)]],
-                       list(u[[1]], h, block=t.block))
+  if (length(tDist)==1) {
+    res <- dduSpCopula(u, copula at spCopList[[match(tDist, copula at t.lags)]], h[,1])
   } else {
-    if(length(h)==1) h <- rep(h,n)
-    res <- NULL
-    for(i in 1:(n%/%t.block)) {
-      cop <- copula at spCopList[[match(t.dist[i*t.block],copula at t.lags)]]
-      tmpPair <- u[[1]][((i-1)*t.block+1):(i*t.block),]
-      res <- rbind(res, dduSpCopula(cop, list(tmpPair,h[i*t.block])))
+    res <- numeric(n)
+    for(t in tDist) {
+      tmpInd <- h[,2]==t
+      tmpCop <- copula at spCopList[[match(t, copula at t.lags)]]
+      res[tmpInd] <- dduSpCopula(u[tmpInd,], tmpCop, h[tmpInd,1])
     }
   }
-  
-  return(res)
+  res
 }
 
-setMethod("dduCopula", signature("list","stCopula"), dduStCopula)
+setMethod("dduCopula", signature("numeric","stCopula"), 
+          function(u, copula, ...) dduStCopula(matrix(u,ncol=2), copula, ...))
+setMethod("dduCopula", signature("matrix","stCopula"), dduStCopula)
 
 
-## ddvSpCopula
-###############
-ddvStCopula <- function (u, copula) {
-  if (!is.list(u) || !length(u)>=3) stop("Point pairs need to be provided with their separating spatial and temproal distances as a list.")
+## ddvSpCopula ##
+#################
+
+ddvStCopula <- function (u, copula, h) {
+  stopifnot(ncol(h)==2)
+  stopifnot(nrow(h)==1 || nrow(h)==nrow(u))
   
-  if(!is.matrix(u[[1]])) u[[1]] <- matrix(u[[1]],ncol=2)
-  n <- nrow(u[[1]])
-  h <- u[[2]]
-  t.dist <- u[[3]]
+  n <- nrow(u)
+  tDist <- unique(h[,2])
   
-  if(length(u)==4) {
-    t.block <- u[[4]]
-    if (n%%t.block != 0) stop("The block size is not a multiple of the data length:",n)
-  } else t.block <- 1
-  
-  if(any(is.na(match(t.dist,copula at t.lags)))) 
+  if(any(is.na(match(tDist,copula at t.lags)))) 
     stop("Prediction time(s) do(es) not math the modelled time slices.")
-  if(length(h)>1 & length(h)!=n) 
-    stop("The spatial distance vector must either be of same length as rows in the data pairs or a single value.")
-  if(length(t.dist)>1 & length(t.dist)!=n) 
-    stop("The temporal distances vector must either be of same length as rows in the data pairs or a single value.")
   
-  if (length(t.dist)==1) {
-    res <- ddvSpCopula(copula at spCopList[[match(t.dist,copula at t.lags)]],
-                       list(u[[1]], h, block=t.block))
+  if (length(tDist)==1) {
+    res <- ddvSpCopula(u, copula at spCopList[[match(tDist,copula at t.lags)]], h[,1])
   } else {
-    if(length(h)==1) h <- rep(h,n)
-    res <- NULL
-    for(i in 1:(n%/%t.block)) {
-      cop <- copula at spCopList[[match(t.dist[i*t.block],copula at t.lags)]]
-      tmpPair <- u[[1]][((i-1)*t.block+1):(i*t.block),]
-      res <- rbind(res, ddvSpCopula(cop, list(tmpPair,h[i*t.block])))
+    res <- numeric(n)
+    for(t in tDist) {
+      tmpInd <- h[,2]==t
+      tmpCop <- copula at spCopList[[match(t, copula at t.lags)]]
+      res[tmpInd] <- ddvSpCopula(u[tmpInd,], tmpCop, h[tmpInd,1])
     }
   }
-  
-  return(res)
+  res
 }
 
-setMethod("ddvCopula", signature("list","stCopula"), ddvStCopula)
-
-# #############
-# ##         ##
-# ## FITTING ##
-# ##         ##
-# #############
-# 
-# # two models: 
-# # 1) Kendall's tau driven:
-# #    fit curve through emp. Kendall's tau values, identify validity ranges for
-# #    copula families deriving parameters from the fit, fade from one family to 
-# #    another at borders
-# # 2) convex-linear combination of copulas: 
-# #    fit one per lag, fade from one to another
-# 
-# # towards the first model:
-# 
-# # INPUT: the stBinning
-# # steps
-# # a) fit a curve
-# # b) estimate bivariate copulas per lag (limited to those with some 1-1-relation 
-# #    to Kendall's tau')
-# # INTERMEDIATE RESULT
-# # c) select best fits based on ... e.g. log-likelihood, visual inspection
-# # d) compose bivariate copulas to one spatial copula
-# # OUTPUT: a spatial copula parametrixued by distance through Kendall's tau
-# 
-# 
-# # towards b)
-# # bins     -> typically output from calcBins
-# # calcTau  -> a function on distance providing Kendall's tau estimates, 
-# # families -> a vector of dummy copula objects of each family to be considered
-# #             DEFAULT: c(normal, t_df=4, clayton, frank, gumbel
-# loglikByCopulasLags <- function(bins, calcTau, families=c(normalCopula(0), tCopula(0,dispstr="un"),
-#                                                           claytonCopula(0), frankCopula(1), gumbelCopula(1))) {
-#   loglik <- NULL
-#   for (cop in families) {
-#     print(cop)
-#     tmploglik <- NULL
-#     for(i in 1:length(bins$meanDists)) {
-#       cop at parameters[1] <- iTau(cop,tau=calcTau(bins$meanDists[i]))
-#       tmploglik <- c(tmploglik, sum(log(dCopula(bins$lagData[[i]],cop))))
-#     }
-#     loglik <- cbind(loglik, tmploglik)
-#   }
-# 
-#   colnames(loglik) <- sapply(families, function(x) class(x)[1])
-# 
-#   return(loglik)
-# }
-# 
-# # towards d)
-# composeSpCop <- function(bestFit, families, bins, calcCor) {
-#   nfits <- length(bestFit)
-#   gaps <- which(diff(bestFit)!=0)
-# 
-#   if(missing(calcCor)) noCor <- nfits
-#   else noCor <- min(which(calcCor(bins$meanDists)<=0), nfits)
-#   
-#   breaks <- sort(c(gaps, gaps+1, noCor))
-#   breaks <- breaks[breaks<noCor]
-#   
-#   cops <- as.list(families[bestFit[breaks]])
-#   
-#   breaks <- unique(c(breaks, min(nfits,rev(breaks)[1]+1)))
-#   distances <- bins$meanDists[breaks]
-#   
-#   if(length(breaks)==length(cops)) {
-#     warning("Lags do not cover the entire range with positive correlation. ", 
-#              "An artifical one fading towards the indepCopula has been added.")
-#     distances <- c(distances, rev(distances)[1]+diff(bins$meanDists[nfits+c(-1,0)]))
-#   }
-# 
-#   if(missing(calcCor)) return(spCopula(components=cops, distances=distances, unit="m"))
-#   else return(spCopula(components=cops, distances=distances, unit="m", spDepFun=calcCor))
-# }
-# 
-# # in once
-# 
-# # bins   -> typically output from calcBins
-# # cutoff -> maximal distance that should be considered for fitting
-# # families -> a vector of dummy copula objects of each family to be considered
-# #             DEFAULT: c(normal, t_df=4, clayton, frank, gumbel
-# # ...
-# # type   -> the type of curve (by now only polynominals are supported)
-# # degree -> the degree of the polynominal
-# # bounds -> the bounds of the correlation function (typically c(0,1))
-# # method -> the measure of association, either "kendall" or "spearman"
-# fitSpCopula <- function(bins, cutoff=NA, families=c(normalCopula(0), tCopula(0,dispstr="un"),
-#                                                     claytonCopula(0), frankCopula(1), gumbelCopula(1)), ...) {
-#   calcTau <- fitCorFun(bins, cutoff=cutoff, ...)
-#   loglik <- loglikByCopulasLags(bins, calcTau=calcTau, families=families)
-#   
-#   bestFit <- apply(apply(loglik, 1, rank),2,function(x) which(x==length(families)))
-#   
-#   return(composeSpCop(bestFit, families, bins, calcTau))
-# }
+setMethod("ddvCopula", signature("numeric","stCopula"), 
+          function(u, copula, ...) ddvStCopula(matrix(u,ncol=2), copula, ...))
+setMethod("ddvCopula", signature("matrix","stCopula"), ddvStCopula)
\ No newline at end of file

Added: pkg/R/stVineCopula.R
===================================================================
--- pkg/R/stVineCopula.R	                        (rev 0)
+++ pkg/R/stVineCopula.R	2013-05-24 15:08:18 UTC (rev 97)
@@ -0,0 +1,202 @@
+#########################################
+## methods for the spatial vine copula ##
+#########################################
+
+## constructor ##
+#################
+
+stVineCopula <- function(stCop, topCop) {
+  stopifnot(is(stCop,"stCopula"))
+  
+  new("stVineCopula", dimension = as.integer(topCop at dimension+1),
+      parameters=numeric(), param.names = character(), param.lowbnd = numeric(), 
+      param.upbnd = numeric(), 
+      fullname = paste("Spatio-temporal vine copula family with 1 spatio-temporal tree."),
+      stCop=stCop, topCop=topCop)
+}
+
+## show ##
+##########
+
+showStVineCopula <- function(object) {
+  dim <- object at dimension
+  cat(object at fullname, "\n")
+  cat("Dimension: ", dim, "\n")
+}
+
+setMethod("show", signature("stVineCopula"), showStVineCopula)
+
+## density ##
+#############
+
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/spcopula -r 97