Nothing
#' Coerce various kind of objects to R-vine structures and matrices
#'
#' `as_rvine_structure` and `as_rvine_matrix` are new S3 generics allowing to
#' coerce objects into R-vine structures and matrices (see [rvine_structure()]
#' and [rvine_matrix()]).
#'
#' The coercion to `rvine_structure` and `rvine_matrix` can be applied to
#' different kind of objects Currently, `rvine_structure`, `rvine_matrix`,
#' `matrix` and `list` are supported.
#'
#' For `as_rvine_structure`:
#'
#' * `rvine_structure` : the main use case is to re-check an object via
#' `validate = TRUE`.
#' * `rvine_matrix` and `matrix` : allow to coerce matrices into R-vine
#' structures (see [rvine_structure()] for more details). The main difference
#' between `rvine_matrix` and `matrix` is the nature of the validity
#' checks.
#' * `list` : must contain named elements `order` and `struct_array` to be
#' coerced into an R-vine structure (see [rvine_structure()] for more details).
#'
#' For `as_rvine_matrix`:
#'
#' * `rvine_structure` : allow to coerce an `rvine_structure` into an
#' R-vine matrix (useful e.g. for printing).
#' * `rvine_matrix`: similar to `as_rvine_structure` for `rvine_structure`,
#' the main use case is to re-check an object via `validate = TRUE`.
#' * `matrix` : allow to coerce matrices into R-vine
#' matrices (mainly by checking that the matrix defines a valid
#' R-vine, see [rvine_matrix()] for more details).
#' * `list` : must contain named elements `order` and `struct_array` to be
#' coerced into an R-vine matrix (see [rvine_structure()] for more details).
#'
#' @param x An object of class `rvine_structure`, `rvine_matrix`, `matrix` or
#' `list` that can be coerced into an R-vine structure or R-vine matrix
#' (see *Details*).
#' @param ... Other arguments passed on to individual methods.
#' @return Either an object of class `rvine_structure` or of class
#' `rvine_matrix` (see [rvine_structure()] or [rvine_matrix()]).
#' @examples
#' # R-vine structures can be constructed from the order vector and struct_array
#' rvine_structure(order = 1:4, struct_array = list(
#' c(4, 4, 4),
#' c(3, 3),
#' 2
#' ))
#'
#' # ... or a similar list can be coerced into an R-vine structure
#' as_rvine_structure(list(order = 1:4, struct_array = list(
#' c(4, 4, 4),
#' c(3, 3),
#' 2
#' )))
#'
#' # similarly, standard matrices can be coerced into R-vine structures
#' mat <- matrix(c(4, 3, 2, 1, 4, 3, 2, 0, 4, 3, 0, 0, 4, 0, 0, 0), 4, 4)
#' as_rvine_structure(mat)
#'
#' # or truncate and construct the structure
#' mat[3, 1] <- 0
#' as_rvine_structure(mat)
#'
#' # throws an error
#' mat[3, 1] <- 5
#' try(as_rvine_structure(mat))
#' @seealso rvine_structure rvine_matrix
#' @rdname as_rvine_structure
#' @aliases as_rvine_matrix
#' @export
as_rvine_structure <- function(x, ...) {
UseMethod("as_rvine_structure")
}
#' @export
#' @rdname as_rvine_structure
as_rvine_matrix <- function(x, ...) {
UseMethod("as_rvine_matrix")
}
#' @param validate When `TRUE``, verifies that the input is a valid
#' rvine-structure (see *Details*). You may want to suppress this when you
#' know that you already have a valid structure and you want to save some time,
#' or to explicitly enable it if you have a structure that you want to re-check.
#' @export
#' @rdname as_rvine_structure
as_rvine_structure.rvine_structure <- function(x, ..., validate = FALSE) {
assert_that(is.flag(validate))
if (validate) {
validate_rvine_structure(x)
} else {
assert_that(is.rvine_structure(x))
}
x
}
#' @export
#' @rdname as_rvine_structure
as_rvine_matrix.rvine_structure <- function(x, ..., validate = FALSE) {
assert_that(is.flag(validate))
if (validate) {
validate_rvine_structure(x)
} else {
assert_that(is.rvine_structure(x))
}
# extract order and dimension
order <- x$order
d <- dim(x)[1]
trunc_lvl <- dim(x)[2]
# set-up output
matrix <- matrix(0, d, d)
# fill output
diag(matrix) <- order
matrix <- matrix[d:1, ]
for (i in seq_len(min(trunc_lvl, d - 1))) {
newrow <- order[x[["struct_array"]][[i]]]
matrix[i, 1:length(newrow)] <- newrow
}
class(matrix) <- c("rvine_matrix", class(matrix))
attr(matrix, "d") <- d
attr(matrix, "trunc_lvl") <- dim(x)[2]
matrix
}
#' @param is_natural_order A flag indicating whether the `struct_array` element
#' of `x` is assumed to be provided in natural order already (a structure is in
#' natural order if the anti-diagonal is 1, .., d from bottom left to top
#' right).
#' @export
#' @rdname as_rvine_structure
as_rvine_structure.list <- function(x, ..., is_natural_order = FALSE) {
assert_that(
is.list(x),
all(c("order", "struct_array") %in% names(x)),
is.flag(is_natural_order)
)
rvine_structure(
x[["order"]],
x[["struct_array"]],
is_natural_order
)
}
#' @export
#' @rdname as_rvine_structure
as_rvine_matrix.list <- function(x, ..., is_natural_order = FALSE) {
assert_that(
is.list(x),
all(c("order", "struct_array") %in% names(x)),
is.flag(is_natural_order)
)
rvine_struct <- rvine_structure(
x[["order"]],
x[["struct_array"]],
is_natural_order
)
as_rvine_matrix.rvine_structure(rvine_struct)
}
#' @export
#' @rdname as_rvine_structure
as_rvine_structure.rvine_matrix <- function(x, ..., validate = FALSE) {
assert_that(is.flag(validate))
if (validate) {
validate_rvine_matrix(x)
} else {
assert_that(is.rvine_matrix(x))
}
# compute structure array in natural order
d <- dim(x)[1]
order <- order(diag(x[d:1, ]))
struct_array <- lapply(1:(d - 1), function(i) order[x[i, 1:(d - i)]])
# create and return x
structure(list(
order = diag(x[d:1, ]),
struct_array = struct_array,
d = d,
trunc_lvl = dim(x)[2]
),
class = c("rvine_structure", "list")
)
}
#' @export
#' @rdname as_rvine_structure
as_rvine_matrix.rvine_matrix <- function(x, ..., validate = FALSE) {
assert_that(is.flag(validate))
if (validate) {
validate_rvine_matrix(x)
} else {
assert_that(is.rvine_matrix(x))
}
x
}
#' @export
#' @rdname as_rvine_structure
as_rvine_structure.matrix <- function(x, ..., validate = TRUE) {
x <- as_rvine_matrix(x, validate)
as_rvine_structure.rvine_matrix(x)
}
#' @export
#' @rdname as_rvine_structure
as_rvine_matrix.matrix <- function(x, ..., validate = TRUE) {
assert_that(is.flag(validate))
if (validate) {
x <- rvine_matrix(x)
} else {
assert_that(is.matrix(x) && is.numeric(x))
x <- rvine_matrix_nocheck(x)
}
x
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.