From noreply at r-forge.r-project.org Thu Sep 1 15:33:20 2016 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 1 Sep 2016 15:33:20 +0200 (CEST) Subject: [spcopula-commits] r156 - in pkg: . R Message-ID: <20160901133321.004C118824A@r-forge.r-project.org> Author: ben_graeler Date: 2016-09-01 15:33:20 +0200 (Thu, 01 Sep 2016) New Revision: 156 Added: pkg/R/mixtureCopula.R Modified: pkg/DESCRIPTION pkg/R/asCopula.R pkg/R/cqsCopula.R pkg/R/empiricalCopula.R pkg/R/tawn3pCopula.R Log: adds mixtureCopula Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2016-08-30 07:33:12 UTC (rev 155) +++ pkg/DESCRIPTION 2016-09-01 13:33:20 UTC (rev 156) @@ -2,7 +2,7 @@ Type: Package Title: Copula Driven Spatio-Temporal Analysis Version: 0.2-1 -Date: 2016-08-30 +Date: 2016-09-01 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) @@ -21,6 +21,7 @@ cqsCopula.R asCopula.R leafCopula.R + mixtureCopula.R spCopula.R stCopula.R spatialPreparation.R Modified: pkg/R/asCopula.R =================================================================== --- pkg/R/asCopula.R 2016-08-30 07:33:12 UTC (rev 155) +++ pkg/R/asCopula.R 2016-09-01 13:33:20 UTC (rev 156) @@ -307,4 +307,7 @@ return((a+3*b)/12) } -setMethod("rho",signature("asCopula"), rhoASC2) \ No newline at end of file +setMethod("rho", signature("asCopula"), rhoASC2) + +setMethod("lambda", signature("asCopula"), + function(copula, ...) c(lower = 0, upper = 0)) \ No newline at end of file Modified: pkg/R/cqsCopula.R =================================================================== --- pkg/R/cqsCopula.R 2016-08-30 07:33:12 UTC (rev 155) +++ pkg/R/cqsCopula.R 2016-09-01 13:33:20 UTC (rev 156) @@ -416,4 +416,7 @@ return( -(a+3*b)/12 ) } -setMethod("rho",signature("cqsCopula"),rhoCQSec) \ No newline at end of file +setMethod("rho",signature("cqsCopula"),rhoCQSec) + +setMethod("lambda", signature("cqsCopula"), + function(copula, ...) c(lower = 0, upper = 0)) \ No newline at end of file Modified: pkg/R/empiricalCopula.R =================================================================== --- pkg/R/empiricalCopula.R 2016-08-30 07:33:12 UTC (rev 155) +++ pkg/R/empiricalCopula.R 2016-09-01 13:33:20 UTC (rev 156) @@ -26,7 +26,7 @@ # simplified constructor genEmpCop <- function(copula, sample.size=1e5) { cat("Note: the copula will be empirically represented by a sample of size:", sample.size, "\n") - empiricalCopula(rCopula(sample.size,copula), copula) + empiricalCopula(rCopula(sample.size, copula), copula) } @@ -35,10 +35,6 @@ ## jcdf ## # from package copula pempCop.C <- function(u, copula) { - # r-forge hack, to be removed after release of copula 0.999-6 - if(exists("C.n")) { - return(C.n(u, copula at sample, offset=0, method="C")) - } else return(Cn(copula at sample,u)) } @@ -53,17 +49,19 @@ TauMatrix(copula at sample)[1,2] } -setMethod("tau",signature("asCopula"),tauempCop) +setMethod("tau",signature("empiricalCopula"), tauempCop) rhoempCop <- function(copula){ cor(copula at sample,method="spearman") } -setMethod("rho",signature("asCopula"),rhoempCop) +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 +# Vine Copula - empirical evaluation ## jcdf ## pvineCopula <- function(u, copula) { empCop <- genEmpCop(copula, 1e5) @@ -72,9 +70,9 @@ } setMethod("pCopula", signature("numeric","vineCopula"), - function(u,copula) { - pvineCopula(matrix(u, ncol=copula at dimension),copula) + function(u, copula) { + pvineCopula(matrix(u, ncol=copula at dimension), copula) }) setMethod("pCopula", signature("data.frame","vineCopula"), - function(u,copula) pvineCopula(as.matrix(u),copula)) -setMethod("pCopula", signature("matrix","vineCopula"), pvineCopula) + function(u, copula) pvineCopula(as.matrix(u), copula)) +setMethod("pCopula", signature("matrix","vineCopula"), pvineCopula) \ No newline at end of file Added: pkg/R/mixtureCopula.R =================================================================== --- pkg/R/mixtureCopula.R (rev 0) +++ pkg/R/mixtureCopula.R 2016-09-01 13:33:20 UTC (rev 156) @@ -0,0 +1,166 @@ +############################## +## ## +## a general mixture copula ## +## ## +############################## + +# class +setClass("mixtureCopula", contains = "copula", slots = list(memberCops= "list")) + +# constructor +mixtureCopula <- function (param = c(0.2, 0.2, 0.5), memberCops = c(normalCopula(), claytonCopula())) { + stopifnot(length(memberCops) == 2) + stopifnot(memberCops[[1]]@dimension == memberCops[[2]]@dimension) + + cop1.nPar <- length(memberCops[[1]]@parameters) + cop2.nPar <- length(memberCops[[2]]@parameters) + + if (missing(param)) + param <- 0.5 + if (length(param) == 1) + param <- c(memberCops[[1]]@parameters, memberCops[[2]]@parameters, 0.5) + else { + stopifnot(length(param) == cop1.nPar + cop2.nPar + 1) + + memberCops[[1]]@parameters <- param[1:cop1.nPar] + memberCops[[2]]@parameters <- param[(1:cop2.nPar)+cop1.nPar] + } + + new("mixtureCopula", dimension = memberCops[[1]]@dimension, parameters = param, memberCops = memberCops, + 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)) +} + +## density ## +setMethod("dCopula", signature(copula = "mixtureCopula"), + function(u, copula, log, ...) { + mixLambda <- tail(copula at parameters, 1) + res <- (1-mixLambda) * dCopula(u, copula at memberCops[[1]], ...) + mixLambda * dCopula(u, copula at memberCops[[2]], ...) + if (log) + return(log(res)) + else + return(res) + }) + +## jcdf ## +setMethod("pCopula", signature( copula = "mixtureCopula"), + function(u, copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * pCopula(u, copula at memberCops[[1]]) + mixLambda * pCopula(u, copula at memberCops[[2]]) + }) + +## partial derivatives ## +## ddu + +setMethod("dduCopula", signature(copula = "mixtureCopula"), + function(u, copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * dduCopula(u, copula at memberCops[[1]]) + mixLambda * dduCopula(u, copula at memberCops[[2]]) + }) + +# ddv +setMethod("ddvCopula", signature(copula = "mixtureCopula"), + function(u, copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * ddvCopula(u, copula at memberCops[[1]]) + mixLambda * ddvCopula(u, copula at memberCops[[2]]) + }) + +## inverse partial derivative +# 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) +} + +setMethod("invdduCopula", + signature("numeric", "mixtureCopula", "numeric"), + invdduMixCop) + +# invddv +invddvMixCop <- function (v, copula, y) { + stopifnot(length(v) == length(y)) + + opti <- function(ind) { + optFun <- function(u) { + (dduCopula(cbind(u, v[ind]), copula) - y[ind])^2 + } + optimise(optFun, c(0,1))$minimum + } + + sapply(1:length(y), opti) +} + +setMethod("invddvCopula", + signature("numeric", "mixtureCopula", "numeric"), + invddvMixCop) + +## random number generator + +rMixCop <- function(n, copula, ...) { + u <- runif(n) + y <- runif(n) + + cbind(u, invdduCopula(u, copula, y)) +} + +setMethod("rCopula", signature(copula = "mixtureCopula"), rMixCop) + +## fitment +fitMixCop <- function(copula, data, start, method="mpl", + lower = NULL, upper = NULL, + optim.method = "BFGS", optim.control = list(maxit = 1000), + estimate.variance = FALSE, ...){ + if (missing(start)) + start <- copula at parameters + stopifnot(method %in% c("ml", "mpl")) + + if(is.null(lower)) + lower <- copula at param.lowbnd + if(is.null(upper)) + upper <- copula at param.lowbnd + + copula:::fitCopula.ml(copula, data, start = start, method = method, + lower = lower, upper = upper, + optim.method = optim.method, + optim.control = optim.control, + estimate.variance = estimate.variance , ...) +} + +setMethod(fitCopula, + signature = c(copula = "mixtureCopula"), + fitMixCop) + +mixCop <- mixtureCopula(c(0.2,0.5,0.3)) +fitCopula(mixCop, rCopula(300, mixCop)) + +fitMixCop(mixCop, rCopula(300, mixCop)) + +# +# 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) { +# 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), +# stop("Implemented methods for copulas in the spCopula package are: ml, itau, and irho.")) +# return(fit) +# } +# +# setMethod("fitCopula", signature("asCopula"), fitCopulaASC2) + +# setMethod("tau",signature("asCopula"),tauASC2) +# setMethod("rho", signature("asCopula"), rhoASC2) +# setMethod("lambda", signature("asCopula"), +# function(copula, ...) c(lower = 0, upper = 0)) \ No newline at end of file Modified: pkg/R/tawn3pCopula.R =================================================================== --- pkg/R/tawn3pCopula.R 2016-08-30 07:33:12 UTC (rev 155) +++ pkg/R/tawn3pCopula.R 2016-09-01 13:33:20 UTC (rev 156) @@ -1,109 +1,144 @@ -####################################### -## tawn copula with all 3 parameters ## -####################################### - -setClass("tawn3pCopula", representation(exprdist = "expression"), - contains = "evCopula") - -Atawn3p <- function(t, param = c(0.9302082, 1, 8.355008)) { - alpha <- param[1] - beta <- param[2] - theta <- param[3] - (1-beta)*(t) + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta) - -} - -ATawn <- function(copula, w) { - Atawn3p(w,copula at parameters) -} - -setMethod("A",signature("tawn3pCopula"),ATawn) - -dAduTawn <- function(copula, w) { - alpha <- copula at parameters[1] - beta <- copula at parameters[2] - theta <- copula at parameters[3] - - # 1st derivative - p1 <- (alpha*(alpha*(-(w-1)))^(theta-1)-beta*(beta*w)^(theta-1)) - p2 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-1) - - # 2nd derivative - p3 <- (alpha*(-(w-1)))^(theta-2) - p4 <- (beta*w)^(theta-2) - p5 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-2) - - data.frame(der1=alpha-beta-p1*p2, - der2=alpha^2*beta^2*(theta-1)*p3*p4*p5) -} - -setMethod("dAdu",signature("tawn3pCopula"),dAduTawn) - -tawn3pCopula <- function (param = c(0.5, 0.5, 2)) { - # A(t) = (1-beta)*t + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta) - # C(u1,u2) = exp(log(u1*u2) * A(log(u2)/log(u1*u2))) - # = u1*u2 + exp(A(log(u2)/log(u1*u2))) - - cdf <- expression(exp(log(u1*u2)*((1-beta)*(log(u2)/log(u1*u2)) + - (1-alpha)*(1-log(u2)/log(u1*u2)) + - ((alpha*(1-log(u2)/log(u1*u2)))^theta+(beta*log(u2)/log(u1*u2))^theta)^(1/theta)))) - dCdU1 <- D(cdf, "u1") - pdf <- D(dCdU1, "u2") - - new("tawn3pCopula", dimension = 2L, exprdist = c(cdf = cdf, pdf = pdf), - parameters = param, param.names = c("alpha", "beta", "theta"), - param.lowbnd = c(0,0,1), param.upbnd = c(1,1,Inf), - fullname = "Tawn copula family with three parameters; Extreme value copula") -} - -dtawn3pCopula <- function(u, copula, log=FALSE, ...) { - dim <- copula at dimension - for (i in 1:dim) { - assign(paste("u", i, sep=""), u[,i]) - } - alpha <- copula at parameters[1] - beta <- copula at parameters[2] - theta <- copula at parameters[3] - - val <- c(eval(copula at exprdist$pdf)) - ## improve log-case - if(log) - log(val) - else - val -} - -setMethod("dCopula", signature("matrix", "tawn3pCopula"), dtawn3pCopula) -setMethod("dCopula", signature("numeric", "tawn3pCopula"),dtawn3pCopula) - -ptawn3pCopula <- function(u, copula, ...) { - dim <- copula at dimension - for (i in 1:dim) { - assign(paste("u", i, sep=""), u[,i]) - } - alpha <- copula at parameters[1] - beta <- copula at parameters[2] - theta <-copula at parameters[3] - - val <- c(eval(copula at exprdist$cdf)) -} - -setMethod("pCopula", signature("matrix", "tawn3pCopula"), ptawn3pCopula) -setMethod("pCopula", signature("numeric", "tawn3pCopula"), ptawn3pCopula) - - -fitTawn3pCop <- function(copula, data, method = c("mpl", "ml", "itau", "irho"), - start = copula at parameters, - lower = copula at param.lowbnd, - upper = copula at param.upbnd, - optim.method = "L-BFGS-B", - optim.control = list(maxit = 1000), estimate.variance = FALSE, - hideWarnings = TRUE) { - - fitCopulaAny <- selectMethod(fitCopula, "copula") - fitCopulaAny(copula, data, method, start, lower, upper, - optim.method, optim.control, estimate.variance, - hideWarnings) -} - +####################################### +## tawn copula with all 3 parameters ## +####################################### + +setClass("tawn3pCopula", representation(exprdist = "expression"), + contains = "evCopula") + +Atawn3p <- function(t, param = c(0.9302082, 1, 8.355008)) { + alpha <- param[1] + beta <- param[2] + theta <- param[3] + (1-beta)*(t) + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta) + +} + +ATawn <- function(copula, w) { + Atawn3p(w, copula at parameters) +} + +setMethod("A", signature("tawn3pCopula"), ATawn) + +dAduTawn <- function(copula, w) { + alpha <- copula at parameters[1] + beta <- copula at parameters[2] + theta <- copula at parameters[3] + + # 1st derivative + p1 <- (alpha*(alpha*(-(w-1)))^(theta-1)-beta*(beta*w)^(theta-1)) + p2 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-1) + + # 2nd derivative + p3 <- (alpha*(-(w-1)))^(theta-2) + p4 <- (beta*w)^(theta-2) + p5 <- ((alpha*(-(w-1)))^theta+(beta*w)^theta)^(1/theta-2) + + data.frame(der1=alpha-beta-p1*p2, + der2=alpha^2*beta^2*(theta-1)*p3*p4*p5) +} + +setMethod("dAdu", signature("tawn3pCopula"), dAduTawn) + +tawn3pCopula <- function (param = c(0.5, 0.5, 2)) { + # A(t) = (1-beta)*t + (1-alpha)*(1-t) + ((alpha*(1-t))^theta+(beta*t)^theta)^(1/theta) + # C(u1,u2) = exp(log(u1*u2) * A(log(u2)/log(u1*u2))) + # = u1*u2 + exp(A(log(u2)/log(u1*u2))) + + cdf <- expression(exp(log(u1*u2)*((1-beta)*(log(u2)/log(u1*u2)) + + (1-alpha)*(1-log(u2)/log(u1*u2)) + + ((alpha*(1-log(u2)/log(u1*u2)))^theta+(beta*log(u2)/log(u1*u2))^theta)^(1/theta)))) + dCdU1 <- D(cdf, "u1") + dCdU2 <- D(cdf, "u2") + pdf <- D(dCdU1, "u2") + + new("tawn3pCopula", dimension = 2L, exprdist = c(cdf = cdf, pdf = pdf, + dCdU = dCdU1, dCdV = dCdU2), + parameters = param, param.names = c("alpha", "beta", "theta"), + param.lowbnd = c(0,0,1), param.upbnd = c(1,1,Inf), + fullname = "Tawn copula family with three parameters; Extreme value copula") +} + +dtawn3pCopula <- function(u, copula, log=FALSE, ...) { + dim <- copula at dimension + for (i in 1:dim) { + assign(paste("u", i, sep=""), u[,i]) + } + alpha <- copula at parameters[1] + beta <- copula at parameters[2] + theta <- copula at parameters[3] + + val <- c(eval(copula at exprdist$pdf)) + ## improve log-case + if(log) + return(log(val)) + else + val +} + +setMethod("dCopula", signature(copula = "tawn3pCopula"), dtawn3pCopula) + +ptawn3pCopula <- function(u, copula, ...) { + dim <- copula at dimension + for (i in 1:dim) { + assign(paste("u", i, sep=""), u[,i]) + } + alpha <- copula at parameters[1] + beta <- copula at parameters[2] + theta <-copula at parameters[3] + + val <- c(eval(copula at exprdist$cdf)) +} + +setMethod("pCopula", signature(copula = "tawn3pCopula"), ptawn3pCopula) + +# partial derivatives + +ddutawn3pCopula <- function(u, copula, ...) { + dim <- copula at dimension + for (i in 1:dim) { + assign(paste("u", i, sep=""), u[,i]) + } + + alpha <- copula at parameters[1] + beta <- copula at parameters[2] + theta <- copula at parameters[3] + + return(eval(copula at exprdist$dCdU)) +} + +setMethod("dduCopula", signature(copula = "tawn3pCopula"), ddutawn3pCopula) + +ddvtawn3pCopula <- function(u, copula, ...) { + dim <- copula at dimension + for (i in 1:dim) { + assign(paste("u", i, sep=""), u[,i]) + } + + alpha <- copula at parameters[1] + beta <- copula at parameters[2] + theta <- copula at parameters[3] + + return(eval(copula at exprdist$dCdV)) +} + +setMethod("ddvCopula", signature(copula = "tawn3pCopula"), ddvtawn3pCopula) + +# tawn3pCop <- tawn3pCopula() +# dduCopula(cbind(runif(10), runif(10)), tawn3pCop) +## fit + +fitTawn3pCop <- function(copula, data, method = c("mpl", "ml"), + start = copula at parameters, + lower = copula at param.lowbnd, + upper = copula at param.upbnd, + optim.method = "L-BFGS-B", + optim.control = list(maxit = 1000), estimate.variance = FALSE, + hideWarnings = TRUE) { + + fitCopulaAny <- selectMethod(fitCopula, "copula") + fitCopulaAny(copula, data, method, start, lower, upper, + optim.method, optim.control, estimate.variance, + hideWarnings) +} + setMethod("fitCopula", signature("tawn3pCopula"), fitTawn3pCop) \ No newline at end of file From noreply at r-forge.r-project.org Thu Sep 1 20:17:15 2016 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 1 Sep 2016 20:17:15 +0200 (CEST) Subject: [spcopula-commits] r157 - / pkg/R Message-ID: <20160901181715.DD52C186A47@r-forge.r-project.org> Author: ben_graeler Date: 2016-09-01 20:17:13 +0200 (Thu, 01 Sep 2016) New Revision: 157 Modified: .Rprofile pkg/R/mixtureCopula.R Log: fixes fitCopula for mixtureCopula.R Modified: .Rprofile =================================================================== --- .Rprofile 2016-09-01 13:33:20 UTC (rev 156) +++ .Rprofile 2016-09-01 18:17:13 UTC (rev 157) @@ -1 +1 @@ -options(repos = c(CRAN="http://cran.uni-muenster.de")) +options(repos = c(CRAN="https://cran.uni-muenster.de")) Modified: pkg/R/mixtureCopula.R =================================================================== --- pkg/R/mixtureCopula.R 2016-09-01 13:33:20 UTC (rev 156) +++ pkg/R/mixtureCopula.R 2016-09-01 18:17:13 UTC (rev 157) @@ -1,166 +1,173 @@ -############################## -## ## -## a general mixture copula ## -## ## -############################## - -# class -setClass("mixtureCopula", contains = "copula", slots = list(memberCops= "list")) - -# constructor -mixtureCopula <- function (param = c(0.2, 0.2, 0.5), memberCops = c(normalCopula(), claytonCopula())) { - stopifnot(length(memberCops) == 2) - stopifnot(memberCops[[1]]@dimension == memberCops[[2]]@dimension) - - cop1.nPar <- length(memberCops[[1]]@parameters) - cop2.nPar <- length(memberCops[[2]]@parameters) - - if (missing(param)) - param <- 0.5 - if (length(param) == 1) - param <- c(memberCops[[1]]@parameters, memberCops[[2]]@parameters, 0.5) - else { - stopifnot(length(param) == cop1.nPar + cop2.nPar + 1) - - memberCops[[1]]@parameters <- param[1:cop1.nPar] - memberCops[[2]]@parameters <- param[(1:cop2.nPar)+cop1.nPar] - } - - new("mixtureCopula", dimension = memberCops[[1]]@dimension, parameters = param, memberCops = memberCops, - 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)) -} - -## density ## -setMethod("dCopula", signature(copula = "mixtureCopula"), - function(u, copula, log, ...) { - mixLambda <- tail(copula at parameters, 1) - res <- (1-mixLambda) * dCopula(u, copula at memberCops[[1]], ...) + mixLambda * dCopula(u, copula at memberCops[[2]], ...) - if (log) - return(log(res)) - else - return(res) - }) - -## jcdf ## -setMethod("pCopula", signature( copula = "mixtureCopula"), - function(u, copula, ...) { - mixLambda <- tail(copula at parameters, 1) - (1-mixLambda) * pCopula(u, copula at memberCops[[1]]) + mixLambda * pCopula(u, copula at memberCops[[2]]) - }) - -## partial derivatives ## -## ddu - -setMethod("dduCopula", signature(copula = "mixtureCopula"), - function(u, copula, ...) { - mixLambda <- tail(copula at parameters, 1) - (1-mixLambda) * dduCopula(u, copula at memberCops[[1]]) + mixLambda * dduCopula(u, copula at memberCops[[2]]) - }) - -# ddv -setMethod("ddvCopula", signature(copula = "mixtureCopula"), - function(u, copula, ...) { - mixLambda <- tail(copula at parameters, 1) - (1-mixLambda) * ddvCopula(u, copula at memberCops[[1]]) + mixLambda * ddvCopula(u, copula at memberCops[[2]]) - }) - -## inverse partial derivative -# 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) -} - -setMethod("invdduCopula", - signature("numeric", "mixtureCopula", "numeric"), - invdduMixCop) - -# invddv -invddvMixCop <- function (v, copula, y) { - stopifnot(length(v) == length(y)) - - opti <- function(ind) { - optFun <- function(u) { - (dduCopula(cbind(u, v[ind]), copula) - y[ind])^2 - } - optimise(optFun, c(0,1))$minimum - } - - sapply(1:length(y), opti) -} - -setMethod("invddvCopula", - signature("numeric", "mixtureCopula", "numeric"), - invddvMixCop) - -## random number generator - -rMixCop <- function(n, copula, ...) { - u <- runif(n) - y <- runif(n) - - cbind(u, invdduCopula(u, copula, y)) -} - -setMethod("rCopula", signature(copula = "mixtureCopula"), rMixCop) - -## fitment -fitMixCop <- function(copula, data, start, method="mpl", - lower = NULL, upper = NULL, - optim.method = "BFGS", optim.control = list(maxit = 1000), - estimate.variance = FALSE, ...){ - if (missing(start)) - start <- copula at parameters - stopifnot(method %in% c("ml", "mpl")) - - if(is.null(lower)) - lower <- copula at param.lowbnd - if(is.null(upper)) - upper <- copula at param.lowbnd - - copula:::fitCopula.ml(copula, data, start = start, method = method, - lower = lower, upper = upper, - optim.method = optim.method, - optim.control = optim.control, - estimate.variance = estimate.variance , ...) -} - -setMethod(fitCopula, - signature = c(copula = "mixtureCopula"), - fitMixCop) - -mixCop <- mixtureCopula(c(0.2,0.5,0.3)) -fitCopula(mixCop, rCopula(300, mixCop)) - -fitMixCop(mixCop, rCopula(300, mixCop)) - -# -# 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) { -# 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), -# stop("Implemented methods for copulas in the spCopula package are: ml, itau, and irho.")) -# return(fit) -# } -# -# setMethod("fitCopula", signature("asCopula"), fitCopulaASC2) - -# setMethod("tau",signature("asCopula"),tauASC2) -# setMethod("rho", signature("asCopula"), rhoASC2) -# setMethod("lambda", signature("asCopula"), -# function(copula, ...) c(lower = 0, upper = 0)) \ No newline at end of file +############################## +## ## +## a general mixture copula ## +## ## +############################## + +# class +setClass("mixtureCopula", contains = "copula", slots = list(memberCops= "list")) + +# constructor +mixtureCopula <- function (param = c(0.2, 0.2, 0.5), memberCops = c(normalCopula(0), claytonCopula(1))) { + stopifnot(length(memberCops) == 2) + stopifnot(memberCops[[1]]@dimension == memberCops[[2]]@dimension) + + cop1.nPar <- length(memberCops[[1]]@parameters) + cop2.nPar <- length(memberCops[[2]]@parameters) + + if (missing(param)) + param <- 0.5 + if (length(param) == 1) + param <- c(memberCops[[1]]@parameters, memberCops[[2]]@parameters, param) + else { + stopifnot(length(param) == cop1.nPar + cop2.nPar + 1) + + memberCops[[1]]@parameters <- param[1:cop1.nPar] + memberCops[[2]]@parameters <- param[(1:cop2.nPar)+cop1.nPar] + } + + new("mixtureCopula", dimension = memberCops[[1]]@dimension, parameters = param, memberCops = memberCops, + 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)) +} + +## density ## +setMethod("dCopula", signature(copula = "mixtureCopula"), + function(u, copula, log, ...) { + mixLambda <- tail(copula at parameters, 1) + res <- (1-mixLambda) * dCopula(u, copula at memberCops[[1]], ...) + mixLambda * dCopula(u, copula at memberCops[[2]], ...) + if (log) + return(log(res)) + else + return(res) + }) + +## jcdf ## +setMethod("pCopula", signature( copula = "mixtureCopula"), + function(u, copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * pCopula(u, copula at memberCops[[1]]) + mixLambda * pCopula(u, copula at memberCops[[2]]) + }) + +## partial derivatives ## +## ddu + +setMethod("dduCopula", signature(copula = "mixtureCopula"), + function(u, copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * dduCopula(u, copula at memberCops[[1]]) + mixLambda * dduCopula(u, copula at memberCops[[2]]) + }) + +# ddv +setMethod("ddvCopula", signature(copula = "mixtureCopula"), + function(u, copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * ddvCopula(u, copula at memberCops[[1]]) + mixLambda * ddvCopula(u, copula at memberCops[[2]]) + }) + +## inverse partial derivative +# 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) +} + +setMethod("invdduCopula", + signature("numeric", "mixtureCopula", "numeric"), + invdduMixCop) + +# invddv +invddvMixCop <- function (v, copula, y) { + stopifnot(length(v) == length(y)) + + opti <- function(ind) { + optFun <- function(u) { + (dduCopula(cbind(u, v[ind]), copula) - y[ind])^2 + } + optimise(optFun, c(0,1))$minimum + } + + sapply(1:length(y), opti) +} + +setMethod("invddvCopula", + signature("numeric", "mixtureCopula", "numeric"), + invddvMixCop) + +## random number generator + +rMixCop <- function(n, copula, ...) { + u <- runif(n) + y <- runif(n) + + cbind(u, invdduCopula(u, copula, y)) +} + +setMethod("rCopula", signature(copula = "mixtureCopula"), rMixCop) + +## fitment +fitMixCop <- function(copula, data, start, method="mpl", + lower = NULL, upper = NULL, + optim.method = "L-BFGS-B", + optim.control = list(maxit = 1000)){ + if (missing(start)) + start <- copula at parameters + stopifnot(method %in% c("ml", "mpl")) + + if(any(is.na(start))) + stop("Copula parameters or 'start' contains an 'NA' value.") + + if(is.null(lower)) + 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, + var.est = matrix(NA), + loglik = -optOut$value, + nsample = nrow(data), + method = method, + fitting.stats = append(optOut[c("convergence","counts","message")], + optim.control)) +} + +setMethod(fitCopula, + signature = c(copula = "mixtureCopula"), + fitMixCop) + +## + +setMethod("tau", signature = c(copula = "mixtureCopula"), + function(copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * tau(copula at memberCops[[1]], ...) + mixLambda * tau(copula at memberCops[[2]], ...) + }) + + +setMethod("lambda", signature = c(copula = "mixtureCopula"), + function(copula, ...) { + mixLambda <- tail(copula at parameters, 1) + (1-mixLambda) * lambda(copula at memberCops[[1]], ...) + mixLambda * lambda(copula at memberCops[[2]], ...) + }) \ No newline at end of file From noreply at r-forge.r-project.org Mon Sep 12 16:07:37 2016 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 12 Sep 2016 16:07:37 +0200 (CEST) Subject: [spcopula-commits] r158 - in pkg: . R demo man tests tests/Examples Message-ID: <20160912140737.AC4D618786B@r-forge.r-project.org> Author: ben_graeler Date: 2016-09-12 16:07:37 +0200 (Mon, 12 Sep 2016) New Revision: 158 Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/R/Classes.R pkg/R/cqsCopula.R pkg/R/empiricalCopula.R pkg/R/partialDerivatives.R pkg/R/spVineCopula.R pkg/demo/spCopula.R pkg/man/tawn3pCopula-class.Rd pkg/tests/Examples/spcopula-Ex.Rout.save pkg/tests/spCopulaTest.Rout.save pkg/tests/stCopulaTest.Rout.save Log: adds documentation for mixtureCopula; fixes error induced by copula:::isFree Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/DESCRIPTION 2016-09-12 14:07:37 UTC (rev 158) @@ -2,7 +2,7 @@ Type: Package Title: Copula Driven Spatio-Temporal Analysis Version: 0.2-1 -Date: 2016-09-01 +Date: 2016-09-12 Authors at R: c(person("Benedikt", "Graeler", role = c("aut", "cre"), email = "ben.graeler at uni-muenster.de"), person("Marius", "Appel",role = "ctb")) @@ -10,8 +10,8 @@ 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. License: GPL-3 LazyLoad: yes -Depends: copula (>= 0.999-15), R (>= 3.1.0) -Imports: methods, sp, spacetime (>= 1.0-9), VineCopula (>= 1.4) +Depends: copula (>= 0.999-15), R (>= 3.1.0), VineCopula (>= 2.0.4) +Imports: methods, sp, spacetime (>= 1.0-9) Suggests: evd URL: http://r-forge.r-project.org/projects/spcopula/ Collate: Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/NAMESPACE 2016-09-12 14:07:37 UTC (rev 158) @@ -1,4 +1,5 @@ import(copula) +import(VineCopula) import(sp, spacetime) import(methods) @@ -6,7 +7,7 @@ importFrom("stats", "D", "approxfun", "cor", "ecdf", "integrate", "lm", "optim", "optimise", "optimize", "pnorm", "predict", "pt", "qnorm", "qt", "quantile", "runif", "uniroot", "var") - importFrom("utils", "setTxtProgressBar", "txtProgressBar") + importFrom("utils", "setTxtProgressBar", "txtProgressBar", "tail") importMethodsFrom(VineCopula, fitCopula) importMethodsFrom(VineCopula, dduCopula,ddvCopula) @@ -44,6 +45,7 @@ export(stCoVarVineCopula) export(neighbourhood, stNeighbourhood) export(empiricalCopula, genEmpCop) +export(mixtureCopula) # general functions export(rankTransform, dependencePlot, unitScatter, univScatter) @@ -79,4 +81,5 @@ ## classes exportClasses(asCopula, cqsCopula, tawn3pCopula, neighbourhood, stNeighbourhood, empiricalCopula) exportClasses(spCopula, stCopula, spVineCopula, stVineCopula) -exportClasses(stCoVarVineCopula) \ No newline at end of file +exportClasses(stCoVarVineCopula) +exportClasses(mixtureCopula) \ No newline at end of file Modified: pkg/R/Classes.R =================================================================== --- pkg/R/Classes.R 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/R/Classes.R 2016-09-12 14:07:37 UTC (rev 158) @@ -173,31 +173,6 @@ tres="character"), validity = validStCopula, contains = list("copula")) -############################################### -## vine copulas, happens now in VineCopula ## -############################################### - -# validVineCopula = function(object) { -# dim <- object at dimension -# if( dim <= 2) -# return("Number of dimension too small (>2).") -# if(length(object at copulas)!=(dim*(dim-1)/2)) -# return("Number of provided copulas does not match given dimension.") -# if(!any(unlist(lapply(object at copulas,function(x) is(x,"copula"))))) -# return("Not all provided copulas in your list are indeed copulas.") -# return (TRUE) -# } -# -# setOldClass("RVineMatrix") -# -# setClass("vineCopula", -# representation = representation(copulas="list", dimension="integer", -# RVM="RVineMatrix"), -# prototype = prototype(RVM=structure(list(),class="RVineMatrix")), -# validity = validVineCopula, -# contains = list("copula") -# ) - ######################### ## Spatial Vine Copula ## ######################### Modified: pkg/R/cqsCopula.R =================================================================== --- pkg/R/cqsCopula.R 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/R/cqsCopula.R 2016-09-12 14:07:37 UTC (rev 158) @@ -1,6 +1,3 @@ -## make fitCopula generic -setGeneric("fitCopula",fitCopula) - ###################################################### ## ## ## a symmetric copula with cubic quadratic sections ## Modified: pkg/R/empiricalCopula.R =================================================================== --- pkg/R/empiricalCopula.R 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/R/empiricalCopula.R 2016-09-12 14:07:37 UTC (rev 158) @@ -35,7 +35,7 @@ ## jcdf ## # from package copula pempCop.C <- function(u, copula) { - return(Cn(copula at sample,u)) + F.n(u, copula at sample) } setMethod("pCopula", signature("numeric", "empiricalCopula"), Modified: pkg/R/partialDerivatives.R =================================================================== --- pkg/R/partialDerivatives.R 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/R/partialDerivatives.R 2016-09-12 14:07:37 UTC (rev 158) @@ -1,9 +1,3 @@ -# partial derivatives and their inverse of some copulas from the copula package -# new defined copulas store their partial derivative separately -# -# setGeneric("dduCopula", function(u, copula, ...) standardGeneric("dduCopula")) -# setGeneric("ddvCopula", function(u, copula, ...) standardGeneric("ddvCopula")) - ## inverse partial derivatives # numerical standard function invdduCopula <- function(u, copula, y, ..., tol=.Machine$double.eps^0.5) { Modified: pkg/R/spVineCopula.R =================================================================== --- pkg/R/spVineCopula.R 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/R/spVineCopula.R 2016-09-12 14:07:37 UTC (rev 158) @@ -87,7 +87,8 @@ }) # fitting the spatial vine for a given list of spatial copulas -fitSpVine <- function(copula, data, method, estimate.variance=FALSE) { +fitSpVine <- function(copula, data, method="ml", estimate.variance=FALSE) { + cat("fitSpVine \n") stopifnot(is.list(data)) stopifnot(length(data)==2) neigh <- data[[1]] Modified: pkg/demo/spCopula.R =================================================================== --- pkg/demo/spCopula.R 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/demo/spCopula.R 2016-09-12 14:07:37 UTC (rev 158) @@ -1,7 +1,5 @@ ## librarys ## -library("spcopula") library("sp") -# library("evd") ## meuse - spatial poionts data.frame ## data("meuse") @@ -83,9 +81,11 @@ vineDim <- 5L meuseNeigh <- getNeighbours(meuse,var="marZinc",size=vineDim) -meuseSpVine <- fitCopula(spVineCopula(spCop, vineCopula(as.integer(vineDim-1))), - list(meuseNeigh, meuse)) +vineCop <- vineCopula(4L) +meuseSpVine <- fitCopula(spVineCopula(spCop, vineCop), + list(meuseNeigh, meuse), method="none") + # log-likelihood: meuseSpVine at loglik Modified: pkg/man/tawn3pCopula-class.Rd =================================================================== --- pkg/man/tawn3pCopula-class.Rd 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/man/tawn3pCopula-class.Rd 2016-09-12 14:07:37 UTC (rev 158) @@ -10,6 +10,8 @@ \alias{pCopula,matrix,tawn3pCopula-method} \alias{pCopula,numeric,tawn3pCopula-method} \alias{rCopula,numeric,tawn3pCopula-method} +\alias{dduCopula,ANY,tawn3pCopula-method} +\alias{ddvCopula,ANY,tawn3pCopula-method} \title{Class \code{"tawn3pCopula"}} \description{ Modified: pkg/tests/Examples/spcopula-Ex.Rout.save =================================================================== --- pkg/tests/Examples/spcopula-Ex.Rout.save 2016-09-01 18:17:13 UTC (rev 157) +++ pkg/tests/Examples/spcopula-Ex.Rout.save 2016-09-12 14:07:37 UTC (rev 158) @@ -1,806 +1,873 @@ - -R version 3.2.2 (2015-08-14) -- "Fire Safety" -Copyright (C) 2015 The R Foundation for Statistical Computing -Platform: x86_64-pc-linux-gnu (64-bit) - -R is free software and comes with ABSOLUTELY NO WARRANTY. -You are welcome to redistribute it under certain conditions. -Type 'license()' or 'licence()' for distribution details. - - Natural language support but running in an English locale - -R is a collaborative project with many contributors. -Type 'contributors()' for more information and -'citation()' on how to cite R or R packages in publications. - -Type 'demo()' for some demos, 'help()' for on-line help, or -'help.start()' for an HTML browser interface to help. -Type 'q()' to quit R. - -> pkgname <- "spcopula" -> source(file.path(R.home("share"), "R", "examples-header.R")) -> options(warn = 1) -> library('spcopula') -Loading required package: copula -> -> base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') -> cleanEx() -> nameEx("EU_RB") -> ### * EU_RB -> -> flush(stderr()); flush(stdout()) -> -> ### Name: EU_RB -> ### Title: Daily mean PM10 concentrations over Europe in June and July 2005 -> ### Aliases: EU_RB -> ### Keywords: datasets -> -> ### ** Examples -> -> data("EU_RB") -> str(EU_RB) -Formal class 'STFDF' [package "spacetime"] with 4 slots - ..@ data :'data.frame': 11834 obs. of 2 variables: - .. ..$ PM10: num [1:11834] 14 9.7 7.8 21.9 11.2 9 11 6.1 7.4 7.4 ... - .. ..$ EMEP: num [1:11834] 11.62 5.02 3.94 3.82 7.01 ... - ..@ sp :Formal class 'SpatialPointsDataFrame' [package "sp"] with 5 slots - .. .. ..@ data :'data.frame': 194 obs. of 1 variable: - .. .. .. ..$ station_altitude: int [1:194] 525 581 918 560 172 117 665 1137 330 330 ... - .. .. ..@ coords.nrs : num(0) - .. .. ..@ coords : num [1:194, 1:2] 4592866 4761515 4658756 4690954 4799839 ... - .. .. .. ..- attr(*, "dimnames")=List of 2 - .. .. .. .. ..$ : NULL - .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" - .. .. ..@ bbox : num [1:2, 1:2] 2749697 1647732 6412269 4604814 - .. .. .. ..- attr(*, "dimnames")=List of 2 - .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" - .. .. .. .. ..$ : chr [1:2] "min" "max" - .. .. ..@ proj4string:Formal class 'CRS' [package "sp"] with 1 slot - .. .. .. .. ..@ projargs: chr " +proj=laea +lat_0=52 +lon_0=10 +x_0=4321000 +y_0=3210000 +ellps=GRS80 +units=m +no_defs" - ..@ time :An ?xts? object on 2005-06-01/2005-07-31 containing: - Data: int [1:61, 1] 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 ... - - attr(*, "dimnames")=List of 2 - ..$ : NULL - ..$ : chr "..1" - Indexed by objects of class: [POSIXct,POSIXt] TZ: GMT - xts Attributes: - NULL - ..@ endTime: POSIXct[1:61], format: "2005-06-02 02:00:00" "2005-06-03 02:00:00" ... -> -> -> -> cleanEx() -> nameEx("EU_RB_2005") -> ### * EU_RB_2005 -> -> flush(stderr()); flush(stdout()) -> -> ### Name: EU_RB_2005 -> ### Title: Daily mean PM10 concentrations over Europe in 2005 as used in -> ### the JSS manuscript -> ### Aliases: EU_RB_2005 -> ### Keywords: datasets -> -> ### ** Examples -> -> data("EU_RB_2005") -> str(EU_RB_2005) -Formal class 'STFDF' [package "spacetime"] with 4 slots - ..@ data :'data.frame': 70810 obs. of 3 variables: - .. ..$ PM10 : num [1:70810] 28 7 11.9 12.9 14.6 30 31.1 8.4 37.8 37.8 ... - .. ..$ EMEP : num [1:70810] 6.36 4.13 5.84 4.93 5.86 ... - .. ..$ logResidKrige: num [1:70810] 12.8 12.4 10.6 11.6 17.1 ... - ..@ sp :Formal class 'SpatialPointsDataFrame' [package "sp"] with 5 slots - .. .. ..@ data :'data.frame': 194 obs. of 8 variables: - .. .. .. ..$ station_altitude : int [1:194] 525 581 918 560 172 117 665 1137 330 330 ... - .. .. .. ..$ station_european_code: Factor w/ 7734 levels "AD0942A","AD0944A",..: 12 61 112 69 73 14 194 184 23 25 ... - .. .. .. ..$ country_iso_code : Factor w/ 39 levels "AD","AL","AT",..: 3 3 3 3 3 3 3 3 3 3 ... - .. .. .. ..$ station_start_date : Factor w/ 2344 levels "1900-01-01","1951-04-01",..: 1117 377 296 411 649 134 658 429 672 684 ... - .. .. .. ..$ station_end_date : Factor w/ 811 levels "","1900-01-01",..: 1 1 1 1 1 1 1 1 1 736 ... - .. .. .. ..$ type_of_station : Factor w/ 5 levels "","Background",..: 2 2 2 2 2 2 2 2 2 2 ... - .. .. .. ..$ station_type_of_area : Factor w/ 5 levels "","rural","suburban",..: 2 2 2 2 2 2 2 2 2 2 ... - .. .. .. ..$ street_type : Factor w/ 5 levels "","Canyon street: L/H < 1.5",..: 1 1 5 4 4 1 4 1 2 1 ... - .. .. ..@ coords.nrs : num(0) - .. .. ..@ coords : num [1:194, 1:2] 4592866 4761515 4658756 4690954 4799839 ... - .. .. .. ..- attr(*, "dimnames")=List of 2 - .. .. .. .. ..$ : NULL - .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" - .. .. ..@ bbox : num [1:2, 1:2] 2749697 1647732 6412269 4604814 - .. .. .. ..- attr(*, "dimnames")=List of 2 - .. .. .. .. ..$ : chr [1:2] "coords.x1" "coords.x2" - .. .. .. .. ..$ : chr [1:2] "min" "max" - .. .. ..@ proj4string:Formal class 'CRS' [package "sp"] with 1 slot - .. .. .. .. ..@ projargs: chr " +proj=laea +lat_0=52 +lon_0=10 +x_0=4321000 +y_0=3210000 +ellps=GRS80 +units=m +no_defs" - ..@ time :An ?xts? object on 2005-01-01/2005-12-31 containing: - Data: int [1:365, 1] 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 ... - - attr(*, "dimnames")=List of 2 - ..$ : NULL - ..$ : chr "..1" - Indexed by objects of class: [POSIXct,POSIXt] TZ: GMT - xts Attributes: - NULL - ..@ endTime: POSIXct[1:365], format: "2005-01-02 01:00:00" "2005-01-03 01:00:00" ... -> -> -> -> cleanEx() -> nameEx("asCopula-class") -> ### * asCopula-class -> -> flush(stderr()); flush(stdout()) -> -> ### Name: asCopula-class -> ### Title: Class '"asCopula"' -> ### Aliases: asCopula-class dduCopula,matrix,asCopula-method -> ### dduCopula,numeric,asCopula-method ddvCopula,matrix,asCopula-method -> ### ddvCopula,numeric,asCopula-method fitCopula,asCopula-method -> ### invdduCopula,numeric,asCopula,numeric-method -> ### invddvCopula,numeric,asCopula,numeric-method -> ### Keywords: classes asymmetric copula copula -> -> ### ** Examples -> -> showClass("asCopula") -Class "asCopula" [package "spcopula"] - -Slots: - -Name: dimension parameters param.names param.lowbnd param.upbnd -Class: integer numeric character numeric numeric - -Name: fullname -Class: character - -Extends: -Class "copula", directly -Class "Copula", by class "copula", distance 2 -> -> -> -> cleanEx() -> nameEx("asCopula") -> ### * asCopula -> -> flush(stderr()); flush(stdout()) -> -> ### Name: asCopula -> ### Title: Constructor of an asymmetric copula with cubic and quadratic -> ### sections (Nelsen 2006). -> ### Aliases: asCopula -> ### Keywords: asymmetric copula cubic quadratic sections -> -> ### ** Examples -> -> persp(asCopula(c(-2,1)),dCopula) -> -> -> -> cleanEx() -> nameEx("bivTailDepFun") -> ### * bivTailDepFun -> -> flush(stderr()); flush(stdout()) -> -> ### Name: bivJointDepFun -> ### Title: Bivariate joint dependence functions -> ### Aliases: bivJointDepFun lowerBivJointDepFun upperBivJointDepFun -> ### empBivJointDepFun lowerEmpBivJointDepFun upperEmpBivJointDepFun -> -> ### ** Examples -> -> library("VineCopula") -> data("simulatedTriples") -> X <- rankTransform(triples[,c(1,3)]) -> -> tdfEmp <- empBivJointDepFun(X) -> plot(tdfEmp,ylim=c(0,1), -+ ylab="tail dependence index") -> abline(v=0.5, col="grey") -> -> smplTau <- cor(X,method="kendall")[1,2] -> -> # Gauss -> tdfGauss <- bivJointDepFun(normalCopula(sin(smplTau*pi/2))) -> curve(tdfGauss,add=TRUE,col="blue") -> -> # survival Gumbel -> tdfGumbel <- bivJointDepFun(surGumbelCopula(1/(1-smplTau))) -> curve(tdfGumbel,add=TRUE,col="darkgreen") -> -> # survival BB6 copula -> tdfBB6 <- bivJointDepFun(surBB6Copula(c(4.65,2.28))) -> curve(tdfBB6,add=TRUE,col="red") -> -> legend("bottomleft",c("empircal","Gauss","surv. Gumbel","surv. BB6"), -+ col=c("black","blue","darkgreen","red"),lty=1) -> -> -> -> cleanEx() - -detaching ?package:VineCopula? - -> nameEx("calcBins") -> ### * calcBins -> -> flush(stderr()); flush(stdout()) -> -> ### Name: calcBins -> ### Title: A function calculating the spatial/spatio-temporal bins -> ### Aliases: calcBins calcBins-methods calcBins,Spatial-method -> ### calcBins,STFDF-method -> ### Keywords: spatial preparation spatio-temporal preparation -> -> ### ** Examples -> -> library("sp") -> data("meuse") -> coordinates(meuse) = ~x+y -> meuse$rtZinc <- rank(meuse$zinc)/(length(meuse)+1) -> -> ## lag classes ## -> bins <- calcBins(meuse, var="rtZinc", nbins=10, cutoff=800) -> -> -> -> cleanEx() - -detaching ?package:sp? - -> nameEx("composeSpCopula") -> ### * composeSpCopula -> -> flush(stderr()); flush(stdout()) -> -> ### Name: composeSpCopula -> ### Title: Composing a bivariate Spatial Copula -> ### Aliases: composeSpCopula -> ### Keywords: spatial multivariate distribution -> -> ### ** Examples -> -> composeSpCopula(c(1,1,2,3),families=list(frankCopula(.4), gumbelCopula(1.6),gumbelCopula(1.4)), -+ bins=data.frame(meanDists=c(500,1000,1500,2000,2500)),range=2250) -Spatial Copula: distance dependent convex combination of bivariate copulas -Dimension: 2 -Copulas: - Frank copula family; Archimedean copula at 500 [m] - Frank copula family; Archimedean copula at 1000 [m] - Gumbel copula family; Archimedean copula; Extreme value copula at 1500 [m] - Gumbel copula family; Archimedean copula; Extreme value copula at 2000 [m] -> -> -> -> cleanEx() -> nameEx("condCovariate") -> ### * condCovariate -> -> flush(stderr()); flush(stdout()) -> -> ### Name: condCovariate -> ### Title: Conditioning of a Covariate -> ### Aliases: condCovariate -> -> ### ** Examples -> -> library("sp") -> library("spacetime") -> -> sp <- SpatialPoints(matrix(c(181000,181100,333500,333600),2)) -> time <- as.POSIXct("2014-03-18")+60*60*24*c(0,1,2) -> data <- data.frame(var=runif(6)) -> data$coVar <- invdduCopula(data$var, gumbelCopula(7), runif(6)) -Numerical evaluation of invddu takes place. -> -> stData <- STFDF(sp, time, data) -> stQuerry <- STF(SpatialPoints(matrix(c(181000,181200,333600,333600),2)), -+ time[2:3]) -> -> stNeigh <- getStNeighbours(stData=stData, ST=stQuerry, -+ spSize=3, tlags=-(0:1), -+ var="var", coVar="coVar", prediction=TRUE) -> -> condCovariate(stNeigh, function(x) gumbelCopula(7)) -[1] 2.558620e-05 5.677942e-09 6.178627e-02 1.765568e-01 -> -> -> -> cleanEx() - -detaching ?package:spacetime?, ?package:sp? - -> nameEx("condSpVine") -> ### * condSpVine -> -> flush(stderr()); flush(stdout()) -> -> ### Name: condSpVine -> ### Title: Conditions a spatial vine copula for conditional prediction -> ### Aliases: condSpVine -> ### Keywords: distribution -> -> ### ** Examples -> -> library("VineCopula") -> data("spCopDemo") -> -> calcKTauPol <- fitCorFun(bins, degree=3) - -Call: -lm(formula = lagCor ~ poly(meanDists, degree), data = bins) - -Coefficients: - (Intercept) poly(meanDists, degree)1 poly(meanDists, degree)2 - 0.20756 -0.58268 0.16262 -poly(meanDists, degree)3 - -0.02181 - -Sum of squared residuals: 0.006621988 -> -> spCop <- spCopula(components=list(normalCopula(0), tCopula(0, dispstr = "un"), -+ frankCopula(1), normalCopula(0), claytonCopula(0), -+ claytonCopula(0), claytonCopula(0), claytonCopula(0), -+ claytonCopula(0), indepCopula()), -+ distances=bins$meanDists, -+ spDepFun=calcKTauPol, unit="m") -The parameters of the components will be recalculated according to the provided spDepFun where possible. -In case no 1-1 relation is known, the copula as in components is used. -parameter at boundary ==> returning indepCopula() -parameter at boundary ==> returning indepCopula() -parameter at boundary ==> returning indepCopula() -parameter at boundary ==> returning indepCopula() -parameter at boundary ==> returning indepCopula() -> -> spVineCop <- spVineCopula(spCop, vineCopula(4L)) -> -> dists <- list(c(473, 124, 116, 649)) -> condVar <- c(0.29, 0.55, 0.05, 0.41) -> condDensity <- condSpVine(condVar,dists,spVineCop) -> -> curve(condDensity) -> mtext(paste("Dists:",paste(round(dists[[1]],0),collapse=", ")),line=0) -> mtext(paste("Cond.:",paste(round(condVar,2),collapse=", ")),line=1) -> -> -> -> cleanEx() - -detaching ?package:VineCopula? - -> nameEx("condStCoVarVine") -> ### * condStCoVarVine -> -> flush(stderr()); flush(stdout()) -> -> ### Name: condStCoVarVine -> ### Title: conditional distribution function of spatio-temporal covariate -> ### vine copula -> ### Aliases: condStCoVarVine -> -> ### ** Examples -> -> library("VineCopula") -> spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), -+ claytonCopula(2), claytonCopula(1), -+ claytonCopula(0.5), indepCopula()), -+ distances=c(100,200,300,400,500,600), -+ unit="km") -> spCopT1 <- spCopula(components=list(claytonCopula(4), claytonCopula(2), -+ claytonCopula(1), claytonCopula(0.5), -+ indepCopula()), -+ distances=c(100,200,300,400,500), -+ unit="km") -> spCopT2 <- spCopula(components=list(claytonCopula(2), claytonCopula(1), -+ claytonCopula(0.5), indepCopula()), -+ distances=c(100,200,300,400), -+ unit="km") -> -> stCop <- stCopula(components=list(spCopT0, spCopT1, spCopT2), -+ tlags=-(0:2)) -> -> # only a constant copula ius used for the covariate -> stCVVC <- stCoVarVineCopula(function(x) gumbelCopula(7), stCop, vineCopula(5L)) -> -> dists <- array(c(150, 250, 150, 250,0,0,-1,-1),dim=c(1,4,2)) -> condVar <- c(0.95, 0.29, 0.55, 0.05, 0.41) -> -> condDensity <- condStCoVarVine(condVar, dists, stCVVC, c(1,1)) -> curve(condDensity) -> -> -> -> cleanEx() - -detaching ?package:VineCopula? - -> nameEx("condStVine") -> ### * condStVine -> -> flush(stderr()); flush(stdout()) -> -> ### Name: condStVine -> ### Title: Conditions a spatio-temporal vine copula for conditional -> ### prediction -> ### Aliases: condStVine -> ### Keywords: distribution -> -> ### ** Examples -> -> # a spatio-temporal C-vine copula (with independent copulas in the upper vine) -> library("VineCopula") -> -> spCopT0 <- spCopula(components=list(claytonCopula(8), claytonCopula(4), -+ claytonCopula(2), claytonCopula(1), -+ claytonCopula(0.5), indepCopula()), -+ distances=c(100,200,300,400,500,600), -+ unit="km") -> spCopT1 <- spCopula(components=list(claytonCopula(4), claytonCopula(2), -+ claytonCopula(1), claytonCopula(0.5), -+ indepCopula()), -+ distances=c(100,200,300,400,500), -+ unit="km") -> -> stCop <- stCopula(components=list(spCopT0, spCopT1), -+ tlags=-(0:1)) -> -> stVineCop <- stVineCopula(stCop, vineCopula(4L)) -> -> dists <- array(c(150, 250, 150, 250,0,0,-1,-1),dim=c(1,4,2)) -> condVar <- c(0.29, 0.55, 0.05, 0.41) -> -> condDensity <- condStVine(condVar,dists,stVineCop) -> curve(condDensity) -> -> -> -> cleanEx() - -detaching ?package:VineCopula? - -> nameEx("cqsCopula-class") -> ### * cqsCopula-class -> -> flush(stderr()); flush(stdout()) -> -> ### Name: cqsCopula-class -> ### Title: Class '"cqsCopula"' -> ### Aliases: cqsCopula-class dduCopula,matrix,cqsCopula-method -> ### dduCopula,numeric,cqsCopula-method ddvCopula,matrix,cqsCopula-method -> ### ddvCopula,numeric,cqsCopula-method fitCopula,cqsCopula-method -> ### invdduCopula,numeric,cqsCopula,numeric-method -> ### invddvCopula,numeric,cqsCopula,numeric-method -> ### Keywords: classes copula -> -> ### ** Examples -> -> showClass("cqsCopula") -Class "cqsCopula" [package "spcopula"] - -Slots: - -Name: fixed dimension parameters param.names param.lowbnd -Class: character integer numeric character numeric - -Name: param.upbnd fullname -Class: numeric character - -Extends: -Class "copula", directly -Class "Copula", by class "copula", distance 2 -> -> -> -> cleanEx() -> nameEx("cqsCopula") -> ### * cqsCopula -> -> flush(stderr()); flush(stdout()) -> -> ### Name: cqsCopula -> ### Title: Constructor of a symmetric copula with cubic quadratic sections. -> ### Aliases: cqsCopula -> ### Keywords: copula cubic quadratic sections -> -> ### ** Examples -> -> persp(cqsCopula(c(-2,1)),dCopula) -> -> -> -> cleanEx() -> nameEx("criticalLevel") -> ### * criticalLevel -> -> flush(stderr()); flush(stdout()) -> -> ### Name: criticalLevel -> ### Title: Calculating the critical level for a given Kendall Return Period -> ### Aliases: criticalLevel -> ### Keywords: survival multivariate -> -> ### ** Examples -> -> criticalLevel(getKendallDistr(frankCopula(.7)), KRP=c(10,100,1000)) -[1] 0.6244540 0.8801567 0.9620758 -> -> -> -> cleanEx() -> nameEx("criticalPair") -> ### * criticalPair -> -> flush(stderr()); flush(stdout()) -> -> ### Name: criticalPair -> ### Title: Calculate Critical Pairs -> ### Aliases: criticalPair -> ### Keywords: ~kwd1 ~kwd2 -> -> ### ** Examples -> -> v <- criticalPair(frankCopula(0.7), 0.9, u=.97, 1) -> pCopula(c(0.97, v),frankCopula(0.7)) -[1] 0.9 -> -> -> -> cleanEx() -> nameEx("criticalTriple") -> ### * criticalTriple -> -> flush(stderr()); flush(stdout()) -> -> ### Name: criticalTriple -> ### Title: calculate critical triples -> ### Aliases: criticalTriple -> ### Keywords: multivariate distribution -> -> ### ** Examples -> -> w <- criticalTriple(frankCopula(0.7,dim=3), 0.9, c(.97,.97), c(1,2)) -> -> # check the triple -> pCopula(c(0.97, 0.97, w), frankCopula(0.7, dim=3)) -[1] 0.9 -> -> -> -> -> cleanEx() -> nameEx("dduCopula") -> ### * dduCopula -> -> flush(stderr()); flush(stdout()) -> -> ### Name: dduCopula -> ### Title: partial derivatives of copulas -> ### Aliases: dduCopula ddvCopula -> ### Keywords: partial derivative conditional probabilities -> -> ### ** Examples -> -> #################################### -> ## Asymmetric vs. Gaussian copula ## -> #################################### -> -> asCop <- asCopula(c(-2,1)) -> asCopSmpl <- rCopula(100,asCop) -> -> unitScatter(smpl=asCopSmpl) -> -> # conditional probabilities of an asymmetric copula given u -> asGivenU <- dduCopula(asCopSmpl,asCop) -> -> # vs. conditional probabilities of an asymmetric copula given v -> asGivenV <- ddvCopula(asCopSmpl[,c(2,1)],asCop) -> unitScatter(smpl=cbind(asGivenU, asGivenV)) -> -> normalCop <- normalCopula(.6) -> normCopSmpl <- rCopula(100,normalCop) -> -> unitScatter(smpl=normCopSmpl) -> -> # conditional probabilities of a Gaussian copula given u -> normGivenU <- dduCopula(normCopSmpl,normalCop) -> -> # vs. conditional probabilities of a Gaussian copula given v -> normGivenV <- ddvCopula(normCopSmpl[,c(2,1)],normalCop) -> unitScatter(smpl=cbind(normGivenU, normGivenV)) -> -> -> -> cleanEx() -> nameEx("dependencePlot") -> ### * dependencePlot -> -> flush(stderr()); flush(stdout()) -> -> ### Name: dependencePlot -> ### Title: Kernel smoothed scatter plot -> ### Aliases: dependencePlot -> ### Keywords: plot -> -> ### ** Examples -> -> ## Not run: dependencePlot(smpl=rCopula(500,asCopula(c(-1,1)))) -> -> -> -> cleanEx() -> nameEx("empiricalCopula-class") -> ### * empiricalCopula-class -> -> flush(stderr()); flush(stdout()) -> -> ### Name: empiricalCopula-class -> ### Title: Class '"empiricalCopula"' -> ### Aliases: empiricalCopula-class -> ### Keywords: classes -> -> ### ** Examples -> -> showClass("empiricalCopula") -Class "empiricalCopula" [package "spcopula"] - -Slots: - -Name: sample dimension parameters param.names param.lowbnd -Class: matrix integer numeric character numeric - -Name: param.upbnd fullname -Class: numeric character - -Extends: -Class "copula", directly -Class "Copula", by class "copula", distance 2 -> -> -> -> cleanEx() -> nameEx("empiricalCopula") -> ### * empiricalCopula -> -> flush(stderr()); flush(stdout()) -> -> ### Name: empiricalCopula -> ### Title: Constructor of an empirical copula class -> ### Aliases: empiricalCopula -> ### Keywords: multivariate -> -> ### ** Examples -> -> empCop <- empiricalCopula(rCopula(500,frankCopula(0.7))) -> str(empCop) -Formal class 'empiricalCopula' [package "spcopula"] with 7 slots - ..@ sample : num [1:500, 1:2] 0.266 0.372 0.573 0.908 0.202 ... - ..@ dimension : int 2 - ..@ parameters : num NA - ..@ param.names : chr "unknown" - ..@ param.lowbnd: num NA - ..@ param.upbnd : num NA - ..@ fullname : chr "Unkown empirical copula based on a sample." -> -> empCop <- empiricalCopula(copula=frankCopula(0.7)) -Note: the copula will be empirically represented by a sample of size: 1e+05 -> str(empCop) -Formal class 'empiricalCopula' [package "spcopula"] with 7 slots - ..@ sample : num [1:100000, 1:2] 0.531 0.685 0.383 0.955 0.118 ... - ..@ dimension : int 2 - ..@ parameters : num 0.7 - ..@ param.names : chr "param" - ..@ param.lowbnd: num -Inf - ..@ param.upbnd : num Inf - ..@ fullname : chr "Empirical copula derived from Frank copula family; Archimedean copula" -> -> empCop <- empiricalCopula(rCopula(500,frankCopula(0.7)), frankCopula(0.7)) -> str(empCop) -Formal class 'empiricalCopula' [package "spcopula"] with 7 slots - ..@ sample : num [1:500, 1:2] 0.8219 0.2413 0.0371 0.2891 0.7464 ... - ..@ dimension : int 2 - ..@ parameters : num 0.7 - ..@ param.names : chr "param" - ..@ param.lowbnd: num -Inf - ..@ param.upbnd : num Inf - ..@ fullname : chr "Empirical copula derived from Frank copula family; Archimedean copula" -> -> # the empirical value -> pCopula(c(0.3, 0.5), empCop) -[1] 0.156 -> -> # the theoretical value -> pCopula(c(0.3, 0.5), frankCopula(0.7)) -[1] 0.1682671 -> -> -> -> cleanEx() -> nameEx("fitCorFun") -> ### * fitCorFun -> -> flush(stderr()); flush(stdout()) -> -> ### Name: fitCorFun -> ### Title: Automated fitting of a correlation function to the correlogram -> ### Aliases: fitCorFun -> ### Keywords: correlogram spcopula -> -> ### ** Examples -> -> # a simplified bins object (from demo(spcopula)) -> bins <- list(meanDists=c(64, 128, 203, 281, 361, 442, 522, 602, 681, 760), -+ lagCor=c(0.57, 0.49, 0.32, 0.29, 0.15, 0.14, 0.10, -0.00, 0.03, -0.01)) -> attr(bins,"cor.method") <- "kendall" -> -> # plot the correlogram -> plot(lagCor~meanDists,bins) -> -> # fit and plot a linear model -> calcKTauLin <- fitCorFun(bins, degree=1, cutoff=600) - -Call: -lm(formula = lagCor ~ poly(meanDists, degree), data = bins) - -Coefficients: - (Intercept) poly(meanDists, degree) - 0.2943 -0.4284 - -Sum of squared residuals: 0.01381904 -> curve(calcKTauLin,0, 1000, col="red",add=TRUE) -> -> # fit and plot a polynomial model -> calcKTauPol <- fitCorFun(bins, degree=5) - -Call: -lm(formula = lagCor ~ poly(meanDists, degree), data = bins) - -Coefficients: - (Intercept) poly(meanDists, degree)1 poly(meanDists, degree)2 - 0.208000 -0.581940 0.161524 -poly(meanDists, degree)3 poly(meanDists, degree)4 poly(meanDists, degree)5 - -0.023774 0.004097 0.011434 - -Sum of squared residuals: 0.006503102 -> curve(calcKTauPol,0, 1000, col="purple",add=TRUE) -> -> -> -> cleanEx() -> nameEx("fitSpCopula") -> ### * fitSpCopula -> -> flush(stderr()); flush(stdout()) -> -> ### Name: fitSpCopula -> ### Title: Spatial Copula Fitting -> ### Aliases: fitSpCopula -> ### Keywords: spatial multivariate distribution -> -> ### ** Examples -> -> # reload some spatial data -> library("sp") -> data("meuse") -> coordinates(meuse) <- ~x+y -> -> # drop margins -> meuse$marZinc <- plnorm(meuse$zinc, mean(log(meuse$zinc)), sd(log(meuse$zinc))) -> -> # load data from a provided binning -> data("spCopDemo") -> -> fitSpCopula(bins, meuse, 600) - -Call: -lm(formula = lagCor ~ poly(meanDists, degree), data = bins) - -Coefficients: - (Intercept) poly(meanDists, degree)1 poly(meanDists, degree)2 - 0.294212 -0.428150 0.100339 -poly(meanDists, degree)3 - 0.007255 - -Sum of squared residuals: 0.003770511 -Normal copula family + +R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" +Copyright (C) 2016 The R Foundation for Statistical Computing +Platform: x86_64-w64-mingw32/x64 (64-bit) + +R is free software and comes with ABSOLUTELY NO WARRANTY. +You are welcome to redistribute it under certain conditions. +Type 'license()' or 'licence()' for distribution details. + +R is a collaborative project with many contributors. +Type 'contributors()' for more information and +'citation()' on how to cite R or R packages in publications. + +Type 'demo()' for some demos, 'help()' for on-line help, or +'help.start()' for an HTML browser interface to help. +Type 'q()' to quit R. + +> pkgname <- "spcopula" +> source(file.path(R.home("share"), "R", "examples-header.R")) +> options(warn = 1) +> options(pager = "console") [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/spcopula -r 158 From noreply at r-forge.r-project.org Wed Sep 14 12:58:12 2016 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 14 Sep 2016 12:58:12 +0200 (CEST) Subject: [spcopula-commits] r159 - pkg/man Message-ID: <20160914105812.CCCB8184C73@r-forge.r-project.org> Author: ben_graeler Date: 2016-09-14 12:58:12 +0200 (Wed, 14 Sep 2016) New Revision: 159 Added: pkg/man/mixtureCopula-class.Rd pkg/man/mixtureCopula.Rd Log: adding man files for the mixtureCopula Added: pkg/man/mixtureCopula-class.Rd =================================================================== --- pkg/man/mixtureCopula-class.Rd (rev 0) +++ pkg/man/mixtureCopula-class.Rd 2016-09-14 10:58:12 UTC (rev 159) @@ -0,0 +1,50 @@ +\name{mixtureCopula-class} +\Rdversion{1.1} +\docType{class} +\alias{mixtureCopula-class} +\alias{dduCopula,ANY,mixtureCopula-method} +\alias{ddvCopula,ANY,mixtureCopula-method} +\alias{fitCopula,mixtureCopula-method} +\alias{invdduCopula,numeric,mixtureCopula,numeric-method} +\alias{invddvCopula,numeric,mixtureCopula,numeric-method} + +\title{Class \code{"mixtureCopula"}} +\description{ +The \code{mixtureCopula} contains two copulas that are combined in a convex manner to a new copula. +} +\section{Objects from the Class}{ +Objects can be created by calls of the form \code{new("mixtureCopula", ...)} or by calling the constructor \code{\link{mixtureCopula}}. +} +\section{Slots}{ + \describe{ + \item{\code{memberCops}:}{Object of class \code{"list"}: holding the copulas used in the convex combination. } + \item{\code{dimension}:}{Object of class \code{"integer"}: the dimension of both input and the resulting copula. } + \item{\code{parameters}:}{Object of class \code{"numeric"}: the set of parameters for the first and second copula as well as the mixing coefficient.} + \item{\code{param.names}:}{Object of class \code{"character"}: names of all parameters. } + \item{\code{param.lowbnd}:}{Object of class \code{"numeric"}: lower bounds of all parameters. } + \item{\code{param.upbnd}:}{Object of class \code{"numeric"}: upper bounds of all parameters. } + \item{\code{fullname}:}{Object of class \code{"character"}: the name of the copula. } + } +} +\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{dduCopula}{\code{signature(u = "ANY", copula = "mixtureCopula")}: ... } + \item{ddvCopula}{\code{signature(u = "ANY", copula = "mixtureCopula")}: ... } + \item{fitCopula}{\code{signature(copula = "mixtureCopula")}: ... } + \item{invdduCopula}{\code{signature(u = "numeric", copula = "mixtureCopula", y = "numeric")}: ... } + \item{invddvCopula}{\code{signature(v = "numeric", copula = "mixtureCopula", y = "numeric")}: ... } + } +} + +\author{ +Benedikt Graeler} + +\examples{ +showClass("mixtureCopula") +} +\keyword{classes} Added: pkg/man/mixtureCopula.Rd =================================================================== --- pkg/man/mixtureCopula.Rd (rev 0) +++ pkg/man/mixtureCopula.Rd 2016-09-14 10:58:12 UTC (rev 159) @@ -0,0 +1,27 @@ +\name{mixtureCopula} +\alias{mixtureCopula} + +\title{ +Constructor of a mixture copula} +\description{ +An instance of a convex mixture of two copulas is generated. +} +\usage{ +mixtureCopula(param = c(0.2, 0.2, 0.5), memberCops = c(normalCopula(0), claytonCopula(1))) +} + +\arguments{ + \item{param}{A numeric vector: the set of parameters for the first and second copula appended by the mixture coefficient.} + \item{memberCops}{A list of two copulas.} +} +\value{ +An object of class \linkS4class{mixtureCopula}} +\author{ +Benedikt Graeler} + +\examples{ + +mixCop <- mixtureCopula() + +persp(mixCop, dCopula) +}