Skip to content

Commit

Permalink
Clean-up arguments of RVineCop/StructureSelect (#59)
Browse files Browse the repository at this point in the history 
* correct RVineMatrixSample for naturalOrder = TRUE

* relax what is considered an appropriate treecrit function

* improve check for treecrit

* Clean-up arguments of RVineCop/StructureSelect
  • Loading branch information
@tvatter @tnagler
tvatter authored and tnagler committed Jun 7, 2019
1 parent 74f222c commit cc8b621
Show file tree
Hide file tree
Showing 4 changed files with 103 additions and 68 deletions.
31 changes: 19 additions & 12 deletions R/RVineCopSelect.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,10 +29,14 @@
#' @param level numeric; significance level of the independence test (default:
#' \code{level = 0.05}).
#' @param trunclevel integer; level of truncation.
#' @param se Logical; whether standard errors are estimated (default: \code{se
#' = FALSE}).
#' @param weights Numerical; weights for each observation (optional).
#' @param rotations logical; if \code{TRUE}, all rotations of the families in
#' \code{familyset} are included.
#' @param se Logical; whether standard errors are estimated (default: \code{se
#' = FALSE}).
#' @param presel Logical; whether to exclude families before fitting based on
#' symmetry properties of the data. Makes the selection about 30\% faster
#' (on average), but may yield slightly worse results in few special cases.
#' @param method indicates the estimation method: either maximum
#' likelihood estimation (\code{method = "mle"}; default) or inversion of
#' Kendall's tau (\code{method = "itau"}). For \code{method = "itau"} only
Expand Down Expand Up @@ -128,8 +132,10 @@
#'
#' contour(RVM1) # contour plots of all pair-copulas
#'
RVineCopSelect <- function(data, familyset = NA, Matrix, selectioncrit = "AIC", indeptest = FALSE,
level = 0.05, trunclevel = NA, se = FALSE, rotations = TRUE, method = "mle", cores = 1) {
RVineCopSelect <- function(data, familyset = NA, Matrix, selectioncrit = "AIC",
indeptest = FALSE, level = 0.05, trunclevel = NA,
weights = NA, rotations = TRUE, se = FALSE,
presel = TRUE, method = "mle", cores = 1) {
## preprocessing of arguments
args <- preproc(c(as.list(environment()), call = match.call()),
check_data,
Expand Down Expand Up @@ -238,15 +244,16 @@ RVineCopSelect <- function(data, familyset = NA, Matrix, selectioncrit = "AIC",
"Independence has been selected automatically.")
}
} else {
cfit <- suppressWarnings(BiCopSelect(zr2,
zr1,
familyset,
selectioncrit,
indeptest,
level,
weights = NA,
rotations,
cfit <- suppressWarnings(BiCopSelect(u1 = zr2,
u2 = zr1,
familyset = familyset,
selectioncrit = selectioncrit,
indeptest = indeptest,
level = level,
weights = weights,
rotations = rotations,
se = se,
presel = presel,
method = method))
warn <- NULL
}
Expand Down
113 changes: 65 additions & 48 deletions R/RVineStructureSelect.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,10 +36,13 @@
#' @param weights numeric; weights for each observation (optional).
#' @param treecrit edge weight for Dissman's structure selection algorithm, see
#' \emph{Details}.
#' @param se Logical; whether standard errors are estimated (default: \code{se
#' = FALSE}).
#' @param rotations If \code{TRUE}, all rotations of the families in
#' \code{familyset} are included.
#' @param se Logical; whether standard errors are estimated (default: \code{se
#' = FALSE}).
#' @param presel Logical; whether to exclude families before fitting based on
#' symmetry properties of the data. Makes the selection about 30\% faster
#' (on average), but may yield slightly worse results in few special cases.
#' @param method indicates the estimation method: either maximum
#' likelihood estimation (\code{method = "mle"}; default) or inversion of
#' Kendall's tau (\code{method = "itau"}). For \code{method = "itau"} only
Expand Down Expand Up @@ -165,9 +168,13 @@
#' DVM <- D2RVine(order, family = rep(0,d*(d-1)/2), par = rep(0, d*(d-1)/2))
#' RVineCopSelect(daxreturns, c(1:6), DVM$Matrix)}
#'
RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE,
level = 0.05, trunclevel = NA, progress = FALSE, weights = NA,
treecrit = "tau", se = FALSE, rotations = TRUE, method = "mle", cores = 1) {
RVineStructureSelect <- function(data, familyset = NA, type = 0,
selectioncrit = "AIC", indeptest = FALSE,
level = 0.05, trunclevel = NA,
progress = FALSE, weights = NA,
treecrit = "tau", rotations = TRUE,
se = FALSE, presel = TRUE,
method = "mle", cores = 1) {
## preprocessing of arguments
args <- preproc(c(as.list(environment()), call = match.call()),
check_data,
Expand All @@ -191,8 +198,11 @@ RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit =
indeptest = indeptest,
level = level,
trunclevel = trunclevel,
weights = weights,
rotations = FALSE, # because prep_familyset
se = se,
rotations = rotations,
presel = presel,
method = method,
cores = cores))
}
if (!(selectioncrit %in% c("AIC", "BIC", "logLik")))
Expand Down Expand Up @@ -235,12 +245,13 @@ RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit =
# estimate pair-copulas
VineTree <- fit.FirstTreeCopulas(MST,
data,
familyset,
selectioncrit,
indeptest,
level,
se = se,
familyset = familyset,
selectioncrit = selectioncrit,
indeptest = indeptest,
level = level,
weights = weights,
se = se,
presel = presel,
method = method,
cores = cores)
# store results
Expand Down Expand Up @@ -270,9 +281,10 @@ RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit =
selectioncrit,
indeptest,
level,
se = se,
progress,
weights = weights,
se = se,
presel = presel,
method = method,
cores = cores)
# store results
Expand Down Expand Up @@ -544,9 +556,10 @@ fasttau <- function(x, y, weights = NA) {
}

## fit pair-copulas for the first vine tree
fit.FirstTreeCopulas <- function(MST, data.univ, type, copulaSelectionBy,
testForIndependence, testForIndependence.level,
se, weights = NA, method = "mle", cores = 1) {
fit.FirstTreeCopulas <- function(MST, data.univ, familyset, selectioncrit,
indeptest, level,
weights = NA, se = FALSE,
presel = TRUE, method = "mle", cores = 1) {

## initialize estimation results with empty list
d <- nrow(MST$E$nums)
Expand Down Expand Up @@ -589,22 +602,24 @@ fit.FirstTreeCopulas <- function(MST, data.univ, type, copulaSelectionBy,
"fit.ACopula",
"BiCopSelect")) %dopar%
pcSelect(pc.data[[i]],
type,
copulaSelectionBy,
testForIndependence,
testForIndependence.level,
se,
familyset,
selectioncrit,
indeptest,
level,
weights,
se,
presel,
method)
} else {
pc.fits <- lapply(X = pc.data,
FUN = pcSelect,
type,
copulaSelectionBy,
testForIndependence,
testForIndependence.level,
se,
familyset,
selectioncrit,
indeptest,
level,
weights,
se,
presel,
method)
}

Expand All @@ -627,10 +642,10 @@ fit.FirstTreeCopulas <- function(MST, data.univ, type, copulaSelectionBy,
}

## fit pair-copulas for vine trees 2,...
fit.TreeCopulas <- function(MST, oldVineGraph, type, copulaSelectionBy,
testForIndependence, testForIndependence.level,
se = se, progress, weights = NA, method = "mle",
cores = 1) {
fit.TreeCopulas <- function(MST, oldVineGraph, familyset, selectioncrit,
indeptest, level,
progress, weights = NA, se = FALSE, presel = TRUE,
method = "mle", cores = 1) {

## initialize estimation results with empty list
d <- nrow(MST$E$nums)
Expand Down Expand Up @@ -697,22 +712,24 @@ fit.TreeCopulas <- function(MST, oldVineGraph, type, copulaSelectionBy,
.export = c("pcSelect", "fit.ACopula"),
.packages = "VineCopula") %dopar%
pcSelect(pc.data[[i]],
type,
copulaSelectionBy,
testForIndependence,
testForIndependence.level,
se,
familyset,
selectioncrit,
indeptest,
level,
weights,
se,
presel,
method)
} else {
pc.fits <- lapply(X = pc.data,
FUN = pcSelect,
type,
copulaSelectionBy,
testForIndependence,
testForIndependence.level,
se,
familyset,
selectioncrit,
indeptest,
level,
weights,
se,
presel,
method)
}

Expand Down Expand Up @@ -862,18 +879,17 @@ getEdgeInfo <- function(i, g, oldVineGraph, treecrit, weights,
}


pcSelect <- function(parameterForACopula, type, ...) {
pcSelect <- function(parameterForACopula, ...) {
return(fit.ACopula(parameterForACopula$zr1,
parameterForACopula$zr2,
type,
...))
}


## bivariate copula selection
fit.ACopula <- function(u1, u2, familyset = NA, selectioncrit = "AIC",
indeptest = FALSE, level = 0.05, se = FALSE,
weights = NA, method = "mle") {
indeptest = FALSE, level = 0.05, weights = NA,
se = FALSE, presel = TRUE, method = "mle") {

## select family and estimate parameter(s) for the pair copula
complete.i <- which(!is.na(u1 + u2))
Expand All @@ -896,13 +912,14 @@ fit.ACopula <- function(u1, u2, familyset = NA, selectioncrit = "AIC",
}
} else {
out <- suppressWarnings(BiCopSelect(u1[complete.i], u2[complete.i],
familyset,
selectioncrit,
indeptest,
level,
familyset = familyset,
selectioncrit = selectioncrit,
indeptest = indeptest,
level = level,
weights = weights,
rotations = FALSE,
rotations = FALSE, # see prep_familyset
se = se,
presel = presel,
method = method))
out$warn <- NULL
}
Expand Down
15 changes: 11 additions & 4 deletions man/RVineCopSelect.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

12 changes: 8 additions & 4 deletions man/RVineStructureSelect.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit cc8b621

Please sign in to comment.