From noreply at r-forge.r-project.org  Wed Jun 19 10:08:52 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Wed, 19 Jun 2013 10:08:52 +0200 (CEST)
Subject: [spcopula-commits] r98 - / pkg/R pkg/demo
Message-ID: <20130619080852.6EA1818544B@r-forge.r-project.org>

Author: ben_graeler
Date: 2013-06-19 10:08:51 +0200 (Wed, 19 Jun 2013)
New Revision: 98

Modified:
   pkg/R/spatialPreparation.R
   pkg/demo/spCopula.R
   spcopula_0.1-1.tar.gz
   spcopula_0.1-1.zip
Log:
- demo fixed

Modified: pkg/R/spatialPreparation.R
===================================================================
--- pkg/R/spatialPreparation.R	2013-05-24 15:08:18 UTC (rev 97)
+++ pkg/R/spatialPreparation.R	2013-06-19 08:08:51 UTC (rev 98)
@@ -234,11 +234,16 @@
 #            NA      -> all observations
 #            other   -> temporal indexing as in spacetime/xts, the parameter t.lags is set to 0 in this case.
 # t.lags:    numeric -> temporal shifts between obs
-calcStBins <- function(data, var, nbins=15, boundaries=NA, cutoff=NA, instances=10, t.lags=c(0), cor.method="kendall", plot=TRUE) {
+calcStBins <- function(data, var, nbins=15, boundaries=NA, cutoff=NA, 
+                       instances=10, t.lags=-(0:2), cor.method="fasttau", 
+                       plot=FALSE) {
 
-  if(is.na(cutoff)) cutoff <- spDists(coordinates(t(data at sp@bbox)))[1,2]/3
-  if(is.na(boundaries)) boundaries <- ((1:nbins) * cutoff / nbins)
-  if(is.na(instances)) instances=length(data at time)
+  if(is.na(cutoff)) 
+    cutoff <- spDists(coordinates(t(data at sp@bbox)))[1,2]/3
+  if(is.na(boundaries)) 
+    boundaries <- ((1:nbins) * cutoff / nbins)
+  if(is.na(instances)) 
+    instances=length(data at time)
   
   spIndices <- calcSpLagInd(data at sp, boundaries)
     
@@ -251,9 +256,10 @@
   else {
     tempIndices <- NULL
     for (t.lag in rev(t.lags)) {
-      smplInd <- sample(x=max(1,1-t.lag):min(lengthTime,lengthTime-t.lag), size=min(instances,lengthTime-max(abs(t.lags))))
+      smplInd <- sample(x=max(1,1-min(t.lags)):min(lengthTime,lengthTime-min(t.lags)),
+                        size=min(instances,lengthTime-max(abs(t.lags))))
       tempIndices <- cbind(smplInd+t.lag, tempIndices)
-      tempIndices <- cbind(tempIndices[,1]-t.lag, tempIndices)
+      tempIndices <- cbind(smplInd, tempIndices)
     }
   }
     
@@ -290,7 +296,7 @@
   lagCor <- sapply(lagData, calcCor)
   
   if(plot) { 
-    plot(mDists, as.matrix(lagCor)[,1], xlab="distance",ylab=paste("correlation [",cor.method,"]",sep=""), 
+    plot(mDists, as.matrix(lagCor)[1,], xlab="distance",ylab=paste("correlation [",cor.method,"]",sep=""), 
          ylim=1.05*c(-abs(min(lagCor)),max(lagCor)), xlim=c(0,max(mDists)))
     abline(h=c(-min(lagCor),0,min(lagCor)),col="grey")
   }

Modified: pkg/demo/spCopula.R
===================================================================
--- pkg/demo/spCopula.R	2013-05-24 15:08:18 UTC (rev 97)
+++ pkg/demo/spCopula.R	2013-06-19 08:08:51 UTC (rev 98)
@@ -1,6 +1,6 @@
 ## librarys ##
 library(spcopula)
-library(evd)
+# library(evd)
 
 ## meuse - spatial poionts data.frame ##
 data(meuse)
@@ -12,10 +12,10 @@
 hist(meuse[["zinc"]],freq=F,n=30,ylim=c(0,0.0035), 
      main="Histogram of zinc", xlab="zinc concentration")
 
-gevEsti <- fgev(meuse[["zinc"]])$estimate
+# 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(dgev(x,gevEsti[1], gevEsti[2], gevEsti[3]),add=T,col="red")
 curve(dlnorm(x,meanLog,sdLog),add=T,col="green")
 
 pMar <- function(q) plnorm(q, meanLog, sdLog)
@@ -26,12 +26,11 @@
 # qMar <- function(p) qgev(p, gevEsti[1], gevEsti[2], gevEsti[3])
 # dMar <- function(x) dgev(x, gevEsti[1], gevEsti[2], gevEsti[3])
 
+meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1)
+
 ## lag classes ##
-bins <- calcBins(meuse,var="zinc",nbins=10,cutoff=800)
+bins <- calcBins(meuse,var="rtZinc",nbins=10,cutoff=800)
 
-# transform data to the unit interval
-bins$lagData <- lapply(bins$lagData, rankTransform)
-
 ## calculate parameters for Kendall's tau function ##
 # either linear
 calcKTauLin <- fitCorFun(bins, degree=1, cutoff=600)
@@ -53,7 +52,7 @@
 
 ## set-up a spatial Copula ##
 spCop <- spCopula(components=list(normalCopula(0), tCopula(0),
-                                  frankCopula(1), normalCopula(0), 
+                                  normalCopula(1), tCopula(0), 
                                   claytonCopula(0), claytonCopula(0),
                                   claytonCopula(0), claytonCopula(0),
                                   claytonCopula(0), indepCopula()),
@@ -80,8 +79,7 @@
 ##
 # spatial vine
 vineDim <- 5L
-meuseNeigh <- getNeighbours(meuse,var="zinc",size=vineDim)
-meuseNeigh at data <- rankTransform(meuseNeigh at data)
+meuseNeigh <- getNeighbours(meuse,var="rtZinc",size=vineDim)
 
 meuseSpVine <- fitCopula(spVineCopula(spCop, vineCopula(as.integer(vineDim-1))),
                          meuseNeigh)

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

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