From noreply at r-forge.r-project.org Wed Feb 1 16:31:26 2017 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 1 Feb 2017 16:31:26 +0100 (CET) Subject: [spcopula-commits] r161 - / pkg pkg/R pkg/man Message-ID: <20170201153126.BB7C81887AB@r-forge.r-project.org> Author: ben_graeler Date: 2017-02-01 16:31:26 +0100 (Wed, 01 Feb 2017) New Revision: 161 Added: genEmpSurCop.Rd pkg/man/empSurCopula-class.Rd pkg/man/empSurCopula.Rd spcopula.pdf Modified: pkg/NAMESPACE pkg/R/Classes.R pkg/R/empiricalCopula.R pkg/R/spatio-temporalPreparation.R pkg/man/genEmpCop.Rd pkg/man/loglikByCopulasStLags.Rd Log: new empirical survival copulas Added: genEmpSurCop.Rd =================================================================== --- genEmpSurCop.Rd (rev 0) +++ genEmpSurCop.Rd 2017-02-01 15:31:26 UTC (rev 161) @@ -0,0 +1,28 @@ +\name{genEmpSurCop} +\alias{genEmpSurCop} +\docType{data} +\title{ +%% ~~ data name/kind ... ~~ +} +\description{ +%% ~~ A concise (1-5 lines) description of the dataset. ~~ +} +\usage{data("genEmpSurCop")} +\format{ + The format is: + chr "genEmpSurCop" +} +\details{ +%% ~~ If necessary, more details than the __description__ above ~~ +} +\source{ +%% ~~ reference to a publication or URL from which the data were obtained ~~ +} +\references{ +%% ~~ possibly secondary sources and usages ~~ +} +\examples{ +data(genEmpSurCop) +## maybe str(genEmpSurCop) ; plot(genEmpSurCop) ... +} +\keyword{datasets} Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2016-12-01 12:46:52 UTC (rev 160) +++ pkg/NAMESPACE 2017-02-01 15:31:26 UTC (rev 161) @@ -44,7 +44,7 @@ export(spVineCopula, stVineCopula) export(stCoVarVineCopula) export(neighbourhood, stNeighbourhood) -export(empiricalCopula, genEmpCop) +export(empiricalCopula, genEmpCop, empSurCopula, genEmpSurCop) export(mixtureCopula) # general functions @@ -79,7 +79,7 @@ export(kendall) ## classes -exportClasses(asCopula, cqsCopula, tawn3pCopula, neighbourhood, stNeighbourhood, empiricalCopula) +exportClasses(asCopula, cqsCopula, tawn3pCopula, neighbourhood, stNeighbourhood, empiricalCopula, empSurCopula) exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) exportClasses(stCoVarVineCopula) exportClasses(mixtureCopula) \ No newline at end of file Modified: pkg/R/Classes.R =================================================================== --- pkg/R/Classes.R 2016-12-01 12:46:52 UTC (rev 160) +++ pkg/R/Classes.R 2017-02-01 15:31:26 UTC (rev 161) @@ -82,6 +82,22 @@ ) #### +## an empirical survival copula representation + +validEmpSurCopula <- function(object) { + if(ncol(object at sample) != object at dimension) + return("Dimension of the copula and the sample do not match.") + else + return(TRUE) +} + +setClass("empSurCopula", + representation = representation("copula", sample="matrix"), + validity = validEmpSurCopula, + contains = list("copula") +) + +#### ## the leaf copula validLeafCopula <- function(object) { Modified: pkg/R/empiricalCopula.R =================================================================== --- pkg/R/empiricalCopula.R 2016-12-01 12:46:52 UTC (rev 160) +++ pkg/R/empiricalCopula.R 2017-02-01 15:31:26 UTC (rev 161) @@ -8,14 +8,17 @@ empiricalCopula <- function (sample=NULL, copula) { if(is.null(sample) && missing(copula)) stop("At least one parameter of copula or sample must be provided.") + if(is.null(sample)) return(genEmpCop(copula)) + if(missing(copula)) return(new("empiricalCopula", dimension = as.integer(ncol(sample)), parameters = as.numeric(NA), param.names = "unknown", param.lowbnd = as.numeric(NA), param.upbnd = as.numeric(NA), fullname = "Unkown empirical copula based on a sample.", sample=sample)) + new("empiricalCopula", dimension = copula at dimension, parameters = copula at parameters, param.names = copula at param.names, param.lowbnd = copula at param.lowbnd, param.upbnd = copula at param.upbnd, @@ -25,11 +28,11 @@ # simplified constructor genEmpCop <- function(copula, sample.size=1e5) { - cat("Note: the copula will be empirically represented by a sample of size:", sample.size, "\n") + cat("Note: the copula will be empirically represented by a sample of size:", + sample.size, "\n") empiricalCopula(rCopula(sample.size, copula), copula) } - ## density, not yet needed and hence not implemented ## ## jcdf ## @@ -61,6 +64,81 @@ setMethod("lambda", signature("empiricalCopula"), function(copula, ...) stop("No evaluation possible, try to plot 'empBivJointDepFun' for a visual assessment.")) +################################## +## ## +## an empirical survival copula ## +## ## +################################## + +# constructor +empSurCopula <- function (sample=NULL, copula) { + if(is.null(sample) && missing(copula)) + stop("At least one parameter of copula or sample must be provided.") + + if(is.null(sample)) + return(genEmpSurCop(copula)) + + if(missing(copula)) + return(new("empSurCopula", dimension = as.integer(ncol(sample)), + parameters = as.numeric(NA), param.names = "unknown", + param.lowbnd = as.numeric(NA), param.upbnd = as.numeric(NA), + fullname = "Unkown empirical survival copula based on a sample.", + sample=sample)) + + new("empSurCopula", dimension = copula at dimension, + parameters = copula at parameters, param.names = copula at param.names, + param.lowbnd = copula at param.lowbnd, param.upbnd = copula at param.upbnd, + fullname = paste("Empirical survival copula derived from",copula at fullname), + sample=sample) +} + +# simplified constructor +genEmpSurCop <- function(copula, sample.size=1e5) { + cat("Note: the survival copula will be empirically represented by a sample of size:", + sample.size, "\n") + empSurCopula(1 - rCopula(sample.size, copula), copula) +} + +## jcdf ## +# from package copula # 3D +pempSurCop.C <- function(u, copula) { + if (copula at dimension==2) + return(apply(u,1,sum) - 1 + F.n(1-u, copula at sample)) + + if (copula at dimension==3) + return(apply(u,1,sum) - 2 + F.n(cbind(1-u[, 1:2, drop=F],1), + copula at sample) + F.n(cbind(1-u[,1, drop=F], 1, 1-u[,3, drop=F]), + copula at sample) + F.n(cbind(1-u[,2:3, drop=F], 1), + copula at sample) - F.n(1-u, copula at sample)) + + stop("The empirical survival copula is only implemented for 2 and 3 dimensions.") +} + +setMethod("pCopula", signature("numeric", "empSurCopula"), + function(u, copula, ...) { + pempSurCop.C(matrix(u, ncol=copula at dimension), copula) + }) +setMethod("pCopula", signature("matrix", "empSurCopula"), pempSurCop.C) + + +# tauempCop <- function(copula){*- +# TauMatrix(copula at sample)[1,2] +# } +# +# setMethod("tau",signature("empiricalCopula"), tauempCop) +# +# +# rhoempCop <- function(copula){ +# cor(copula at sample,method="spearman") +# } +# +# setMethod("rho",signature("empiricalCopula"), rhoempCop) +# +# setMethod("lambda", signature("empiricalCopula"), +# function(copula, ...) stop("No evaluation possible, try to plot 'empBivJointDepFun' for a visual assessment.")) +# + + # Vine Copula - empirical evaluation ## jcdf ## pvineCopula <- function(u, copula) { Modified: pkg/R/spatio-temporalPreparation.R =================================================================== --- pkg/R/spatio-temporalPreparation.R 2016-12-01 12:46:52 UTC (rev 160) +++ pkg/R/spatio-temporalPreparation.R 2017-02-01 15:31:26 UTC (rev 161) @@ -348,7 +348,7 @@ cor.method="fasttau", plot=FALSE) { if(is.na(cutoff)) cutoff <- spDists(coordinates(t(data at sp@bbox)))[1,2]/3 - if(is.na(boundaries)) + if(any(is.na(boundaries))) boundaries <- (1:nbins) * cutoff / nbins if(is.na(instances)) instances=length(data at time) Added: pkg/man/empSurCopula-class.Rd =================================================================== --- pkg/man/empSurCopula-class.Rd (rev 0) +++ pkg/man/empSurCopula-class.Rd 2017-02-01 15:31:26 UTC (rev 161) @@ -0,0 +1,44 @@ +\name{empSurCopula-class} +\Rdversion{1.1} +\docType{class} +\alias{empSurCopula-class} + +\title{Class \code{"empiricalCopula"}} +\description{ +A class representing an empirical survival version of a given copula. +} +\section{Objects from the Class}{ +Objects can be created by calls of the form \code{new("empSurCopula", ...)}, +through the constructor \code{\link{empSurCopula}} or the simplified constructor \code{\link{genEmpSurCop}}. + +} +\section{Slots}{ + \describe{ + \item{\code{sample}:}{Object of class \code{"matrix"} representing the sample. } + \item{\code{dimension}:}{Object of class \code{"integer"} giving the dimension. } + \item{\code{parameters}:}{Object of class \code{"numeric"} giving the parameters of the underlying copula family if present, \"NA\" otherwise.} + \item{\code{param.names}:}{Object of class \code{"character"} giving the parameter names of the underlying copula family if present, \"unknown\" otherwise. } + \item{\code{param.lowbnd}:}{Object of class \code{"numeric"} giving the lower bound of the underlying copula family if present, \"NA\" otherwise.} + \item{\code{param.upbnd}:}{Object of class \code{"numeric"} giving the upper bound of the underlying copula family if present, \"NA\" otherwise.} + \item{\code{fullname}:}{Object of class \code{"character"} giving a descriptive name including the underlying copula family's name if present. } + } +} +\section{Extends}{ +Class \code{"\linkS4class{copula}"}, directly. +Class \code{"\linkS4class{Copula}"}, by class "copula", distance 2. +} +\section{Methods}{ +No additional methods defined with class \code{empSurCopula} in the signature, but \code{\link{pCopula}} works as expected. +} +\author{ +Benedikt Graeler} +\note{ +Its implementation of \code{\link{pCopula}} is based on C-code from \code{\link{copula-package}}. +} + + +\seealso{\code{\link{genEmpSurCop}}} +\examples{ +showClass("empSurCopula") +} +\keyword{classes} Added: pkg/man/empSurCopula.Rd =================================================================== --- pkg/man/empSurCopula.Rd (rev 0) +++ pkg/man/empSurCopula.Rd 2017-02-01 15:31:26 UTC (rev 161) @@ -0,0 +1,49 @@ +\name{empSurCopula} +\alias{empSurCopula} +\title{ +Constructor of an empirical survival copula class +} +\description{ +Constructs an object of the empirical survival copula class \code{\linkS4class{empSurCopula}}, see \code{\link{genEmpSurCop}} for a simplified version. +} +\usage{ +empSurCopula(sample=NULL, copula) +} +\arguments{ + \item{sample}{ +A sample from a provided or unknown copula family. +} + \item{copula}{ +The underlying theoretical copula, in case it is known or a sample should be generated. +} +} +\value{ +An object of \code{\linkS4class{empSurCopula}}. +} +\author{ +Benedikt Graeler +} +\note{ +Its implementation of \code{\link{pCopula}} is based on C-code from \code{\link{copula-package}}. +} + +\seealso{ +\code{\link{genEmpSurCop}} for a simplified constructor with sample length control. +} +\examples{ +empCop <- empSurCopula(rCopula(500,frankCopula(0.7))) +str(empCop) + +empCop <- empSurCopula(copula=frankCopula(0.7)) +str(empCop) + +empCop <- empSurCopula(rCopula(500,frankCopula(0.7)), frankCopula(0.7)) +str(empCop) + +# the empirical value +pCopula(c(0.3, 0.5), empCop) + +# the theoretical value +pCopula(c(0.3, 0.5), frankCopula(0.7)) +} +\keyword{ multivariate } Modified: pkg/man/genEmpCop.Rd =================================================================== --- pkg/man/genEmpCop.Rd 2016-12-01 12:46:52 UTC (rev 160) +++ pkg/man/genEmpCop.Rd 2017-02-01 15:31:26 UTC (rev 161) @@ -1,13 +1,15 @@ \name{genEmpCop} \alias{genEmpCop} +\alias{genEmpSurCop} \title{ Generate an empirical copula } \description{ -Generates an empirical copula from a sample and returns the corresponding function. +Generates an empirical (survival) copula from a sample and returns the corresponding function. } \usage{ genEmpCop(copula, sample.size=1e5) +genEmpSurCop(copula, sample.size=1e5) } \arguments{ \item{copula}{ Modified: pkg/man/loglikByCopulasStLags.Rd =================================================================== --- pkg/man/loglikByCopulasStLags.Rd 2016-12-01 12:46:52 UTC (rev 160) +++ pkg/man/loglikByCopulasStLags.Rd 2017-02-01 15:31:26 UTC (rev 161) @@ -3,7 +3,7 @@ \title{Log-likelihoods by copula family and spatio-temporal lag class} -\description{This function works through a set of copula family and evaluates the best fitting one for each spatiao-temporal lag.} +\description{This function works through a set of copula families and evaluates the best fitting one for each spatio-temporal lag.} \usage{ loglikByCopulasStLags(stBins, data, families = c(normalCopula(), Added: spcopula.pdf =================================================================== --- spcopula.pdf (rev 0) +++ spcopula.pdf 2017-02-01 15:31:26 UTC (rev 161) @@ -0,0 +1,9499 @@ +%PDF-1.5 +%???? +1 0 obj +<< /S /GoTo /D (Section.0.Introduction.1) >> +endobj +4 0 obj +(Introduction) +endobj +5 0 obj +<< /S /GoTo /D (Section.1.Spatio-temporal\040vine\040copulas.1) >> +endobj +8 0 obj +(Spatio-temporal vine copulas) +endobj +9 0 obj +<< /S /GoTo /D (Section.2.Spatio-temporal\040vine\040copula\040estimation.1) >> +endobj +12 0 obj +(Spatio-temporal vine copula estimation) +endobj +13 0 obj +<< /S /GoTo /D (Section.3.Prediction\040of\040the\040spatio-temporal\040random\040field.1) >> +endobj +16 0 obj +(Prediction of the spatio-temporal random field) +endobj +17 0 obj +<< /S /GoTo /D (Section.4.Application.1) >> +endobj +20 0 obj +(Application) +endobj +21 0 obj +<< /S /GoTo /D (Subsubsection.5.0.0.Joining\040vine\040copula.3) >> +endobj +24 0 obj +(Joining vine copula) +endobj +25 0 obj +<< /S /GoTo /D (Section.5.Results\040and\040discussion.1) >> +endobj +28 0 obj +(Results and discussion) +endobj +29 0 obj +<< /S /GoTo /D (Section.6.Conclusions.1) >> +endobj +32 0 obj +(Conclusions) +endobj +33 0 obj +<< /S /GoTo /D [34 0 R /Fit] >> +endobj +35 0 obj +<< +/Length 350 +>> +stream +concordance:spcopula.tex:spcopula.Rnw:1 49 1 1 0 1 1 1 5 72 1 1 18 109 1 1 2 1 0 1 5 7 0 1 2 9 1 1 2 4 0 2 2 4 0 1 2 8 1 1 4 6 0 1 2 1 3 5 0 1 2 4 1 1 4 6 0 1 2 17 1 1 5 4 0 1 1 3 0 1 2 1 5 4 0 1 1 3 0 1 2 2 1 1 3 5 0 1 2 3 1 1 3 2 0 1 1 3 0 1 2 3 1 1 2 4 0 1 2 2 1 1 2 4 0 1 2 2 1 1 2 1 0 1 1 3 0 1 2 2 1 1 2 4 0 1 2 2 1 1 5 4 0 1 1 1 2 4 0 1 2 60 1 +endstream +endobj +52 0 obj +<< +/Length 3255 +/Filter /FlateDecode +>> +stream +x???r?F?????2?0x?-?&???*??*?8??(?I? ???????s0xHr?\23===??L? L???????????2??(?3?????<?$?b[????????In??*??w?W????OY?o??(? + at L???Z?? +????in??????Y????? ??qp?Y???A??v}??l???????w!Al???` +DWq?????e?nN???i??GDwy??#??iCl=??r???ab?(3?^??? pp???s @i??I???A????f????????_???&?c?????Ty0????^???????? 5&??2??D ?`s???Olaq?U<?1???o7?vZ0?8??????????M(?'d?????=?mH ?????#q?z?i?&"????3?p??l{??3????[??{?XQy???`??* +^:?\$G}?\d???#?`?O??c???? +????????7? +?? +??eAZ?+ +.nK?&?g?D????????U??X#J"5|??$g????eR?\{??GdgCP??~????X:8?[Q2?q?e????Yd ? ???MF"?:? q?>j?????QVz????B"?n?#_+:?s??? o????v????G??~5X??? k +2m/?{qZ?F??1)%d??6V}O?????e?U??? ?,u??ct?????N`????d???y??`!??*@yO/ $,,??3??r?kA??vl???]8#???M9?^???r?JY????Y?????x????kri\:+?Iu?x???2r?FQ^??J???"???Dr??S??4&`_?C)?%h?i?.?????,?4 ???????(5??th????? +????oZ??4?ee???? +??aH{????+?WSV??Z?Gq?.UR?,Is(h?d?J*???s?K?S?MZ??^"??Xa?htw;?9?k?6?I~?)?$???Q??-w/??B????M?S??O_$??L??A? +?IN?8z`~!9???????8f;?L???5)???/??? 2????D?x???8??V??0??????2??q^????~.?25?(Y??'=??G??? +???kU?'???????'Sj~?F?n??????S\?[?? ?Y E??t\rI?k/}??_???1GK9\??T1?'?K?4%?S;????l]?)g?#L?&?R +C????jlPb&??? +?????G???B?-T?6d??!?m?\????????????????|r? +?N??tX?? ??h2?'??D????C +Q???/??n???7??T???#d?"?c?Qf??????m??WR|???k??????%M)cZPd?????e?5?RsE??vh??o??9? +?????qF?3? ??? ?H??)??o$?E?x?2????B??????]M???T?s?y?b?P??+??~T???su?K? ???4??de4G@?SVC?u8??????a?7?r@?P?i+?????x=iSl???c?| +?>/C????y?v?7????????K??6?WADu?????K???or????T{??+>??K:`E)QZsI^FY?}?W;IY???e??W;??q???jf?Z?m???76???~?????Y?? +endstream +endobj +34 0 obj +<< +/Type /Page +/Contents 52 0 R +/Resources 51 0 R +/MediaBox [0 0 595.276 841.89] +/Parent 64 0 R +/Annots [ 36 0 R 37 0 R 38 0 R 39 0 R 40 0 R 41 0 R 42 0 R 43 0 R 44 0 R 45 0 R 46 0 R 47 0 R 63 0 R 48 0 R ] +>> +endobj +36 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [180.941 221.361 226.231 234.159] +/A << /S /GoTo /D (cite.Bardossy2006) >> +>> +endobj +37 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [232.815 221.361 256.625 234.159] +/A << /S /GoTo /D (cite.Bardossy2006) >> +>> +endobj +38 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [143.984 194.262 232.768 207.06] +/A << /S /GoTo /D (cite.Kazianka2011) >> +>> +endobj +39 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [238.515 194.262 262.326 207.06] +/A << /S /GoTo /D (cite.Kazianka2011) >> +>> +endobj +40 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [266.862 194.262 290.673 207.06] +/A << /S /GoTo /D (cite.Kazianka2010) >> +>> +endobj +41 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [299.467 194.262 344.757 207.06] +/A << /S /GoTo /D (cite.Bardossy2011) >> +>> +endobj +42 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [350.504 194.262 374.315 207.06] +/A << /S /GoTo /D (cite.Bardossy2011) >> +>> +endobj +43 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [383.109 194.262 489.206 207.06] +/A << /S /GoTo /D (cite.Bardossy2009) >> +>> +endobj +44 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [494.953 194.262 518.764 207.06] +/A << /S /GoTo /D (cite.Bardossy2009) >> +>> +endobj +45 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [93.769 180.713 174.554 193.511] +/A << /S /GoTo /D (cite.Bardossy2008) >> +>> +endobj +46 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [180.84 180.713 204.65 193.511] +/A << /S /GoTo /D (cite.Bardossy2008) >> +>> +endobj +47 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [465.582 135.73 522.996 148.528] +/A << /S /GoTo /D (cite.Cressie2011) >> +>> +endobj +63 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [80.004 122.181 109.836 134.979] +/A << /S /GoTo /D (cite.Cressie2011) >> +>> +endobj +48 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [111.667 122.181 135.478 134.979] +/A << /S /GoTo /D (cite.Cressie2011) >> +>> +endobj +53 0 obj +<< +/D [34 0 R /XYZ 80 770.89 null] +>> +endobj +54 0 obj +<< +/D [34 0 R /XYZ 81 733.028 null] +>> +endobj +2 0 obj +<< +/D [34 0 R /XYZ 81 331.039 null] +>> +endobj +62 0 obj +<< +/D [34 0 R /XYZ 81 331.039 null] +>> +endobj +51 0 obj +<< +/Font << /F48 55 0 R /F52 56 0 R /F55 57 0 R /F61 58 0 R /F8 59 0 R /F69 60 0 R /F70 61 0 R >> +/ProcSet [ /PDF /Text ] +>> +endobj +100 0 obj +<< +/Length 3685 +/Filter /FlateDecode +>> +stream +x??[K????????Se?$?d??ulW?J??;?T???#qf??c,J;??????????N??" ??h???6[<,??o??????z?gi?5???~Q??????(?????????_????q??4??k A}????S{??o????????????????pl?7??0?O?a????'x9????q?7?p6bk?S.?2????[?R??G"???????m?????Gy?????=???G / +;?*?zn?%???+???gncErz?u??? ???q?V??}f1?|???9???????I?J??uQ0?[U??m???%?>H???e???e??Ui?ux?7%N??m?E????r$??? +Og????8??? +3??b.7?;??K??8?'?e2??;?B??A?h?A,???n5p?^.f?????Hsc??y??;U?M??'C?p?:???$?p?5%x(1m?+??<4???c??t?k??+Y???H??$????neO??>???^PFX???6&?qf??w??GVQ?y=?*????zU9 +n????SuL?U^?r5??%????Id?/?:z+??6??D?H?????w2??`?Im??N?hu?q+rj=???t????-C?xv6HR???v??"?3?6?? +?+??ExJ~c?I??@??O?m?h????g}??1?? +7??*;N?/??F????"????Z_?n?r2??.?43???@???0??V>?K? ???????????#?? g?M????,u"??U?N??n??5rB???|?&??? +?????~???N?? +9X??J?? ]M??,?S?-?????[Tfhfo[LG>???_?ue??Y3V???bz?I????5M@??????[????Z? 2d.???.??L??$[?e???f?\&?-?b?????1;6?3vy???????o????h`?J??b???E??????N2?~?}?P?!??( :??DYi?J?,?i?Gu2M?]?f0U?tz}R?????????P?Mu?g??^ ??GR>a???/???^??_??????yb?????????)a?vA??U^jeB3I?P????????N?|,?N??(?G>??K??P? pV??,d ???^ +?l?.???I?L??u?r6Z?;??_????>c?`??g!Be???-???{?.w(M?p?0??#J?# ?3??qF\~^??X?}?S??[?4+?[O ?w???C7B?E$h?v?kJ?J???O???v???T????E????1i????8???)??r?`????X=R??@~?? ??[????R???5?k???r??F?C&?-SS?5, ??Y???(??Q?T???m?r???Nxr?9 ?d????,J?????Mf??{???-m?|w????7?Y????c?)?\?/&?????Z?s +?I??'????z??Q?:??H|??|? ?????0????.??/Il??g|?k?\??F?p???8??_Q??F????!?O??/"??`?_??[???d??z ?+???,?J?Yu?.i8????x&??*?BEt6?S?????[?g?22??6-?/?xsUX_????!Q????`??uy???BIM??eiU?"Q4?P7? ??n?<3?~???Ec???C?z??d *:????Y???W~T???V?s|\%??S???S????]??M?9p?|s??A??U?#?7?FVM?^?4 ?gXa?f(g?4+?? H??f\{?Uy)???a?+w\ ?????Z?Y{P????????>.??_1???SK?$???c???? ? +?? ???3v?Z?\\)mr?)??7D??#?W????df?????5L?L?4?(T1@?\t?:?l4??bi?N?^??????????????]????e???\??jR ?|??????V???3? +R&+l5?=`???????:F??'?????j#?}$??? ?_Q??vy???8_q??F}??)???U???!@???"rx???-k^???????-???C???MV?, ?/?Vg?8?u?d3??????&?? +?5?l5)??_R?g3?6??Z|??+/??V??$?*Hk??^?$<[?????; .V??r??/j????5W_???F??\?+??Z?jT?*B?!??I????E}?? ????1y???> +endobj +49 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [349.982 704.796 382.378 717.594] +/A << /S /GoTo /D (cite.Graler2014) >> +>> +endobj +50 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [384.108 704.796 407.919 717.594] +/A << /S /GoTo /D (cite.Graler2014) >> +>> +endobj +72 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [172.569 620.218 180.016 633.016] +/A << /S /GoTo /D (equation.2.1) >> +>> +endobj +73 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [230.739 620.218 238.186 633.016] +/A << /S /GoTo /D (section.2) >> +>> +endobj +74 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [170.182 579.57 202.578 592.368] +/A << /S /GoTo /D (cite.Graler2014) >> +>> +endobj +75 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [208.819 579.57 232.63 592.368] +/A << /S /GoTo /D (cite.Graler2014) >> +>> +endobj +76 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [401.909 566.021 522.996 578.819] +/A << /S /GoTo /D (cite.Aas2009) >> +>> +endobj +103 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [80.004 552.472 117.276 565.27] +/A << /S /GoTo /D (cite.Aas2009) >> +>> +endobj +77 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [118.581 552.472 142.392 565.27] +/A << /S /GoTo /D (cite.Aas2009) >> +>> +endobj +78 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [146.719 552.472 239.971 565.27] +/A << /S /GoTo /D (cite.Bedford2002) >> +>> +endobj +79 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [241.276 552.472 265.087 565.27] +/A << /S /GoTo /D (cite.Bedford2002) >> +>> +endobj +80 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [93.156 525.373 193.266 538.171] +/A << /S /GoTo /D (cite.Graler2012a) >> +>> +endobj +81 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [199.582 525.373 223.392 538.171] +/A << /S /GoTo /D (cite.Graler2012a) >> +>> +endobj +82 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [324.186 427.245 425.082 440.043] +/A << /S /GoTo /D (cite.Kojadinovic2010a) >> +>> +endobj +83 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [425.758 427.245 449.569 440.043] +/A << /S /GoTo /D (cite.Kojadinovic2010a) >> +>> +endobj +84 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [453.267 427.245 474.045 440.043] +/A << /S /GoTo /D (cite.Yan2007) >> +>> +endobj +85 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [474.721 427.245 498.531 440.043] +/A << /S /GoTo /D (cite.Yan2007) >> +>> +endobj +86 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [259.554 400.147 444.482 412.945] +/A << /S /GoTo /D (cite.Schepsmeier2013) >> +>> +endobj +87 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [446.149 400.147 469.959 412.945] +/A << /S /GoTo /D (cite.Schepsmeier2013) >> +>> +endobj +88 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [267.245 359.499 370.213 372.297] +/A << /S /GoTo /D (cite.Pebesma2005) >> +>> +endobj +89 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [372.198 359.499 396.008 372.297] +/A << /S /GoTo /D (cite.Pebesma2005) >> +>> +endobj +90 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [479.004 359.499 522.996 372.297] +/A << /S /GoTo /D (cite.Pebesma2012) >> +>> +endobj +91 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[0 1 0] +/Rect [80.004 345.95 103.814 358.748] +/A << /S /GoTo /D (cite.Pebesma2012) >> +>> +endobj +92 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [152.046 335.128 159.493 344.692] +/A << /S /GoTo /D (table.1) >> +>> +endobj +93 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [512.527 289.081 519.975 300.76] +/A << /S /GoTo /D (section.3) >> +>> +endobj +94 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [117.881 275.532 125.328 287.211] +/A << /S /GoTo /D (section.4) >> +>> +endobj +95 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [341.662 248.433 349.109 260.113] +/A << /S /GoTo /D (section.5) >> +>> +endobj +96 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [118.141 209.902 125.588 219.465] +/A << /S /GoTo /D (section.6) >> +>> +endobj +97 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [293.612 209.902 301.059 219.465] +/A << /S /GoTo /D (section.7) >> +>> +endobj +101 0 obj +<< +/D [99 0 R /XYZ 80 770.89 null] +>> +endobj +98 0 obj +<< +/Font << /F8 59 0 R /F74 102 0 R /F70 61 0 R /F48 55 0 R /F69 60 0 R /F21 104 0 R /F23 105 0 R >> +/ProcSet [ /PDF /Text ] +>> +endobj +130 0 obj +<< +/Length 4476 +/Filter /FlateDecode +>> +stream +x??\[o#??~??`?????[_l?a=?8 '????E??$bDQf??'/??9??t?HQy? +?]?U???;????L??wg?^?}???Um?????DW??ZMjW?q?????o?jz??\-??O??=???????????L\S??????6????~9?w?;????_}h?mU?MY?l?hp?Y)d?O|?-?JW???[Tm;B +]W????u3????2]5?n??/?~>SH?DM??E]?I?UQ???????+? ?6?'?????h???M>??s??d(oa5???????g??????;????K?'?*T??+o?58?_??????f???e?SPW8???]?K??|.}%?~k?{K{????v?'=P??)%?.????>?Um?Qe???a????i?>???.L Z?4|???????Mku????????}?? ?kF?)?jU?w?p?zk???v6G?u=??x?bX?X*?|^z>???~??W:?V??$N`s9?G??f?>?? ?E0????G?? ?22????G?? ?T9?|?9?6}??ZW??~?/;"*?N????(???`LB??,z =?z??(?No?Q?W?&%??R?v???$(0z???1Su ? +?1??+C???#R"???GY%rUam??E???G??,6?n???\f?? PGL??`?????/?~?0????E?I?-c?|5??a???F???U????? +??`???;?????Aucqa-?U???,??8?R?|??jP???3g???xp?"?.\?G?&?8?????y? ;??iLQ???????c-l??e"??vzES?e,??^??x?k?d]?????????F"??I??6F??s??????4??I??O??>4???to?h???(??LT??=Ew?VW? ZLY??I?G?????pcKx???/ +?????A???7h(?r$?n?'18?r?? ZsT?!?S? ?^X?????B???*?y?3.??d??3?A?q&Z??.c mu???????>\?u;??[??]???????i?d????~?V_???r?K???1Ty w?%????b?C?r???? d?p?r? ? ??? [h???eQ???-M.KN?????\??0??m?????ZN9??????}q?1???????hui?/}!???",??[??c?u?0A`0?]Lf???M&)??K: ???3?q ?R?????S???;??0ik[?C'$0???z'9?UR?Z?h?b??I??q?E\??a&/? O????f9????@?????L 6???R#???????rq?????9?K,??"-??? ????Rn8T????A$?? ??ZZ?I?R?? +???q(???"?(??r??:?0?J????qj?JbzM.0?o????,?U?Y???????????;??q??h7??V??????RM??@k??????=AyW?Ty?F?????j?@?5??a?????$?*M`?V,???uiIu<?A?? +Qev??9?CiL????? +??O?????d???+E?;?,,=@?????????W?????c???????y????-????????i????@?RNbma?`?x\ 6 +????w???a????0:Af? *`??y`????R?5????J?j|?V%Q?S1?0?s-?`?????????ok?? !??|??W?_g?*l,??)????%??d4?*4??? +??KN?????kVLk?q??}???Mv??eh???>)4? +?3?u??6?????@ ???????????????F>o=???t?[n%??k>~?cy????Q???y?#?%???yB???$D"? {r?8QDG< 2???9????????*yW2??ML(???QnT?B???? +? +?????HA"!??OMb^J?ww?7>?? Qj?T8R?Q+????I???*??&*?d?L|?~?TLje??j)-A?>?**???D??????????????t:_?kb??,QMac???,???????}\??2 at ST???B????????y????65?T???&%F???Bj8??l?????y? Author: ben_graeler Date: 2017-02-07 12:35:01 +0100 (Tue, 07 Feb 2017) New Revision: 162 Added: pkg/R/hkCopula.R pkg/man/hkCopula-class.Rd pkg/man/hkCopula.Rd pkg/man/rCopula_y.Rd Modified: / pkg/DESCRIPTION pkg/NAMESPACE pkg/R/Classes.R pkg/R/asCopula.R pkg/R/cqsCopula.R pkg/R/empiricalCopula.R pkg/R/mixtureCopula.R pkg/R/partialDerivatives.R pkg/R/spCopula.R pkg/R/spVineCopula.R pkg/R/stCoVarVineCopula.R pkg/R/stCopula.R pkg/R/stVineCopula.R pkg/man/asCopula.Rd pkg/man/cqsCopula.Rd pkg/man/mixtureCopula.Rd pkg/tests/Examples/spcopula-Ex.Rout.save Log: keeping track with copula, adds some functionality for Hierarchical Kendall Copulas Property changes on: ___________________________________________________________________ Modified: svn:ignore - .Rd2pdf6724 .Rhistory .Rproj.user Meuse_spcopula_estimation.R pkg.Rcheck pkg.pdf spcopula.Rcheck spcopula.Rproj spCopDemo_old_Mar_2013.RData .RData inst spcopula_0.2-1.tar.gz + .Rd2pdf6724 .Rhistory .Rproj.user Meuse_spcopula_estimation.R pkg.Rcheck pkg.pdf spcopula.Rcheck spcopula.Rproj spCopDemo_old_Mar_2013.RData .RData inst spcopula_0.2-1.tar.gz copula_example_template.R spcopula_0.2-2.tar.gz Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/DESCRIPTION 2017-02-07 11:35:01 UTC (rev 162) @@ -1,13 +1,13 @@ Package: spcopula Type: Package -Title: Copula Driven Spatio-Temporal Analysis -Version: 0.2-1 -Date: 2016-09-12 +Title: Copula Driven Analysis - Multivariate, Spatial, Spatio-Temporal +Version: 0.2-2 +Date: 2017-02-07 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), - email = "ben.graeler at uni-muenster.de"), + email = "b.graeler at 52north.org"), person("Marius", "Appel",role = "ctb")) -Maintainer: Benedikt Graeler -Description: We provide a framework to analyse spatial and spatio-temporal data via copulas and vine copulas. The data needs to be provided in the form of the sp and spacetime package respectively. Additionally, support for calculating different multivariate return periods based on copulas and vine copulas is implemented. +Maintainer: Benedikt Graeler +Description: A framework to analyse multivariate, spatial and spatio-temporal data via copulas, vine copulas and hierarchical Kendall copulas is provided. The spatial/spatio-temporal data needs to be provided in the form of the sp and spacetime package respectively. Additionally, support for calculating different multivariate return periods based on copulas and vine copulas is implemented. As of version 0.2-2, Hierarchical Kendall Copulas are also provided. License: GPL-3 LazyLoad: yes Depends: copula (>= 0.999-15), R (>= 3.1.0), VineCopula (>= 2.0.4) @@ -35,4 +35,5 @@ tawn3pCopula.R tailDependenceFunctions.R KendallDistribution.R + hkCopula.R zzz.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/NAMESPACE 2017-02-07 11:35:01 UTC (rev 162) @@ -4,10 +4,10 @@ import(methods) importFrom("graphics", "abline", "smoothScatter") - importFrom("stats", "D", "approxfun", "cor", "ecdf", "integrate", "lm", - "optim", "optimise", "optimize", "pnorm", "predict", "pt", - "qnorm", "qt", "quantile", "runif", "uniroot", "var") - importFrom("utils", "setTxtProgressBar", "txtProgressBar", "tail") +importFrom("stats", "D", "approxfun", "cor", "ecdf", "integrate", "lm", + "optim", "optimise", "optimize", "pnorm", "predict", "pt", + "qnorm", "qt", "quantile", "runif", "uniroot", "var") +importFrom("utils", "setTxtProgressBar", "txtProgressBar", "tail", "capture.output", "str") importMethodsFrom(VineCopula, fitCopula) importMethodsFrom(VineCopula, dduCopula,ddvCopula) @@ -46,13 +46,14 @@ export(neighbourhood, stNeighbourhood) export(empiricalCopula, genEmpCop, empSurCopula, genEmpSurCop) export(mixtureCopula) +export(hkCopula) # general functions export(rankTransform, dependencePlot, unitScatter, univScatter) export(fitCopula) export(dduCopula,ddvCopula) export(invdduCopula, invddvCopula) -export(qCopula_u, qCopula_v) +export(qCopula_u, qCopula_v, rCopula_y) export(condSpVine,spCopPredict) export(condStVine,stCopPredict) export(condStCoVarVine, condCovariate) @@ -82,4 +83,5 @@ exportClasses(asCopula, cqsCopula, tawn3pCopula, neighbourhood, stNeighbourhood, empiricalCopula, empSurCopula) exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) exportClasses(stCoVarVineCopula) -exportClasses(mixtureCopula) \ No newline at end of file +exportClasses(mixtureCopula) +exportClasses(hkCopula) \ No newline at end of file Modified: pkg/R/Classes.R =================================================================== --- pkg/R/Classes.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/Classes.R 2017-02-07 11:35:01 UTC (rev 162) @@ -1,87 +1,4 @@ -## an asymmetric copula with cubic and quadratic sections - -validAsCopula = 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") - else return (TRUE) -} - -# the lower bound of the parameter a dependening on the parameter b -limA <- function (b) { - 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, - contains = list("copula") -) - #### -## a symmetric copula with cubic and quadratic sections - -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 (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) - return("Only one of the parameters may be kept fixed.") - } - else return (TRUE) -} - -setClass("cqsCopula", - representation = representation("copula",fixed="character"), - validity = validCqsCopula, - contains = list("copula") -) - -#### -## an empirical copula representation - -validEmpCopula <- function(object) { - if(ncol(object at sample) != object at dimension) - return("Dimension of the copula and the sample do not match.") - else - return(TRUE) -} - -setClass("empiricalCopula", - representation = representation("copula", sample="matrix"), - validity = validEmpCopula, - contains = list("copula") -) - -#### ## an empirical survival copula representation validEmpSurCopula <- function(object) { @@ -115,6 +32,32 @@ contains = list("copula") ) +##### +## Hierarchical Kendall Copulas + +validHkCopula <- function(object) { + stopifnot(all(sapply(object at clusterCops, function(x) inherits(x[[1]], "copula")))) + if (object at dimension != sum(sapply(object at clusterCops, function(x) x[[1]]@dimension))+object at nestingCop@dimension-length(object at clusterCops)) + return("The dimensions of the hierarchical Kendall copula do not match.") + + if(length(object at clusterCops) != length(object at kenFuns)) + return("Each cluster copula needs to have its Kendall function in 'kenFuns'.") + + else return (TRUE) +} + +setClass("hkCopula", + representation = representation("copula", + nestingCop = "copula", + clusterCops = "list", + kenFuns = "list"), + validity = validHkCopula, + contains = list("copula") +) + + + + ## ## the spatial copula ## @@ -158,10 +101,10 @@ check.lower <- c(check.lower, is.na(object at calibMoa(object at components[[i]], c(0,object at distances)[i]))) } if(sum(check.upper>0)) return(paste("Reconsider the upper boundary conditions of the following copula(s): \n", - paste(sapply(object at components[check.upper], function(x) x at fullname), + paste(sapply(object at components[check.upper], function(x) describeCop(x, "very short")), "at", object at distances[check.upper],collapse="\n"))) if(sum(check.lower>0)) return(paste("Reconsider the lower boundary conditions of the following copula(s): \n", - paste(sapply(object at components[check.lower], function(x) x at fullname), + paste(sapply(object at components[check.lower], function(x) describeCop(x, "very short")), "at", object at distances[check.lower],collapse="\n"))) } return(TRUE) @@ -280,4 +223,5 @@ var="character", coVar="character", prediction="logical"), - validity = validStNeighbourhood) \ No newline at end of file + validity = validStNeighbourhood) + Modified: pkg/R/asCopula.R =================================================================== --- pkg/R/asCopula.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/asCopula.R 2017-02-07 11:35:01 UTC (rev 162) @@ -5,6 +5,41 @@ ########################## # (see Example 3.16 in: Nelsen, Roger B. (2006): An Introduction to Copulas, second edition, Springer) +validAsCopula = 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") + else return (TRUE) +} + +# the lower bound of the parameter a dependening on the parameter b +limA <- function (b) { + 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, + contains = list("copula") +) + # constructor asCopula <- function (param=c(0,0)) { val <- new("asCopula", dimension = as.integer(2), parameters = param, @@ -13,6 +48,24 @@ return(val) } +## printing +setMethod("describeCop", c("asCopula", "character"), + function(x, kind = c("short", "very short", "long"), prefix = "", ...) { + kind <- match.arg(kind) + if(kind == "very short") # e.g. for show() which has more parts + return(paste0(prefix, "AS-CQS copula")) + + name <- "asymmetric" + d <- dim(x) + ch <- paste0(prefix, name, " copula, dim. d = ", d) + switch(kind <- match.arg(kind), + short = ch, + long = paste0(ch, "\n", prefix, " param.: ", + capture.output(str(x at parameters, + give.head=FALSE))), + stop("invalid 'kind': ", kind)) + }) + ## density ## dASC2 <- function (u, copula, log=FALSE) { @@ -184,11 +237,14 @@ fitCopulaASC2 <- function (copula, data, method = "ml", start=c(0,0), lower=c(-3,-1), upper=c(1,1), optim.method="L-BFGS-B", optim.control=list(), - estimate.variance = FALSE) { + estimate.variance = FALSE, call) { + if(missing(call)) + call <- match.call() + fit <- switch(method, - ml=fitASC2.ml(copula, data, start, lower, upper, optim.control, optim.method), - itau=fitASC2.itau(copula, data, estimate.variance), - irho=fitASC2.irho(copula, data, estimate.variance), + ml=fitASC2.ml(copula, data, start, lower, upper, optim.control, optim.method, call), + itau=fitASC2.itau(copula, data, estimate.variance, call), + irho=fitASC2.irho(copula, data, estimate.variance, call), stop("Implemented methods for copulas in the spCopula package are: ml, itau, and irho.")) return(fit) } @@ -207,27 +263,33 @@ # method # one of kendall or spearman according to the calculation of moa -fitASC2.itau <- function(copula, data, estimate.variance, tau=NULL) { +fitASC2.itau <- function(copula, data, estimate.variance, tau=NULL, call) { + if(missing(call)) + call <- match.call() if(is.null(tau)) tau <- TauMatrix(data)[1,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", + method = "Inversion of Kendall's tau and MLE", call = call, fitting.stats = list(convergence=as.integer(NA)), copula = copula) } fitASC2.irho <- function(copula, data, estimate.variance, rho=NULL){ + if(missing(call)) + call <- match.call() 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", + method = "Inversion of Spearman's rho and MLE", call=call, fitting.stats = list(convergence=as.integer(NA)), copula = copula) } @@ -252,8 +314,11 @@ # maximum log-likelihood estimation of a and b using optim -fitASC2.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:") +fitASC2.ml <- function(copula, data, start, lower, upper, optim.control, optim.method, call) { + if(missing(call)) + call <- match.call() + 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) @@ -269,6 +334,7 @@ loglik = -optimized$value, nsample = nrow(data), method = "Numerical MLE over the full range.", + call = call, fitting.stats = optimized, copula = asCopula(optimized$par))) } Modified: pkg/R/cqsCopula.R =================================================================== --- pkg/R/cqsCopula.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/cqsCopula.R 2017-02-07 11:35:01 UTC (rev 162) @@ -3,7 +3,36 @@ ## a symmetric copula with cubic quadratic sections ## ## ## ###################################################### +# (see Example 3.16 in: Nelsen, Roger B. (2006): An Introduction to Copulas, second edition, Springer) +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 (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) + return("Only one of the parameters may be kept fixed.") + } + else return (TRUE) +} + +setClass("cqsCopula", + representation = representation("copula",fixed="character"), + validity = validCqsCopula, + contains = list("copula") +) + +# constructor 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), @@ -11,6 +40,24 @@ fullname = "copula family with cubic quadratic sections", fixed=fixed) } +## printing +setMethod("describeCop", c("cqsCopula", "character"), + function(x, kind = c("short", "very short", "long"), prefix = "", ...) { + kind <- match.arg(kind) + if(kind == "very short") # e.g. for show() which has more parts + return(paste0(prefix, "CQS copula")) + + name <- "cubic-quadratic sections" + d <- dim(x) + ch <- paste0(prefix, name, " copula, dim. d = ", d) + switch(kind <- match.arg(kind), + short = ch, + long = paste0(ch, "\n", prefix, " param.: ", + capture.output(str(x at parameters, + give.head=FALSE))), + stop("invalid 'kind': ", kind)) + }) + ## density ## dCQSec <- function (u, copula, log=F) { a <- copula at parameters[1] Modified: pkg/R/empiricalCopula.R =================================================================== --- pkg/R/empiricalCopula.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/empiricalCopula.R 2017-02-07 11:35:01 UTC (rev 162) @@ -4,6 +4,21 @@ ## ## ######################################## +# validity +validEmpCopula <- function(object) { + if(ncol(object at sample) != object at dimension) + return("Dimension of the copula and the sample do not match.") + else + return(TRUE) +} + +# class definition +setClass("empiricalCopula", + representation = representation("copula", sample="matrix"), + validity = validEmpCopula, + contains = list("copula") +) + # constructor empiricalCopula <- function (sample=NULL, copula) { if(is.null(sample) && missing(copula)) @@ -22,7 +37,7 @@ new("empiricalCopula", dimension = copula at dimension, parameters = copula at parameters, param.names = copula at param.names, param.lowbnd = copula at param.lowbnd, param.upbnd = copula at param.upbnd, - fullname = paste("Empirical copula derived from",copula at fullname), + fullname = paste("Empirical copula derived from", describeCop(copula, "very short")), sample=sample) } @@ -33,6 +48,24 @@ empiricalCopula(rCopula(sample.size, copula), copula) } +# printing +setMethod("describeCop", c("empiricalCopula", "character"), + function(x, kind = c("short", "very short", "long"), prefix = "", ...) { + kind <- match.arg(kind) + name <- "empirical" + if(kind == "very short") # e.g. for show() which has more parts + return(paste0(prefix, name, " copula")) + ## else + d <- dim(x) + ch <- paste0(prefix, name, " copula, dim. d = ", d) + switch(kind <- match.arg(kind), + short = ch, + long = paste0(ch, "\n", prefix, " param.: ", + capture.output(str(x at parameters, + give.head=FALSE))), + stop("invalid 'kind': ", kind)) + }) + ## density, not yet needed and hence not implemented ## ## jcdf ## @@ -88,7 +121,7 @@ new("empSurCopula", dimension = copula at dimension, parameters = copula at parameters, param.names = copula at param.names, param.lowbnd = copula at param.lowbnd, param.upbnd = copula at param.upbnd, - fullname = paste("Empirical survival copula derived from",copula at fullname), + fullname = paste("Empirical survival copula derived from", describeCop(copula, "very short")), sample=sample) } Added: pkg/R/hkCopula.R =================================================================== --- pkg/R/hkCopula.R (rev 0) +++ pkg/R/hkCopula.R 2017-02-07 11:35:01 UTC (rev 162) @@ -0,0 +1,232 @@ +## Hierarchical Kendall Copulas as defined in Brechmann, Eike Christian. +## "Hierarchical Kendall copulas: Properties and inference." Canadian Journal +## of Statistics 42.1 (2014): 78-108. + +# Slots: +# +# Name: nestingCop clusterCops kenFuns dimension parameters param.names param.lowbnd param.upbnd fullname +# Class: copula list list integer numeric character numeric numeric character + +## nestingCop copula +## clusterCop list of list (copula, ind) + +# easy constructor + +hkCopula <- function(nestingCop, clusterCops, kenFuns=NULL) { + if (is.null(kenFuns)) { + kenFuns <- lapply(clusterCops, function(copInd) getKendallDistr(copInd[[1]])) + } + + new("hkCopula", + nestingCop = nestingCop, + clusterCops = clusterCops, + kenFuns = kenFuns, + dimension = as.integer(sum(sapply(clusterCops, function(x) x[[1]]@dimension))+nestingCop at dimension-length(clusterCops)), + parameters = NA_real_, + param.names =NA_character_, + param.lowbnd = NA_real_, + param.upbnd = NA_real_, + fullname = "Hierarchical Kendall Copula") +} + +showHkCopula <- function(object) { + cat(object at fullname, "\n") + cat("Dimension: ", object at dimension, "\n") + cat("Nesting copula:\n") + show(object at nestingCop) + cat("Cluster copulas:\n") + for (i in 1:length(object at clusterCops)) { + cmpCop <- object at clusterCops[[i]][[1]] + cat(" ", describeCop(cmpCop, "very short"), + "of dimension", cmpCop at dimension, + "for indices", object at clusterCops[[i]][[2]], "\n") + } +} + +setMethod("show", signature("hkCopula"), showHkCopula) + +## density + +dHkCop <- function(u, copula, log=F, ...) { + stopifnot(ncol(u) == copula at dimension) + + lik <- NULL + kenVal <- NULL + + for (i in 1:length(copula at clusterCops)) { + cop <- copula at clusterCops[[i]][[1]] + ind <- copula at clusterCops[[i]][[2]] + ken <- copula at kenFuns[[i]] + + lik <- cbind(lik, dCopula(u[, ind], cop, log=log)) + kenVal <- cbind(kenVal, ken(pCopula(u[, ind], cop))) + } + + if (ncol(kenVal) < copula at nestingCop@dimension) { + kenVal <- cbind(kenVal, u[, -sapply(copula at clusterCops, function(x) x[[2]])]) + } + + lik <- cbind(lik, dCopula(kenVal, copula at nestingCop, log=log)) + + if (log) + return(apply(lik, 1, sum)) + + return(apply(lik, 1, prod)) +} + +setMethod("dCopula", signature("matrix", "hkCopula"), dHkCop) +setMethod("dCopula", signature("numeric", "hkCopula"), + function(u, copula, log, ...) dHkCop(matrix(u, ncol = copula at dimension), copula, log, ...)) + +rHkCop <- function(n, copula, ...) { + smpl <- matrix(NA, n, copula at dimension) + + nestSmpl <- rCopula(n, copula at nestingCop) + + for (i in 1:length(copula at clusterCops)) { + cop <- copula at clusterCops[[i]][[1]] + ind <- copula at clusterCops[[i]][[2]] + ken <- copula at kenFuns[[i]] + invKen <- genInvKenFun(ken) + + smpl[,ind] <- rCopula_y(invKen(nestSmpl[,i]), cop) + } + + if (ncol(nestSmpl) > length(copula at clusterCops)) { + smpl[,-sapply(copula at clusterCops, function(x) x[[2]])] <- nestSmpl[, -c(1:length(copula at clusterCops))] + } + + return(smpl) +} + +setMethod(rCopula, signature = c("numeric","hkCopula"), rHkCop) + +setMethod(pCopula, signature = c("numeric","hkCopula"), + function(u, copula, ...) stop("Please use an empirical representation (i.e. \"genEmpCop\" applied to a sample of this copula).")) + +setMethod(pCopula, signature = c("matrix","hkCopula"), + function(u, copula, ...) stop("Please use an empirical representation (i.e. \"genEmpCop\" applied to a sample of this copula).")) + + +rCop_y <- function(y, copula, n=1, n.disc = 1e2) { + stopifnot(copula at dimension == 2) + n.y <- length(y) + stopifnot(n.y == 1 | n == 1) + + smpl <- matrix(NA, n.y*n, 2) + + for (i in 1:n.y) { # i <- 1 + condVals <- seq(y[i], 1-(1-y[i])/n.disc, length.out = n.disc) + uv <- qCopula_v(copula, rep(y[i], n.disc), condVals) + uv <- rbind(uv, qCopula_u(copula, rep(y[i], n.disc), condVals)) + + uv <- uv[order(uv[,1]),] + + dSeq <- cumsum(c(0, apply((uv[-nrow(uv),]-uv[-1,])^2, 1, function (x) sqrt(sum(x))))) + probs <- dCopula(uv, copula) + + apFun <- approxfun(dSeq, probs, rule = 2) + probCor <- integrate(apFun, 0, max(dSeq))$value + + rContour <- runif(n, 0, probCor) + + funAppConPoint <- function(rCont) { + invCDFContour <- function(x) { + abs(integrate(apFun, 0, x)$value - rCont) + } + + lContour <- optimise(invCDFContour, c(0, max(dSeq)))$minimum + + dSeqInt <- findInterval(lContour, dSeq) + + lSeq <- sqrt(sum((uv[dSeqInt,]-uv[dSeqInt+1,])^2)) + + uv[dSeqInt,] + (lContour - dSeq[dSeqInt])/lSeq * (uv[dSeqInt+1,]-uv[dSeqInt,]) + } + + if (n == 1) { + appConPoint <- funAppConPoint(rContour) + + if (appConPoint[1] > appConPoint[2]) { + smpl[i,] <- qCopula_u(copula, y[i], appConPoint[1]) + } else { + smpl[i,] <- qCopula_v(copula, y[i], appConPoint[2]) + } + } else { + appConPoint <- t(sapply(rContour, funAppConPoint)) + + boolLower <- appConPoint[,1] > appConPoint[,2] + smpl[boolLower,] <- qCopula_u(copula, rep(y, sum(boolLower)), appConPoint[boolLower, 1]) + smpl[!boolLower,] <- qCopula_v(copula, rep(y, sum(!boolLower)), appConPoint[!boolLower, 2]) + } + + # plot(uv, type="l", xlim=c(uv[dSeqInt+c(0,1)]+c(-1,1)/1000), asp=1) + # points(uv[dSeqInt+c(0,1),], col=c("red", "purple")) + # points(matrix(appConPoint, nrow = 1), col="green") + # points(matrix(smpl, nrow = 1), col="green", pch=2) + } + + return(smpl) +} + +setGeneric("rCopula_y", function(y, copula, n=1, n.disc=1e2) NULL) +setMethod("rCopula_y", signature("numeric", "copula"), rCop_y) + +# ## attic +# hkCop <- new("hkCopula", nestingCop=normalCopula(0.6), +# clusterCops=list(list(cop=frankCopula(3), ind=c(1,2))), +# kenFuns = list(getKendallDistr(frankCopula(3))), +# dimension = 3L, +# parameters = NA_real_, +# param.names ="", +# param.lowbnd = NA_real_, +# param.upbnd = NA_real_, +# fullname = "Hierarchical Kendall Copula") +# +# hkCop4D <- new("hkCopula", nestingCop=normalCopula(0.6), +# clusterCops=list(list(cop=frankCopula(3), ind=c(1,2)), +# list(cop=gumbelCopula(5), ind=c(3,4))), +# kenFuns = list(getKendallDistr(frankCopula(3)), +# getKendallDistr(gumbelCopula(5))), +# dimension = 4L, +# parameters = c(0), +# param.names ="", +# param.lowbnd = c(0), +# param.upbnd = 0, +# fullname = "Hierarchical Kendall Copula") +# +# rHkCop(10, hkCop) +# +# smplRHkCop3D <- rCopula(100, hkCop) +# +# library(rgl) +# plot3d(smplRHkCop3D) +# kenHKcop <- genEmpKenFun(hkCop, sample = smplRHkCop3D) +# +# curve(kenHKcop) +# +# showMethods("pCopula") +# +# plot(rCopula_y(0.9, gumbelCopula(5), 100)) +# plot(rCopula_y(0.9, tawn3pCopula(c(0.75,.25,5)), 100)) +# plot(rCopula_y(0.9, normalCopula(0.4), 100), asp=1) +# points(rCopula_y(0.9, normalCopula(0.8), 100), asp=1, pch=2) +# points(rCopula_y(0.9, normalCopula(-0.8), 100), asp=1, pch=3) +# +# points(rCopula_y(0.4, normalCopula(-0.3), 100), asp=1, pch=4) +# abline(1.9,-1, col="red") +# +# contour(normalCopula(-0.3), pCopula, asp=1) +# +# sum(dHkCop(rHkCop(10, hkCop), hkCop))/10 +# sum(dHkCop(rHkCop(10, hkCop4D), hkCop4D))/10 +# +# sum(dHkCop(matrix(runif(3000), 1000), hkCop))/1000 +# sum(dHkCop(matrix(runif(4000), 1000), hkCop4D))/1000 +# +# par(mfrow=c(2,1)) +# hist(dHkCop(matrix(runif(4*1e5),ncol = 4), hkCop4D), n=4000, xlim=c(0,10)) +# hist(dHkCop(matrix(runif(3*1e5),ncol = 3), hkCop), n=400, xlim=c(0,10)) +# +# sum(dHkCop(matrix(runif(4*1e5),ncol = 4), hkCop4D))/1e5 +# sum(dHkCop(matrix(runif(3*1e5),ncol = 3), hkCop))/1e5 \ No newline at end of file Modified: pkg/R/mixtureCopula.R =================================================================== --- pkg/R/mixtureCopula.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/mixtureCopula.R 2017-02-07 11:35:01 UTC (rev 162) @@ -30,7 +30,8 @@ param.names = c(memberCops[[1]]@param.names, memberCops[[2]]@param.names, "mixLambda"), param.lowbnd = c(memberCops[[1]]@param.lowbnd, memberCops[[2]]@param.lowbnd, 0), param.upbnd = c(memberCops[[1]]@param.upbnd, memberCops[[2]]@param.upbnd, 1), - fullname = paste("mixture of a", memberCops[[1]]@fullname, "and a", memberCops[[2]]@fullname)) + fullname = paste("mixture of a", describeCop(memberCops[[1]], "very short"), + "and a", describeCop(memberCops[[2]], "very short"))) } ## density ## @@ -71,14 +72,14 @@ # invddu invdduMixCop <- function (u, copula, y) { stopifnot(length(u) == length(y)) - + opti <- function(ind) { optFun <- function(v) { (dduCopula(cbind(u[ind], v), copula) - y[ind])^2 } optimise(optFun, c(0,1))$minimum } - + sapply(1:length(y), opti) } @@ -131,17 +132,16 @@ lower <- copula at param.lowbnd if(is.null(upper)) upper <- copula at param.upbnd - + optFun <- function(parSet) { cop <- mixtureCopula(parSet, copula at memberCops) - cat(cop at parameters, "\n") -sum(log(dCopula(data, cop))) } optOut <- optim(start, optFun, method = optim.method, lower = lower, upper = upper, control = optim.control) - + new("fitCopula", copula = mixtureCopula(optOut$par, copula at memberCops), estimate = optOut$par, @@ -165,6 +165,11 @@ (1-mixLambda) * tau(copula at memberCops[[1]], ...) + mixLambda * tau(copula at memberCops[[2]], ...) }) +setMethod("rho", signature = c(copula = "mixtureCopula"), + function(copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * rho(copula at memberCops[[1]], ...) + mixLambda * rho(copula at memberCops[[2]], ...) + }) setMethod("lambda", signature = c(copula = "mixtureCopula"), function(copula, ...) { Modified: pkg/R/partialDerivatives.R =================================================================== --- pkg/R/partialDerivatives.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/partialDerivatives.R 2017-02-07 11:35:01 UTC (rev 162) @@ -266,7 +266,7 @@ ########################## ## Wolfram alpha: -# -e^?/(e^(? u) - e^?) - ((e^? - 1) e^(? + ? u))/((e^(? u) - e^?) (e^? - e^(? + ? u) + e^(? u + ? v) - e^(? + ? v))) +# -e^a/(e^(a u) - e^a) - ((e^a - 1) e^(a + a u))/((e^(a u) - e^a) (e^a - e^(a + a u) + e^(a u + a v) - e^(a + a v))) dduFrank <- function(u, copula){ rho <- copula at parameters Modified: pkg/R/spCopula.R =================================================================== --- pkg/R/spCopula.R 2017-02-01 15:31:26 UTC (rev 161) +++ pkg/R/spCopula.R 2017-02-07 11:35:01 UTC (rev 162) @@ -56,7 +56,7 @@ if(class(x)=="indepCopula") return(NA) x at param.upbnd})) - + new("spCopula", dimension=as.integer(2), parameters=param, param.names=param.names, param.lowbnd=param.low, param.upbnd=param.up, fullname="Spatial Copula: distance dependent convex combination of bivariate copulas", @@ -70,14 +70,11 @@ cat("Copulas:\n") for (i in 1:length(object at components)) { cmpCop <- object at components[[i]] - cat(" ", cmpCop at fullname, "at", object at distances[i], - paste("[",object at unit,"]",sep=""), "\n") -# if (length(cmpCop at parameters) > 0) { -# for (i in (1:length(cmpCop at parameters))) -# cat(" ", cmpCop at param.names[i], " = ", cmpCop at parameters[i], "\n") -# } + cat(" ", describeCop(cmpCop, "very short"), "at", object at distances[i], + paste("[",object at unit,"]",sep=""), "\n") } - if(!is.null(object at calibMoa(normalCopula(0),0))) cat("A spatial dependence function is used. \n") + if(!is.null(object at calibMoa(normalCopula(0),0))) + cat("A spatial dependence function is used. \n") } setMethod("show", signature("spCopula"), showCopula) @@ -555,7 +552,7 @@ loglik <- NULL copulas <- list() for (cop in families) { - cat(cop at fullname,"\n") + cat(describeCop(cop, "very short"),"\n") tmploglik <- NULL tmpCop <- list() @@ -609,7 +606,7 @@ fits <-lapply(families, function(cop) { - cat(cop at fullname,"\n") [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 162 From noreply at r-forge.r-project.org Wed Feb 8 10:10:02 2017 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Feb 2017 10:10:02 +0100 (CET) Subject: [spcopula-commits] r163 - in pkg: . R tests/Examples Message-ID: <20170208091002.86798186B8C@r-forge.r-project.org> Author: ben_graeler Date: 2017-02-08 10:10:02 +0100 (Wed, 08 Feb 2017) New Revision: 163 Modified: pkg/DESCRIPTION pkg/R/spVineCopula.R pkg/R/stCoVarVineCopula.R pkg/R/stVineCopula.R pkg/tests/Examples/spcopula-Ex.Rout.save Log: remove "estmate.variance" from fitCopula in spVines Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2017-02-07 11:35:01 UTC (rev 162) +++ pkg/DESCRIPTION 2017-02-08 09:10:02 UTC (rev 163) @@ -2,7 +2,7 @@ Type: Package Title: Copula Driven Analysis - Multivariate, Spatial, Spatio-Temporal Version: 0.2-2 -Date: 2017-02-07 +Date: 2017-02-08 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "b.graeler at 52north.org"), person("Marius", "Appel",role = "ctb")) Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2017-02-07 11:35:01 UTC (rev 162) +++ pkg/R/spVineCopula.R 2017-02-08 09:10:02 UTC (rev 163) @@ -131,7 +131,7 @@ loglik <- dCopula(topCop,u0,log=TRUE) } else { cat("[Estimating a",ncol(u0),"dimensional copula at the top.]\n") - vineCopFit <- fitCopula(copula at topCop, u0, method, estimate.variance) + vineCopFit <- fitCopula(copula at topCop, u0, method) spVineCop <- spVineCopula(copula at spCop, vineCopFit at copula) loglik <- vineCopFit at loglik Modified: pkg/R/stCoVarVineCopula.R =================================================================== --- pkg/R/stCoVarVineCopula.R 2017-02-07 11:35:01 UTC (rev 162) +++ pkg/R/stCoVarVineCopula.R 2017-02-08 09:10:02 UTC (rev 163) @@ -110,7 +110,7 @@ # cat("]\n") # # cat("[Estimating a",ncol(u0),"dimensional copula at the top.]\n") -# vineCopFit <- fitCopula(copula at topCop, u0, method, estimate.variance) +# vineCopFit <- fitCopula(copula at topCop, u0, method) # # stVineCop <- stVineCopula(copula at stCop, vineCopFit at copula) # loglik <- vineCopFit at loglik Modified: pkg/R/stVineCopula.R =================================================================== --- pkg/R/stVineCopula.R 2017-02-07 11:35:01 UTC (rev 162) +++ pkg/R/stVineCopula.R 2017-02-08 09:10:02 UTC (rev 163) @@ -95,7 +95,7 @@ cat("]\n") cat("[Estimating a",ncol(u0),"dimensional copula at the top.]\n") - vineCopFit <- fitCopula(copula at topCop, u0, method, estimate.variance) + vineCopFit <- fitCopula(copula at topCop, u0, method) stVineCop <- stVineCopula(copula at stCop, vineCopFit at copula) loglik <- vineCopFit at loglik Modified: pkg/tests/Examples/spcopula-Ex.Rout.save =================================================================== --- pkg/tests/Examples/spcopula-Ex.Rout.save 2017-02-07 11:35:01 UTC (rev 162) +++ pkg/tests/Examples/spcopula-Ex.Rout.save 2017-02-08 09:10:02 UTC (rev 163) @@ -19,18 +19,6 @@ > source(file.path(R.home("share"), "R", "examples-header.R")) > options(warn = 1) > options(pager = "console") -> base::assign(".ExTimings", "spcopula-Ex.timings", pos = 'CheckExEnv') -> base::cat("name\tuser\tsystem\telapsed\n", file=base::get(".ExTimings", pos = 'CheckExEnv')) -> base::assign(".format_ptime", -+ function(x) { -+ if(!is.na(x[4L])) x[1L] <- x[1L] + x[4L] -+ if(!is.na(x[5L])) x[2L] <- x[2L] + x[5L] -+ options(OutDec = '.') -+ format(x[1L:3L], digits = 7L) -+ }, -+ pos = 'CheckExEnv') -> -> ### * > library('spcopula') Loading required package: copula Loading required package: VineCopula @@ -42,7 +30,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EU_RB > ### Title: Daily mean PM10 concentrations over Europe in June and July 2005 > ### Aliases: EU_RB @@ -82,15 +69,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("EU_RB", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("EU_RB_2005") > ### * EU_RB_2005 > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: EU_RB_2005 > ### Title: Daily mean PM10 concentrations over Europe in 2005 as used in > ### the JSS manuscript @@ -139,15 +123,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("EU_RB_2005", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("asCopula-class") > ### * asCopula-class > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: asCopula-class > ### Title: Class '"asCopula"' > ### Aliases: asCopula-class dduCopula,matrix,asCopula-method @@ -177,15 +158,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("asCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("asCopula") > ### * asCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: asCopula > ### Title: Constructor of an asymmetric copula with cubic and quadratic > ### sections (Nelsen 2006). @@ -226,8 +204,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("asCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > graphics::par(get("par.postscript", pos = 'CheckExEnv')) > cleanEx() > nameEx("bivTailDepFun") @@ -235,7 +211,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: bivJointDepFun > ### Title: Bivariate joint dependence functions > ### Aliases: bivJointDepFun lowerBivJointDepFun upperBivJointDepFun @@ -271,15 +246,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("bivTailDepFun", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("calcBins") > ### * calcBins > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: calcBins > ### Title: A function calculating the spatial/spatio-temporal bins > ### Aliases: calcBins calcBins-methods calcBins,Spatial-method @@ -298,8 +270,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("calcBins", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -309,7 +279,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: composeSpCopula > ### Title: Composing a bivariate Spatial Copula > ### Aliases: composeSpCopula @@ -329,15 +298,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("composeSpCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("condCovariate") > ### * condCovariate > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: condCovariate > ### Title: Conditioning of a Covariate > ### Aliases: condCovariate @@ -366,8 +332,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("condCovariate", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:spacetime', 'package:sp' @@ -377,7 +341,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: condSpVine > ### Title: Conditions a spatial vine copula for conditional prediction > ### Aliases: condSpVine @@ -427,15 +390,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("condSpVine", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("condStCoVarVine") > ### * condStCoVarVine > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: condStCoVarVine > ### Title: conditional distribution function of spatio-temporal covariate > ### vine copula @@ -473,15 +433,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("condStCoVarVine", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("condStVine") > ### * condStVine > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: condStVine > ### Title: Conditions a spatio-temporal vine copula for conditional > ### prediction @@ -517,15 +474,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("condStVine", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("cqsCopula-class") > ### * cqsCopula-class > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: cqsCopula-class > ### Title: Class '"cqsCopula"' > ### Aliases: cqsCopula-class dduCopula,matrix,cqsCopula-method @@ -555,15 +509,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("cqsCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("cqsCopula") > ### * cqsCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: cqsCopula > ### Title: Constructor of a symmetric copula with cubic quadratic sections. > ### Aliases: cqsCopula @@ -603,8 +554,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("cqsCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > graphics::par(get("par.postscript", pos = 'CheckExEnv')) > cleanEx() > nameEx("criticalLevel") @@ -612,7 +561,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: criticalLevel > ### Title: Calculating the critical level for a given Kendall Return Period > ### Aliases: criticalLevel @@ -625,15 +573,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("criticalLevel", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("criticalPair") > ### * criticalPair > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: criticalPair > ### Title: Calculate Critical Pairs > ### Aliases: criticalPair @@ -647,15 +592,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("criticalPair", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("criticalTriple") > ### * criticalTriple > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: criticalTriple > ### Title: calculate critical triples > ### Aliases: criticalTriple @@ -672,15 +614,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("criticalTriple", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("dduCopula") > ### * dduCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: dduCopula > ### Title: partial derivatives of copulas > ### Aliases: dduCopula ddvCopula @@ -718,15 +657,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("dduCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("dependencePlot") > ### * dependencePlot > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: dependencePlot > ### Title: Kernel smoothed scatter plot > ### Aliases: dependencePlot @@ -738,15 +674,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("dependencePlot", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("empSurCopula-class") > ### * empSurCopula-class > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: empSurCopula-class > ### Title: Class '"empiricalCopula"' > ### Aliases: empSurCopula-class @@ -772,15 +705,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("empSurCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("empSurCopula") > ### * empSurCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: empSurCopula > ### Title: Constructor of an empirical survival copula class > ### Aliases: empSurCopula @@ -832,15 +762,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("empSurCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("empiricalCopula-class") > ### * empiricalCopula-class > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: empiricalCopula-class > ### Title: Class '"empiricalCopula"' > ### Aliases: empiricalCopula-class @@ -866,15 +793,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("empiricalCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("empiricalCopula") > ### * empiricalCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: empiricalCopula > ### Title: Constructor of an empirical copula class > ### Aliases: empiricalCopula @@ -926,15 +850,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("empiricalCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("fitCorFun") > ### * fitCorFun > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: fitCorFun > ### Title: Automated fitting of a correlation function to the correlogram > ### Aliases: fitCorFun @@ -980,15 +901,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("fitCorFun", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("fitSpCopula") > ### * fitSpCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: fitSpCopula > ### Title: Spatial Copula Fitting > ### Aliases: fitSpCopula @@ -1155,8 +1073,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("fitSpCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -1166,7 +1082,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: genEmpCop > ### Title: Generate an empirical copula > ### Aliases: genEmpCop genEmpSurCop @@ -1187,15 +1102,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("genEmpCop", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("genEmpKenFun") > ### * genEmpKenFun > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: genEmpKenFun > ### Title: Generates an empirical Kendall distribution function > ### Aliases: genEmpKenFun @@ -1209,15 +1121,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("genEmpKenFun", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("genInvKenFun") > ### * genInvKenFun > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: genInvKenFun > ### Title: Generate the inverse Kendall distribution function > ### Aliases: genInvKenFun @@ -1235,15 +1144,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("genInvKenFun", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("getKendallDistr") > ### * getKendallDistr > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: getKendallDistr > ### Title: Retrieving the Kendall Distribution function for a given copula > ### Aliases: getKendallDistr getKendallDistr,claytonCopula-method @@ -1261,15 +1167,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("getKendallDistr", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("getNeighbours") > ### * getNeighbours > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: getNeighbours > ### Title: Creating Local Neighbourhoods > ### Aliases: getNeighbours @@ -1288,8 +1191,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("getNeighbours", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -1299,7 +1200,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: getStNeighbours > ### Title: Creating Local Spatio-Temporal Neighbourhoods > ### Aliases: getStNeighbours @@ -1326,8 +1226,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("getStNeighbours", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:spacetime', 'package:sp' @@ -1337,7 +1235,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: hkCopula-class > ### Title: Class '"hkCopula"' > ### Aliases: hkCopula-class @@ -1363,15 +1260,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("hkCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("hkCopula") > ### * hkCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: hkCopula > ### Title: Constructor of a hierarchical Kendall copula > ### Aliases: hkCopula @@ -1417,15 +1311,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("hkCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("kendallDistribution") > ### * kendallDistribution > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: kendallDistribution > ### Title: The Kendall distribution > ### Aliases: kendallDistribution kendallDistribution,claytonCopula-method @@ -1444,15 +1335,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("kendallDistribution", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("kendallRP") > ### * kendallRP > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: kendallRP > ### Title: calculating the Kendall Return Period > ### Aliases: kendallRP @@ -1465,15 +1353,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("kendallRP", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("loglikByCopulasLags") > ### * loglikByCopulasLags > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: loglikByCopulasLags > ### Title: Log-likelihoods by copula family and spatial lag class > ### Aliases: loglikByCopulasLags @@ -1641,8 +1526,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("loglikByCopulasLags", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -1652,7 +1535,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: loglikByCopulasStLags > ### Title: Log-likelihoods by copula family and spatio-temporal lag class > ### Aliases: loglikByCopulasStLags @@ -1820,8 +1702,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("loglikByCopulasStLags", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -1831,7 +1711,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: mixtureCopula-class > ### Title: Class '"mixtureCopula"' > ### Aliases: mixtureCopula-class dduCopula,ANY,mixtureCopula-method @@ -1860,15 +1739,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("mixtureCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("mixtureCopula") > ### * mixtureCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: mixtureCopula > ### Title: Constructor of a mixture copula > ### Aliases: mixtureCopula @@ -1908,8 +1784,6 @@ > curve(kenCop, main="Kendall function", asp=1) > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("mixtureCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > graphics::par(get("par.postscript", pos = 'CheckExEnv')) > cleanEx() > nameEx("neighbourhood-class") @@ -1917,7 +1791,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: neighbourhood-class > ### Title: Class 'neighbourhood' > ### Aliases: neighbourhood-class names,neighbourhood-method @@ -1937,8 +1810,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("neighbourhood-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -1948,7 +1819,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: neighbourhood > ### Title: Constructor of the 'neighbourhood' class. > ### Aliases: neighbourhood @@ -1975,8 +1845,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("neighbourhood", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -1986,7 +1854,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: qCopula_u > ### Title: The inverse of a bivariate copula given u or v > ### Aliases: qCopula_u qCopula_u,copula-method qCopula_v @@ -2007,15 +1874,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("qCopula_u", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("rCopula_y") > ### * rCopula_y > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: rCopula_y > ### Title: Sampling from a given contour level > ### Aliases: rCopula_y rCopula_y-methods rCopula_y,ANY-method @@ -2029,15 +1893,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("rCopula_y", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("rankTransform") > ### * rankTransform > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: rankTransform > ### Title: rank order transformation of margins > ### Aliases: rankTransform @@ -2054,15 +1915,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("rankTransform", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("reduceNeighbours") > ### * reduceNeighbours > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: reduceNeighbours > ### Title: Selecting the strongest correlated neighbours > ### Aliases: reduceNeighbours @@ -2108,8 +1966,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("reduceNeighbours", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:spacetime', 'package:sp' @@ -2119,7 +1975,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: simulatedTriples > ### Title: annual extreme rainfall triples > ### Aliases: triples @@ -2136,15 +1991,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("simulatedTriples", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("spCopDemo") > ### * spCopDemo > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: spCopDemo > ### Title: workspace produced in 'demo(spCopula)' > ### Aliases: lokliktau bestFitTau bins calcKTauLin calcKTauPol dataSet @@ -2159,15 +2011,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("spCopDemo", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("spCopPredict") > ### * spCopPredict > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: spCopPredict > ### Title: spatial prediction based on a spatial vine copula > ### Aliases: spCopPredict @@ -2258,8 +2107,6 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("spCopPredict", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() detaching 'package:sp' @@ -2269,7 +2116,6 @@ > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: spCopula-class > ### Title: Class '"spCopula"' > ### Aliases: spCopula-class dduCopula,matrix,spCopula-method @@ -2316,15 +2162,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("spCopula-class", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("spCopula") > ### * spCopula > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: spCopula > ### Title: Spatial Copula > ### Aliases: spCopula @@ -2358,15 +2201,12 @@ > > > -> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") -> base::cat("spCopula", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("spGaussCopPredict") > ### * spGaussCopPredict > > flush(stderr()); flush(stdout()) > -> base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: spGaussCopPredict > ### Title: spatial prediction using a Gaussian Copula [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 163 From noreply at r-forge.r-project.org Tue Feb 28 14:45:36 2017 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 28 Feb 2017 14:45:36 +0100 (CET) Subject: [spcopula-commits] r164 - in pkg: . R man tests/Examples Message-ID: <20170228134537.0A8EE186513@r-forge.r-project.org> Author: ben_graeler Date: 2017-02-28 14:45:36 +0100 (Tue, 28 Feb 2017) New Revision: 164 Added: pkg/R/trunCopula.R pkg/man/trunCopula-class.Rd pkg/man/trunCopula.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/hkCopula.R pkg/R/returnPeriods.R pkg/man/asCopula-class.Rd pkg/man/cqsCopula-class.Rd pkg/man/mixtureCopula-class.Rd pkg/man/spVineCopula-class.Rd pkg/man/stVineCopula-class.Rd pkg/tests/Examples/spcopula-Ex.Rout.save Log: - adds truncated copula Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/DESCRIPTION 2017-02-28 13:45:36 UTC (rev 164) @@ -1,8 +1,8 @@ Package: spcopula Type: Package Title: Copula Driven Analysis - Multivariate, Spatial, Spatio-Temporal -Version: 0.2-2 -Date: 2017-02-08 +Version: 0.2-4 +Date: 2017-02-28 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "b.graeler at 52north.org"), person("Marius", "Appel",role = "ctb")) @@ -36,4 +36,5 @@ tailDependenceFunctions.R KendallDistribution.R hkCopula.R + trunCopula.R zzz.R Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/NAMESPACE 2017-02-28 13:45:36 UTC (rev 164) @@ -47,6 +47,7 @@ export(empiricalCopula, genEmpCop, empSurCopula, genEmpSurCop) export(mixtureCopula) export(hkCopula) +export(trunCopula) # general functions export(rankTransform, dependencePlot, unitScatter, univScatter) @@ -84,4 +85,5 @@ exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) exportClasses(stCoVarVineCopula) exportClasses(mixtureCopula) -exportClasses(hkCopula) \ No newline at end of file +exportClasses(hkCopula) +exportClasses(trunCopula) \ No newline at end of file Modified: pkg/R/hkCopula.R =================================================================== --- pkg/R/hkCopula.R 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/R/hkCopula.R 2017-02-28 13:45:36 UTC (rev 164) @@ -159,11 +159,6 @@ smpl[boolLower,] <- qCopula_u(copula, rep(y, sum(boolLower)), appConPoint[boolLower, 1]) smpl[!boolLower,] <- qCopula_v(copula, rep(y, sum(!boolLower)), appConPoint[!boolLower, 2]) } - - # plot(uv, type="l", xlim=c(uv[dSeqInt+c(0,1)]+c(-1,1)/1000), asp=1) - # points(uv[dSeqInt+c(0,1),], col=c("red", "purple")) - # points(matrix(appConPoint, nrow = 1), col="green") - # points(matrix(smpl, nrow = 1), col="green", pch=2) } return(smpl) Modified: pkg/R/returnPeriods.R =================================================================== --- pkg/R/returnPeriods.R 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/R/returnPeriods.R 2017-02-28 13:45:36 UTC (rev 164) @@ -99,72 +99,77 @@ }) } - -setGeneric("qCopula_u",function(copula,p,u,...) {standardGeneric("qCopula_u")}) - -qCopula_u.def <- function(copula,p,u, tol=.Machine$double.eps^.5) { # sample=NULL - dim <- copula at dimension - if(length(p) != length(u)) stop("Length of p and u differ!") +qCopula_u.def <- function(copula, p, u, tol=.Machine$double.eps^.5) { # sample=NULL + copDim <- dim(copula) + stopifnot(length(p) == length(u)) - params <- NULL - for(i in 1:length(p)) { # i <- 1 - if (u[i] < p[i]) { - params <- rbind(params,rep(NA,dim-1)) - } else { - if (dim == 2) { - params <- rbind(params, - optimize(function(v) abs(pCopula(cbind(rep(u[i],length(v)),v),copula)-p[i]), - c(p,1), tol=tol)$minimum) + if (copDim == 2) { + res <- sapply(1:length(p), + function(ind) { + if (u[ind] < p[ind]) + return(NA) + if (u[ind] == 1) + return(p[ind]) + optimise(function(v) abs(pCopula(cbind(u[ind], v), copula) - p[ind]), + c(p[ind], 1 + p[ind] - u[ind]), tol=tol)$minimum + }) + } else { + res < NULL + for(i in 1:length(p)) { # i <- 1 + if (u[i] < p[i]) { + res <- rbind(res, rep(NA,dim-1)) } else { opt <- optim(par=rep(p[i],dim-1), function(vw) abs(pCopula(c(u[i],vw), copula)-p[i]), lower=rep(p[i],dim-1), upper=rep(1,dim-1), method="L-BFGS-B") - params <- rbind(params, opt$par) + res <- rbind(res, opt$par) } } } - return(cbind(u,params)) + return(cbind(u, res)) } +setGeneric("qCopula_u", function(copula, p, u, ...) standardGeneric("qCopula_u")) setMethod("qCopula_u", signature("copula"), qCopula_u.def) -setGeneric("qCopula_v",function(copula,p,v,...) {standardGeneric("qCopula_v")}) - -qCopula_v.def <- function(copula,p,v, tol=.Machine$double.eps^.5) { # sample=NULL - dim <- copula at dimension - if(length(p) != length(v)) stop("Length of p and v differ!") +qCopula_v.def <- function(copula, p, v, tol=.Machine$double.eps^.5) { + copDim <- dim(copula) + if(length(p) != length(v)) + stop("Length of p and u differ!") - params <- NULL - for(i in 1:length(p)) { # i <- 1 - if (v[i] < p[i]) { - params <- rbind(params,rep(NA,dim-1)) - } else { - if (dim == 2) { - params <- rbind(params, - optimize(function(u) abs(pCopula(cbind(u, rep(v[i],length(u))),copula)-p[i]), - c(p,1), tol=tol)$minimum) + if (copDim == 2) { + res <- sapply(1:length(p), + function(ind) { + if (v[ind] < p[ind]) + return(NA) + if (v[ind] == 1) + return(p[ind]) + optimise(function(u) abs(pCopula(cbind(u, v[ind]), copula) - p[ind]), + c(p[ind], 1 + p[ind] - v[ind]), tol=tol)$minimum + }) + res <- cbind(res, v) + } else { + res < NULL + for(i in 1:length(p)) { # i <- 1 + if (v[i] < p[i]) { + res <- rbind(res,rep(NA,dim-1)) } else { opt <- optim(par=rep(p[i],dim-1), - function(uw) abs(pCopula(c(uw[1],v[i],uw[2]), copula)-p[i]), + function(uw) abs(pCopula(c(uw[1], v[i], uw[2]), copula)-p[i]), lower=rep(p[i],dim-1), upper=rep(1,dim-1), method="L-BFGS-B") - params <- rbind(params, opt$par) + res <- rbind(res, opt$par) } } + + res <- cbind(res[,1], v, res[,2]) } - if (dim == 2) { - return(cbind(params,v)) - } else { - if (is.matrix(params)) - return(cbind(params[,1], v, params[,2])) - else - return(cbind(params[1], v, params[2])) - } - + return(res) } +setGeneric("qCopula_v", function(copula, p, v, ...) standardGeneric("qCopula_v")) setMethod("qCopula_v", signature("copula"), qCopula_v.def) Added: pkg/R/trunCopula.R =================================================================== --- pkg/R/trunCopula.R (rev 0) +++ pkg/R/trunCopula.R 2017-02-28 13:45:36 UTC (rev 164) @@ -0,0 +1,295 @@ +## Truncated copulas exhibting a crisp boundary, often induced by lower bounds. +## Points below the boundary are shifted "upwards" onto the boundary. Hence, +## considerable mass is concentrated on the boundary yielding a mixed density +## analougously to mixed discrete continuous distributions in the univariate +## case. + +# class truncated copula +validTrunCop <- function(object) { + if(any(object at trunFamily@parameters != object at parameters[-c(length(object at parameters)-(1:0))])) { + warning("Missmatch of parameters between the parameter slot and the parameter slot of the \"trunFamily\".") + } + + ifelse(object at dimension == 2, TRUE, FALSE) +} + +# Slots: +# +# Name: trunFamily contPar .tools dimension parameters param.names param.lowbnd param.upbnd +# Class: copula numeric list integer numeric character numeric numeric +# +# Name: fullname +# Class: character + +setClass("trunCopula", + list("copula", trunFamily = "copula", contPar = "numeric", .tools = "list"), + validity = validTrunCop, + contains = list("copula")) + +trunCopula <- function(copula, contPar, approx.u=1:1000/1000) { + + # setting helper functions + contFun <- function(x) x^contPar + invContFun <- function(x) x^(1/contPar) + + trunFun <- approxfun(c(0, approx.u), + c(0, qCopula_u(copula, contFun(approx.u), approx.u)[,2])) + + invTrunFun <- approxfun(trunFun(c(0, approx.u)), c(0, approx.u)) + + CDF <- approxfun(c(0, approx.u), + c(0, pCopula(cbind(invTrunFun(approx.u), approx.u), copula))) + invCDF <- approxfun(CDF(c(0, approx.u)), c(0, approx.u)) + + # calculate density along the contour line + dCont <- function(u) { + v <- trunFun(u) + (dduCopula(cbind(u,v), copula) - dduCopula(cbind(u,0), copula)) + } + + new("trunCopula", + dimension = dim(copula), + parameters = c(copula at parameters, contPar), + param.names = c(copula at param.names, "truncation"), + param.lowbnd = c(copula at param.lowbnd, -Inf), + param.upbnd = c(copula at param.upbnd, Inf), + fullname = "truncated copula", + trunFamily = copula, + contPar = contPar, + .tools = list(trunFun = trunFun, + invTrunFun = invTrunFun, + CDF = CDF, + invCDF = invCDF, + contFun = contFun, + invContFun = invContFun, + dCont = dCont)) +} + +## console printing +setMethod("describeCop", c("trunCopula", "character"), + function(x, kind = c("short", "very short", "long"), prefix = "", ...) { + kind <- match.arg(kind) + if(kind == "very short") # e.g. for show() which has more parts + return(paste0(prefix, "truncated copula")) + + name <- paste("truncated", describeCop(x at trunFamily, "very short")) + d <- dim(x) + ch <- paste0(prefix, name, ", dim. d = ", d) + switch(kind <- match.arg(kind), + short = ch, + long = paste0(ch, "\n", prefix, " param.: ", + capture.output(str(x at parameters, + give.head=FALSE))), + stop("invalid 'kind': ", kind)) + }) + +## density + +dTrunCop <- function(u, copula, log=FALSE, ..., tol=1e-3) { + if (log) { + res <- rep(NA, nrow(u)) + } else { + res <- rep(0, nrow(u)) + } + + contVals <- copula at .tools$contFun(u[,1]) + diffContVals <- u[,2] - contVals + + # split in above and on contour + boolAbove <- diffContVals >= tol + boolContour <- abs(diffContVals) < tol + + # shift back + u[,2] <- sapply(u[,2], function(v) copula at .tools$invCDF(v)) + + res[boolAbove] <- dCopula(u[boolAbove,], copula at trunFamily, log, ...) + + if (any(boolContour)) { + res[boolContour] <- copula at .tools$dCont(u[boolContour,1]) + if (log) + res[boolContour] <- log(res[boolContour]) + } + + return(res) +} + +# setMethod(dCopula, c("matrix", "trunCopula"), dTrunCop) +# +# setMethod(dCopula, c("numeric", "trunCopula"), +# function(u, copula, log, ...) { +# dTrunCop(matrix(u, ncol=2), copula, log, ...) +# }) + +## sampling from the trunCopula + +rTrunCop <- function(n, copula, ...) { + smpl <- rCopula(n, copula at trunFamily, ...) + smpl[,2] <- pmax(copula at .tools$CDF(smpl[,2]), + copula at .tools$contFun(smpl[,1])) + + return(smpl) +} + +setMethod(rCopula, c("numeric", "trunCopula"), rTrunCop) + +## CDF of the trunCopula + +pTrunCop <- function(u, copula, ...) { + res <- u[,1] + boolu11 <- u[,1] == 1 + res[boolu11] <- u[boolu11,2] + + boolu21 <- u[,2] == 1 + res[boolu21] <- u[boolu21,1] + + contVals <- copula at .tools$contFun(u[,1]) + boolBelow <- u[,2] < contVals + + u[boolBelow, 1] <- copula at .tools$invContFun(u[boolBelow,2]) + + u[,2] <- copula at .tools$invCDF(u[,2]) + + res[!(boolu11 | boolu21)] <- pCopula(u[!(boolu11 | boolu21),], copula at trunFamily)# , ...) + return(res) +} + +setMethod(pCopula, c("numeric", "trunCopula"), + function(u, copula, ...) pTrunCop(matrix(u, ncol = dim(copula)), copula, ...)) + +setMethod(pCopula, c("matrix", "trunCopula"), pTrunCop) + +### CDF version ### +fitTrunCop <- function(copula, data, ..., method, lower, upper, tol=1e-3) { + if (missing(method)) + method <- ifelse(length(copula at trunFamily@parameters) > 1, "Nelder-Mead", "Brent") + if (missing(lower)) + lower <- ifelse(is.infinite(copula at trunFamily@param.lowbnd), -1e3, copula at trunFamily@param.lowbnd) + if (missing(upper)) + upper <- ifelse(is.infinite(copula at trunFamily@param.upbnd), 1e3, copula at trunFamily@param.upbnd) + + pEmpCop <- pCopula(data, empiricalCopula(data)) + + optFun <- function(par) { + cat(par, "\n") + innerCop <- copula at trunFamily + innerCop at parameters <- par + cop <- trunCopula(innerCop, copula at contPar) + + mae <- mean(abs(pCopula(data, cop) - pEmpCop)) + cat(mae, "\n") + mae + } + + optOut <- optim(copula at trunFamily@parameters, optFun, + method = method, lower = lower, upper = upper, ...) + + innerCop <- copula at trunFamily + innerCop at parameters <- optOut$par + cop <- trunCopula(innerCop, copula at contPar) + + new("fitCopula", + copula=cop, + estimate = c(optOut$par, copula at contPar), + var.est = matrix(NA), + loglik = sum(dCopula(data, cop, log=T, tol=tol)), + nsample = as.integer(nrow(data)), + method = "Copula CDF optimisation with fixed boundary.", + call = match.call(), + fitting.stats = optOut) +} + +setMethod("fitCopula", c("trunCopula", "matrix"), fitTrunCop) + +# ## sample along contour +rTrunCop_y <- function(y, copula, n=1, n.disc = 1000) { + stopifnot(copula at dimension == 2) + n.y <- length(y) + stopifnot(n.y == 1 | n == 1) + + uIntSec <- copula at .tools$invContFun(y) + + smpl <- matrix(NA, n.y*n, 2) + + for (i in 1:n.y) { # i <- 1 i <- i+1 + condVals <- seq(y[i], 1-(1-y[i])/n.disc^2, length.out = n.disc) + uv <- qCopula_v(copula, rep(y[i], n.disc-1), condVals[-1]) + uv <- rbind(uv, qCopula_u(copula, rep(y[i], sum(condVals < uIntSec[i])), + condVals[condVals < uIntSec[i]])) + uv <- uv[order(uv[,1]),] + + dSeq <- cumsum(c(0, apply((uv[-nrow(uv),]-uv[-1,])^2, 1, function (x) sqrt(sum(x))))) + probs <- dTrunCop(uv, copula) + + apFun <- approxfun(dSeq, probs, rule = 2) + probLine <- copula at .tools$dCont(uIntSec[i]) + probCont <- integrate(apFun, 0, max(dSeq))$value + + rContour <- runif(n, 0, probCont + probLine) + + funAppConPoint <- function(rCont) { + invCDFContour <- function(x) { + abs(integrate(apFun, 0, x)$value - rCont) + } + + lContour <- optimise(invCDFContour, c(0, max(dSeq)))$minimum + + dSeqInt <- findInterval(lContour, dSeq) + + lSeq <- sqrt(sum((uv[dSeqInt,]-uv[dSeqInt+1,])^2)) + + uv[dSeqInt,] + (lContour - dSeq[dSeqInt])/lSeq * (uv[dSeqInt+1,]-uv[dSeqInt,]) + } + + if (n == 1) { + if (rContour <= probLine) { + smpl[i,] <- c(uIntSec[i], y[i]) + next; + } + rContour <- rContour - probLine + + appConPoint <- funAppConPoint(rContour) + + if (appConPoint[1] > appConPoint[2]) { + smpl[i,] <- qCopula_u(copula, y[i], appConPoint[1]) + } else { + smpl[i,] <- qCopula_v(copula, y[i], appConPoint[2]) + } + } else { + boolLine <- rContour <= probLine + smpl <- cbind(rep(uIntSec, n), + rep(y, n)) + rContour <- rContour - probLine + smpl[!boolLine,] <- t(sapply(rContour[!boolLine], funAppConPoint)) + + boolLower <- smpl[,1] > smpl[,2] + if (any(boolLower & !boolLine)) + smpl[boolLower & !boolLine,] <- qCopula_u(copula, rep(y[i], sum(boolLower & !boolLine)), + smpl[boolLower & !boolLine, 1]) + if (any(!boolLower & !boolLine)) + smpl[!boolLower & !boolLine,] <- qCopula_v(copula, rep(y[i], sum(!boolLower & !boolLine)), + smpl[!boolLower & !boolLine, 2]) + } + } + + return(smpl) +} + +setMethod(rCopula_y, signature = c("numeric", "trunCopula"), rTrunCop_y) + +## cond inverse + +qTrunCop_v <- function(copula, p, v, tol=.Machine$double.eps^.5) { # sample=NULL + stopifnot(length(p) == length(v)) + + cbind(sapply(1:length(p), + function(ind) { + if (v[ind] < p[ind]) + return(NA) + if (v[ind] == 1) + return(p[ind]) + optimise(function(u) abs(pCopula(cbind(u, v[ind]), copula) - p[ind]), + c(p[ind], copula at .tools$invContFun(v[ind])), tol=tol)$minimum + }), v) +} + +setMethod("qCopula_v", signature = c("trunCopula"), qTrunCop_v) Modified: pkg/man/asCopula-class.Rd =================================================================== --- pkg/man/asCopula-class.Rd 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/man/asCopula-class.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -6,7 +6,7 @@ \alias{dduCopula,numeric,asCopula-method} \alias{ddvCopula,matrix,asCopula-method} \alias{ddvCopula,numeric,asCopula-method} -\alias{fitCopula,asCopula-method} +\alias{fitCopula,asCopula,ANY-method} \alias{invdduCopula,numeric,asCopula,numeric-method} \alias{invddvCopula,numeric,asCopula,numeric-method} Modified: pkg/man/cqsCopula-class.Rd =================================================================== --- pkg/man/cqsCopula-class.Rd 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/man/cqsCopula-class.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -6,7 +6,7 @@ \alias{dduCopula,numeric,cqsCopula-method} \alias{ddvCopula,matrix,cqsCopula-method} \alias{ddvCopula,numeric,cqsCopula-method} -\alias{fitCopula,cqsCopula-method} +\alias{fitCopula,cqsCopula,ANY-method} \alias{invdduCopula,numeric,cqsCopula,numeric-method} \alias{invddvCopula,numeric,cqsCopula,numeric-method} Modified: pkg/man/mixtureCopula-class.Rd =================================================================== --- pkg/man/mixtureCopula-class.Rd 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/man/mixtureCopula-class.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -4,7 +4,7 @@ \alias{mixtureCopula-class} \alias{dduCopula,ANY,mixtureCopula-method} \alias{ddvCopula,ANY,mixtureCopula-method} -\alias{fitCopula,mixtureCopula-method} +\alias{fitCopula,mixtureCopula,ANY-method} \alias{invdduCopula,numeric,mixtureCopula,numeric-method} \alias{invddvCopula,numeric,mixtureCopula,numeric-method} Modified: pkg/man/spVineCopula-class.Rd =================================================================== --- pkg/man/spVineCopula-class.Rd 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/man/spVineCopula-class.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -4,7 +4,7 @@ \alias{spVineCopula-class} \alias{mixedSpVineCopula-class} \alias{pureSpVineCopula-class} -\alias{fitCopula,spVineCopula-method} +\alias{fitCopula,spVineCopula,ANY-method} \title{Class \code{"spVineCopula"}} \description{ Modified: pkg/man/stVineCopula-class.Rd =================================================================== --- pkg/man/stVineCopula-class.Rd 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/man/stVineCopula-class.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -2,7 +2,7 @@ \Rdversion{1.1} \docType{class} \alias{stVineCopula-class} -\alias{fitCopula,stVineCopula-method} +\alias{fitCopula,stVineCopula,ANY-method} \title{Class \code{"stVineCopula"}} \description{ Added: pkg/man/trunCopula-class.Rd =================================================================== --- pkg/man/trunCopula-class.Rd (rev 0) +++ pkg/man/trunCopula-class.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -0,0 +1,49 @@ +\name{trunCopula-class} +\Rdversion{1.1} +\docType{class} +\alias{trunCopula-class} +\alias{fitCopula,trunCopula,matrix-method} +\alias{qCopula_v,trunCopula-method} +\alias{rCopula_y,numeric,trunCopula-method} + +\title{Class \code{"trunCopula"}} +\description{ +A representation of a truncated copula where mass below a truncation boundary is pushed on to the the boundary. +} +\section{Objects from the Class}{ +Objects can be created by calls of the form \code{new("trunCopula", ...)}. Or via the simplified constructor \code{\link{trunCopula}}. +} +\section{Slots}{ + \describe{ + \item{\code{trunFamily}:}{Object of class \code{"copula"} of the underlying continuous copula.} + \item{\code{contPar}:}{Object of class \code{"numeric"} between 1 and infintiy defining the power 'p' of the truncation boundary 'u^p'.} + \item{\code{.tools}:}{Object of class \code{"list"} containing a couple of helper functions that are assigned via the constructor.} + \item{\code{dimension}:}{Object of class \code{"integer"} giving the dimesnion (currently only 2). } + \item{\code{parameters}:}{Object of class \code{"numeric"} representing the continuous copula parameters and the power 'p' as of 'contPar'.} + \item{\code{param.names}:}{Object of class \code{"character"} giving the parameter names. } + \item{\code{param.lowbnd}:}{Object of class \code{"numeric"} giving the parameter lower bounds.} + \item{\code{param.upbnd}:}{Object of class \code{"numeric"} giving the parameter upper bounds.} + \item{\code{fullname}:}{Object of class \code{"character"} . } + } +} +\section{Extends}{ +Class \code{"\linkS4class{copula}"}, directly. +Class \code{"\linkS4class{parCopula}"}, by class "copula", distance 2. +Class \code{"\linkS4class{Copula}"}, by class "copula", distance 3. +} +\section{Methods}{ + \describe{ + \item{fitCopula}{\code{signature(copula = "trunCopula", data = "matrix")}: ... } + \item{qCopula_v}{\code{signature(copula = "trunCopula", p = "numeric", v = "numeric")}: ... } + \item{rCopula_y}{\code{signature(y = "numeric", copula = "trunCopula")}: ... } + } +} +\author{ +Benedikt Graeler +} + +\examples{ +showClass("trunCopula") +} + +\keyword{classes} Added: pkg/man/trunCopula.Rd =================================================================== --- pkg/man/trunCopula.Rd (rev 0) +++ pkg/man/trunCopula.Rd 2017-02-28 13:45:36 UTC (rev 164) @@ -0,0 +1,39 @@ +\name{trunCopula} +\alias{trunCopula} + +\title{ +Constructor of the truncated copula class. +} +\description{ +Returns a class \code{\linkS4class{trunCopula}} representing a truncated copula where mass of a continuous copula is concentrated in the boubndary curve. +} +\usage{ +trunCopula(copula, contPar, approx.u = 1:1000/1000) +} + +\arguments{ + \item{copula}{the underlying continuous copula} + \item{contPar}{The power 'p' of the polynomial boundary 'x^p'.} + \item{approx.u}{a discretisation of the u-axis for numerical approximations} +} +\value{An object of \code{\linkS4class{trunCopula}}} +\author{ +Benedikt Graeler} + +\examples{ + +cop <- trunCopula(gumbelCopula(3), 1.2) +cop + +smpl <- rCopula(100, cop) + +par(mfrow=c(2,2), mai=c(0.4,0.4,0.4,0.4)) +plot(smpl,asp=1, main="sample") + +contour(cop, pCopula, asp=1, main="CDF", n=201) +points(rCopula_y(0.4, cop, 10), col="red") + +# too few points, but faster for package compilation +kenCop <- getKendallDistr(cop, smpl) +curve(kenCop, main="Kendall function", asp=1) +} \ No newline at end of file Modified: pkg/tests/Examples/spcopula-Ex.Rout.save =================================================================== --- pkg/tests/Examples/spcopula-Ex.Rout.save 2017-02-08 09:10:02 UTC (rev 163) +++ pkg/tests/Examples/spcopula-Ex.Rout.save 2017-02-28 13:45:36 UTC (rev 164) @@ -133,7 +133,7 @@ > ### Title: Class '"asCopula"' > ### Aliases: asCopula-class dduCopula,matrix,asCopula-method > ### dduCopula,numeric,asCopula-method ddvCopula,matrix,asCopula-method -> ### ddvCopula,numeric,asCopula-method fitCopula,asCopula-method +> ### ddvCopula,numeric,asCopula-method fitCopula,asCopula,ANY-method > ### invdduCopula,numeric,asCopula,numeric-method > ### invddvCopula,numeric,asCopula,numeric-method > ### Keywords: classes asymmetric copula copula @@ -484,7 +484,7 @@ > ### Title: Class '"cqsCopula"' > ### Aliases: cqsCopula-class dduCopula,matrix,cqsCopula-method > ### dduCopula,numeric,cqsCopula-method ddvCopula,matrix,cqsCopula-method -> ### ddvCopula,numeric,cqsCopula-method fitCopula,cqsCopula-method +> ### ddvCopula,numeric,cqsCopula-method fitCopula,cqsCopula,ANY-method > ### invdduCopula,numeric,cqsCopula,numeric-method > ### invddvCopula,numeric,cqsCopula,numeric-method > ### Keywords: classes copula @@ -1714,7 +1714,7 @@ > ### Name: mixtureCopula-class > ### Title: Class '"mixtureCopula"' > ### Aliases: mixtureCopula-class dduCopula,ANY,mixtureCopula-method -> ### ddvCopula,ANY,mixtureCopula-method fitCopula,mixtureCopula-method +> ### ddvCopula,ANY,mixtureCopula-method fitCopula,mixtureCopula,ANY-method > ### invdduCopula,numeric,mixtureCopula,numeric-method > ### invddvCopula,numeric,mixtureCopula,numeric-method > ### Keywords: classes @@ -1864,13 +1864,13 @@ > > uv <- qCopula_u(asCopula(c(-1,1)), p=rep(0.9,10), u=runif(10,0.9,1)) > pCopula(uv,asCopula(c(-1,1)))-0.9 - [1] -5.285787e-09 -1.979502e-10 7.899040e-09 -5.241861e-09 2.531447e-09 - [6] 8.471355e-09 -6.502292e-09 -1.261782e-09 3.313125e-09 7.337630e-09 + [1] -6.854504e-09 -2.410827e-09 7.820441e-09 4.006534e-09 1.189353e-09 + [6] 7.326577e-09 2.424379e-09 5.285333e-09 -4.919274e-09 -2.558232e-09 > > uv <- qCopula_v(asCopula(c(-1,1)), p=rep(0.9,10), v=runif(10,0.9,1)) > pCopula(uv,asCopula(c(-1,1)))-0.9 - [1] -1.033849e-09 4.513519e-09 8.776860e-09 2.134065e-09 3.399305e-09 - [6] 4.947090e-09 2.469908e-10 4.513539e-09 6.891024e-09 -3.606405e-09 + [1] 1.414896e-08 2.142035e-09 -4.321133e-09 8.461797e-09 -7.768893e-09 + [6] -1.606910e-08 -1.162496e-08 -3.348833e-10 1.726091e-09 -1.168865e-09 > > > @@ -2648,7 +2648,7 @@ > ### Name: spVineCopula-class > ### Title: Class '"spVineCopula"' > ### Aliases: spVineCopula-class mixedSpVineCopula-class -> ### pureSpVineCopula-class fitCopula,spVineCopula-method +> ### pureSpVineCopula-class fitCopula,spVineCopula,ANY-method > ### Keywords: classes > > ### ** Examples @@ -2997,7 +2997,7 @@ > > ### Name: stVineCopula-class > ### Title: Class '"stVineCopula"' -> ### Aliases: stVineCopula-class fitCopula,stVineCopula-method +> ### Aliases: stVineCopula-class fitCopula,stVineCopula,ANY-method > ### Keywords: classes > > ### ** Examples @@ -3118,6 +3118,74 @@ > > > cleanEx() +> nameEx("trunCopula-class") +> ### * trunCopula-class +> +> flush(stderr()); flush(stdout()) +> +> ### Name: trunCopula-class +> ### Title: Class '"trunCopula"' +> ### Aliases: trunCopula-class fitCopula,trunCopula,matrix-method +> ### qCopula_v,trunCopula-method rCopula_y,numeric,trunCopula-method +> ### Keywords: classes +> +> ### ** Examples +> +> showClass("trunCopula") +Class "trunCopula" [package "spcopula"] + +Slots: + +Name: trunFamily contPar .tools dimension parameters +Class: copula numeric list integer numeric + +Name: param.names param.lowbnd param.upbnd fullname +Class: character numeric numeric character + +Extends: +Class "copula", directly +Class "parCopula", by class "copula", distance 2 +Class "Copula", by class "copula", distance 3 +> +> +> +> cleanEx() +> nameEx("trunCopula") +> ### * trunCopula +> +> flush(stderr()); flush(stdout()) +> +> ### Name: trunCopula +> ### Title: Constructor of the truncated copula class. +> ### Aliases: trunCopula +> +> ### ** Examples +> +> +> cop <- trunCopula(gumbelCopula(3), 1.2) +> cop +truncated Gumbel copula, dim. d = 2 +Dimension: 2 +Parameters: + param = 3.0 + truncation = 1.2 +> +> smpl <- rCopula(100, cop) +> +> par(mfrow=c(2,2), mai=c(0.4,0.4,0.4,0.4)) +> plot(smpl,asp=1, main="sample") +> +> contour(cop, pCopula, asp=1, main="CDF", n=201) +> points(rCopula_y(0.4, cop, 10), col="red") +> +> # too few points, but faster for package compilation +> kenCop <- getKendallDistr(cop, smpl) +> curve(kenCop, main="Kendall function", asp=1) +> +> +> +> graphics::par(get("par.postscript", pos = 'CheckExEnv')) +> cleanEx() > nameEx("unitScatter") > ### * unitScatter > @@ -3140,7 +3208,7 @@ > ### > options(digits = 7L) > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n") -Time elapsed: 12.88 0.41 14.08 NA NA +Time elapsed: 13.34 0.31 14.62 NA NA > grDevices::dev.off() null device 1