From noreply at r-forge.r-project.org  Tue Mar  5 14:22:41 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue,  5 Mar 2013 14:22:41 +0100 (CET)
Subject: [spcopula-commits] r88 - / pkg/R pkg/data pkg/demo pkg/man
Message-ID: <20130305132241.AED431813C8@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-03-05 14:22:41 +0100 (Tue, 05 Mar 2013)
New Revision: 88

Modified:
   pkg/R/leafCopula.R
   pkg/R/spVineCopula.R
   pkg/data/spCopDemo.RData
   pkg/demo/spCopula_estimation.R
   pkg/man/loglikByCopulasLags.Rd
   pkg/man/spCopula-class.Rd
   pkg/man/spCopula.Rd
   pkg/man/spVineCopula-class.Rd
   pkg/man/spVineCopula.Rd
   pkg/man/vineCopula-class.Rd
   spcopula_0.1-1.tar.gz
   spcopula_0.1-1.zip
Log:
- cleaned data files
- adjusted examples

Modified: pkg/R/leafCopula.R
===================================================================
--- pkg/R/leafCopula.R	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/R/leafCopula.R	2013-03-05 13:22:41 UTC (rev 88)
@@ -6,6 +6,8 @@
   return(val)
 }
 
+# param <- c(1.446923, -1.722742)
+
 # weak lower border, two-place parameter
 weakBorderPoly <- function(x, par) {
   par[1]*x^3+par[2]*x^2+x
@@ -50,12 +52,11 @@
 
 # precalculate ellipse parameters
 solveQ <- function(u) {
-  sqrt(0.5*(strongBorderPoly(u)-u)^2)
+  sqrt(0.5)*(strongBorderPoly(u)-u)
 }
 
 ddxsolveQ <- function(u) {
-  sBor <- strongBorderPoly(u)
-  1/(2*sqrt(0.5*(sBor-u)^2))*(sBor-u)*(ddxstrongBorderPoly(u)-1)
+  sqrt(0.5)*(ddxstrongBorderPoly(u)-1)
 }
 
 # ## double check
@@ -68,7 +69,7 @@
 # ##
 
 solveXb <- function(u, par) {
-  sqrt(2*(u-weakBorderPoly(u, par))^2)+solveQ(u)
+  sqrt(2)*(u-weakBorderPoly(u, par))+solveQ(u)
 }
 
 ddxsolveXb <- function(u, par) {
@@ -99,7 +100,7 @@
 solveA <- function(u, par) {
   xb <- solveXb(u, par)
   q <- solveQ(u)
-  sqrt((-xb^3+2*q*xb^2-q^2*xb)/(-2*xb+2*q+xb))
+  sqrt(xb^2 - q^2*xb/(2*q-xb))
 }
 
 ddusolveA <- function(u, par) {
@@ -122,7 +123,7 @@
 solveB <- function(u, par) {
   a <- solveA(u, par)
   xb <- solveXb(u, par)
-  a^2*sqrt(1-(xb/a)^2)/xb
+  a*sqrt(a^2-xb^2)/xb
 } 
 
 ddusolveB <- function(u, par) {

Modified: pkg/R/spVineCopula.R
===================================================================
--- pkg/R/spVineCopula.R	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/R/spVineCopula.R	2013-03-05 13:22:41 UTC (rev 88)
@@ -62,7 +62,7 @@
   
   vineCop <- fitCopula(copula at vineCop, secLevel) 
   
-  return(spVineCopula(spCop, vineCop))
+  return(spVineCopula(copula at spCop, vineCop))
 }
 
 setMethod("fitCopula",signature=signature("spVineCopula"),fitSpVine)
\ No newline at end of file

Modified: pkg/data/spCopDemo.RData
===================================================================
(Binary files differ)

Modified: pkg/demo/spCopula_estimation.R
===================================================================
--- pkg/demo/spCopula_estimation.R	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/demo/spCopula_estimation.R	2013-03-05 13:22:41 UTC (rev 88)
@@ -2,24 +2,23 @@
 library(spcopula)
 library(evd)
 
-## dataset - spatial poionts data.frame ##
+## meuse - spatial poionts data.frame ##
 data(meuse)
 coordinates(meuse) = ~x+y
-dataSet <- meuse
 
 spplot(meuse,"zinc", col.regions=bpy.colors(5))
 
 ## margins ##
-hist(dataSet[["zinc"]],freq=F,n=30,ylim=c(0,0.0035), 
+hist(meuse[["zinc"]],freq=F,n=30,ylim=c(0,0.0035), 
      main="Histogram of zinc", xlab="zinc concentration")
-gevEsti <- fgev(dataSet[["zinc"]])$estimate
-meanLog <- mean(log(dataSet[["zinc"]]))
-sdLog <- sd(log(dataSet[["zinc"]]))
+gevEsti <- fgev(meuse[["zinc"]])$estimate
+meanLog <- mean(log(meuse[["zinc"]]))
+sdLog <- sd(log(meuse[["zinc"]]))
 curve(dgev(x,gevEsti[1], gevEsti[2], gevEsti[3]),add=T,col="red")
 curve(dlnorm(x,meanLog,sdLog),add=T,col="green")
 
-ks.test(dataSet[["zinc"]],pgev,gevEsti[1], gevEsti[2], gevEsti[3]) # p: 0.07
-ks.test(dataSet[["zinc"]],plnorm,meanLog,sdLog) # p: 0.03
+ks.test(meuse[["zinc"]],pgev,gevEsti[1], gevEsti[2], gevEsti[3]) # p: 0.07
+ks.test(meuse[["zinc"]],plnorm,meanLog,sdLog) # p: 0.03
 
 pMar <- function(q) plnorm(q, meanLog, sdLog)
 qMar <- function(p) qlnorm(p, meanLog, sdLog)
@@ -30,7 +29,7 @@
 # dMar <- function(x) dgev(x, gevEsti[1], gevEsti[2], gevEsti[3])
 
 ## lag classes ##
-bins <- calcBins(dataSet,var="zinc",nbins=10,cutoff=800)
+bins <- calcBins(meuse,var="zinc",nbins=10,cutoff=800)
 
 # transform data to the unit interval
 bins$lagData <- lapply(bins$lagData, rankTransform)
@@ -82,7 +81,7 @@
 ##
 # spatial vine
 vineDim <- 5L
-meuseNeigh <- getNeighbours(dataSet,"zinc",vineDim)
+meuseNeigh <- getNeighbours(meuse,"zinc",vineDim)
 meuseNeigh at data <- rankTransform(meuseNeigh at data)
 
 meuseSpVine <- fitCopula(spVineCopula(spCop, vineCopula(as.integer(vineDim-1))),
@@ -124,22 +123,22 @@
 }
 proc.time()-time
 
-mean(abs(predMean-dataSet$zinc))
-mean(predMean-dataSet$zinc)
-sqrt(mean((predMean-dataSet$zinc)^2))
+mean(abs(predMean-meuse$zinc))
+mean(predMean-meuse$zinc)
+sqrt(mean((predMean-meuse$zinc)^2))
 
-mean(abs(predMedian-dataSet$zinc))
-mean(predMedian-dataSet$zinc)
-sqrt(mean((predMedian-dataSet$zinc)^2))
+mean(abs(predMedian-meuse$zinc))
+mean(predMedian-meuse$zinc)
+sqrt(mean((predMedian-meuse$zinc)^2))
 
-plot(predMean,dataSet$zinc)
+plot(predMean,meuse$zinc)
 abline(0,1)
 
-plot(predMedian,dataSet$zinc)
+plot(predMedian,meuse$zinc)
 abline(0,1)
 
 ## kriging results:
-# same neighbourhood size:
+# same neighbourhood size 5L:
 # MAE:  158.61
 # BIAS:  -4.24
 # RMSE: 239.85

Modified: pkg/man/loglikByCopulasLags.Rd
===================================================================
--- pkg/man/loglikByCopulasLags.Rd	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/man/loglikByCopulasLags.Rd	2013-03-05 13:22:41 UTC (rev 88)
@@ -35,6 +35,8 @@
 \examples{
 data(spCopDemo) # load the workspace from demo(spcopula_estimation)
 
+calcKTauPol <- fitCorFun(bins, degree=3)
+
 loglikTau <- loglikByCopulasLags(bins, calcKTauPol)
 loglikTau
 }

Modified: pkg/man/spCopula-class.Rd
===================================================================
--- pkg/man/spCopula-class.Rd	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/man/spCopula-class.Rd	2013-03-05 13:22:41 UTC (rev 88)
@@ -50,12 +50,15 @@
 # data from demo(spcopula_estimation)
 data(spCopDemo) 
 
+calcKTauPol <- fitCorFun(bins, degree=3)
+
 spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"),
                                   frankCopula(1), normalCopula(0), claytonCopula(0),
                                   claytonCopula(0), claytonCopula(0), claytonCopula(0),
                                   claytonCopula(0), indepCopula()),
                   distances=bins$meanDists,
                   spDepFun=calcKTauPol, unit="m")
+                  
 dCopula(u=matrix(c(.3,.3,.7,.7),ncol=2),spCop,h=c(200,400))
 pCopula(u=matrix(c(.3,.3,.7,.7),ncol=2),spCop,h=c(200,400))
 }

Modified: pkg/man/spCopula.Rd
===================================================================
--- pkg/man/spCopula.Rd	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/man/spCopula.Rd	2013-03-05 13:22:41 UTC (rev 88)
@@ -40,6 +40,8 @@
 \examples{
 data(spCopDemo)
 
+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),

Modified: pkg/man/spVineCopula-class.Rd
===================================================================
--- pkg/man/spVineCopula-class.Rd	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/man/spVineCopula-class.Rd	2013-03-05 13:22:41 UTC (rev 88)
@@ -2,6 +2,7 @@
 \Rdversion{1.1}
 \docType{class}
 \alias{spVineCopula-class}
+\alias{fitCopula,spVineCopula-method}
 
 \title{Class \code{"spVineCopula"}}
 \description{

Modified: pkg/man/spVineCopula.Rd
===================================================================
--- pkg/man/spVineCopula.Rd	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/man/spVineCopula.Rd	2013-03-05 13:22:41 UTC (rev 88)
@@ -25,6 +25,9 @@
 \examples{
 # a spatial C-vine copula (with independent dummy copulas in the upper vine)
 data(spCopDemo)
+
+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),

Modified: pkg/man/vineCopula-class.Rd
===================================================================
--- pkg/man/vineCopula-class.Rd	2013-02-20 11:22:13 UTC (rev 87)
+++ pkg/man/vineCopula-class.Rd	2013-03-05 13:22:41 UTC (rev 88)
@@ -2,6 +2,7 @@
 \Rdversion{1.1}
 \docType{class}
 \alias{vineCopula-class}
+\alias{fitCopula,vineCopula-method}
 
 \title{Class \code{"vineCopula"}}
 \description{

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  Wed Mar 27 20:13:09 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 27 Mar 2013 20:13:09 +0100 (CET)
Subject: [spcopula-commits] r89 - / pkg/R
Message-ID: <20130327191309.7CC911850A3@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-03-27 20:13:09 +0100 (Wed, 27 Mar 2013)
New Revision: 89

Modified:
   pkg/R/leafCopula.R
   pkg/R/utilities.R
   pkg/R/vineCopulas.R
   spcopula_0.1-1.tar.gz
   spcopula_0.1-1.zip
Log:
- improved utilities.R and vineCopulas.R, some optimization for the leafCopula.R

Modified: pkg/R/leafCopula.R
===================================================================
--- pkg/R/leafCopula.R	2013-03-05 13:22:41 UTC (rev 88)
+++ pkg/R/leafCopula.R	2013-03-27 19:13:09 UTC (rev 89)
@@ -74,7 +74,7 @@
 
 ddxsolveXb <- function(u, par) {
   wBor <- weakBorderPoly(u, par)
-  -(sqrt(2)*(u-wBor)*(ddxweakBorderPoly(u, par)-1))/sqrt((u-wBor)^2)+ddxsolveQ(u)
+  sqrt(2)*(1-ddxweakBorderPoly(u, par))+ddxsolveQ(u)
 }
 
 # ## double check

Modified: pkg/R/utilities.R
===================================================================
--- pkg/R/utilities.R	2013-03-05 13:22:41 UTC (rev 88)
+++ pkg/R/utilities.R	2013-03-27 19:13:09 UTC (rev 89)
@@ -11,7 +11,7 @@
   }
 
   bool <- apply(u,1,function(row) !any(is.na(row)))
-  res <- apply(u[bool,],2,rank,ties.method)/(sum(bool)+1)
+  res <- apply(u[bool,],2,rank,ties.method=ties.method)/(sum(bool)+1)
   if(is.data.frame(u))
     return(as.data.frame(res))
   return(res)

Modified: pkg/R/vineCopulas.R
===================================================================
--- pkg/R/vineCopulas.R	2013-03-05 13:22:41 UTC (rev 88)
+++ pkg/R/vineCopulas.R	2013-03-27 19:13:09 UTC (rev 89)
@@ -5,13 +5,13 @@
 ####################
 
 # constructor
-vineCopula <- function (RVM) { # RVM <- 4L
-  if (is.integer(RVM)) {# assuming dimension; i <- 1
-    Matrix <- NULL
-    for (i in 1:RVM) {
-      Matrix <- cbind(Matrix,c(rep(0,i-1),(RVM-i+1):1))
-    }
-    RVM <- RVineMatrix(Matrix)
+vineCopula <- function (RVM, type="CVine") { # RVM <- 4L
+  if (is.integer(RVM)) {# assuming a dimension
+    stopifnot(type %in% c("CVine","DVine"))
+    if (type=="CVine")
+      RVM <- C2RVine(1:RVM,rep(0,RVM*(RVM-1)/2),rep(0,RVM*(RVM-1)/2))
+    if (type=="DVine")
+      RVM <- D2RVine(1:RVM,rep(0,RVM*(RVM-1)/2),rep(0,RVM*(RVM-1)/2))
   }
   
   # handling non S4-class as sub-element in a S4-class
@@ -20,7 +20,7 @@
   
   ltr <- lower.tri(RVM$Matrix)
   copDef <- cbind(RVM$family[ltr], RVM$par[ltr], RVM$par2[ltr])
-  copulas <- apply(copDef,1, function(x) copulaFromFamilyIndex(x[1],x[2],x[3]))
+  copulas <- rev(apply(copDef,1, function(x) copulaFromFamilyIndex(x[1],x[2],x[3])))
   
   new("vineCopula", copulas=copulas, dimension = as.integer(nrow(RVM$Matrix)),
       RVM=RVM, parameters = numeric(),
@@ -202,6 +202,7 @@
 
 # fitting using RVine
 fitVineCop <- function(copula, data, method) {
+  stopifnot(copula at dimension==ncol(data))
   if("StructureSelect" %in% method)
     vineCopula(RVineStructureSelect(data, indeptest="indeptest" %in% method))
   else

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

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