Release 0.5.3.1.0 (#220)

* catch na in ktau_to_par (#214)

* make AIC default selection criterion (#213)

* Allow 1-dimensional models (#216)

* Better structures (#203)

* fix tau->par for frank (#207)

* some typos and doc formatting (#208)

* switch to github actions (#204)

Co-authored-by: Thibault Vatter <[email protected]>

.Rbuildignore

@@ -16,3 +16,4 @@
 ^docs$
 .github/
 
+^\.github$

.github/.gitignore

@@ -0,0 +1 @@
+*.html

.github/workflows/R-CMD-check.yaml

@@ -1,3 +1,9 @@
+# NOTE: This workflow is overkill for most R packages
+# check-standard.yaml is likely a better choice
+# usethis::use_github_action("check-standard") will install it.
+#
+# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag.
+# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions
 on: [push, pull_request]
 
 name: R-CMD-check
@@ -12,58 +18,83 @@ jobs:
       fail-fast: false
       matrix:
         config:
-        - { os: windows-latest, r: '4.0', args: "--no-manual"}
-        - { os: macOS-latest, r: 'devel', args: "--no-manual"}
-        - { os: ubuntu-16.04, r: '3.6', args: "--no-manual" }
-        - { os: ubuntu-16.04, r: '4.0', args: "--no-manual" }
+          - {os: macOS-latest,   r: 'release'}
+          - {os: windows-latest, r: 'release'}
+          - {os: ubuntu-16.04,   r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest", http-user-agent: "R/4.0.0 (ubuntu-16.04) R (4.0.0 x86_64-pc-linux-gnu x86_64 linux-gnu) on GitHub Actions" }
+          - {os: ubuntu-16.04,   r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
+          - {os: ubuntu-16.04,   r: 'oldrel',  rspm: "https://packagemanager.rstudio.com/cran/__linux__/xenial/latest"}
 
     env:
       R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
-      CRAN: ${{ matrix.config.cran }}
+      RSPM: ${{ matrix.config.rspm }}
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
 
     steps:
-      - uses: actions/checkout@v1
+      - uses: actions/checkout@v2
 
       - uses: r-lib/actions/setup-r@master
         with:
           r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
 
       - uses: r-lib/actions/setup-pandoc@master
 
-      - uses: r-lib/actions/setup-tinytex@master
-        if: contains(matrix.config.args, 'no-manual') == false
+      - name: Query dependencies
+        run: |
+          install.packages('remotes')
+          saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2)
+          writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version")
+        shell: Rscript {0}
 
       - name: Cache R packages
         if: runner.os != 'Windows'
         uses: actions/cache@v1
         with:
           path: ${{ env.R_LIBS_USER }}
-          key: ${{ runner.os }}-r-${{ matrix.config.r }}-${{ hashFiles('DESCRIPTION') }}
+          key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}
+          restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-
 
       - name: Install system dependencies
         if: runner.os == 'Linux'
-        env:
-          RHUB_PLATFORM: linux-x86_64-ubuntu-gcc
         run: |
-          Rscript -e "install.packages('remotes')" -e "remotes::install_github('r-hub/sysreqs')"
-          sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))")
-          sudo -s eval "$sysreqs"
+          while read -r cmd
+          do
+            eval sudo $cmd
+          done < <(Rscript -e 'cat(remotes::system_requirements("ubuntu", "16.04"), sep = "\n")')
 
       - name: Install dependencies
-        run: Rscript -e "install.packages('remotes')" -e "remotes::install_deps(dependencies = TRUE)" -e "remotes::install_cran('rcmdcheck')"
+        run: |
+          remotes::install_deps(dependencies = TRUE)
+          remotes::install_cran("rcmdcheck")
+        shell: Rscript {0}
+
+      - name: Session info
+        run: |
+          options(width = 100)
+          pkgs <- installed.packages()[, "Package"]
+          sessioninfo::session_info(pkgs, include_base = TRUE)
+        shell: Rscript {0}
 
       - name: Check
-        run: Rscript -e "rcmdcheck::rcmdcheck(args = '${{ matrix.config.args }}', error_on = 'warning', check_dir = 'check')"
+        env:
+          _R_CHECK_CRAN_INCOMING_: false
+        run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check")
+        shell: Rscript {0}
+
+      - name: Show testthat output
+        if: always()
+        run: find check -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
 
       - name: Upload check results
         if: failure()
-        uses: actions/upload-artifact@master
+        uses: actions/upload-artifact@main
         with:
           name: ${{ runner.os }}-r${{ matrix.config.r }}-results
           path: check
 
       - name: Test coverage
-        if: matrix.config.os == 'macOS-latest' && matrix.config.r == '3.6'
+        if: matrix.config.os == 'macOS-latest' && matrix.config.r == 'release'
         run: |
           Rscript -e 'remotes::install_github("r-lib/covr@gh-actions")'
           Rscript -e 'covr::codecov(line_exclusion = list.files(recursive = TRUE)[grep("^(?!.*wrappers).*\\\.(hpp|h|cpp|c|ipp)$", list.files(recursive = TRUE), perl = TRUE)], token = "${{secrets.CODECOV_TOKEN}}")'

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: rvinecopulib
 Type: Package
 Title: High Performance Algorithms for Vine Copula Modeling
-Version: 0.5.2.1.0
+Version: 0.5.3.1.0
 Authors@R: c(
         person("Thomas", "Nagler",, "[email protected]", role = c("aut", "cre")),
         person("Thibault", "Vatter",, "[email protected]", role = c("aut"))
@@ -45,4 +45,4 @@ LinkingTo:
 BugReports: https://github.com/vinecopulib/rvinecopulib/issues
 Roxygen: list(markdown = TRUE)
 SystemRequirements: C++11
-RoxygenNote: 7.1.0
+RoxygenNote: 7.1.1

NEWS.md

@@ -1,3 +1,24 @@
+# rvinecopulib 0.5.3.1.0 (August 11, 2020)
+
+Release following the updates of vinecopulib to 0.5.3, see 
+https://github.com/vinecopulib/vinecopulib/releases. The most 
+relevant changes are summarized below.
+
+### NEW FEATURES
+
+  * allow 1-dimensional models (#216) 
+
+  * make AIC default selection criterion (#213)
+
+### BUG FIXES
+
+  * catch na in ktau_to_par (#214)
+
+  * make Bicop/Vinecop objects indepent of copied-from-objects
+
+  * enforce parameters bounds in tau_to_parameters for Archimedean families
+
+
 # rvinecopulib 0.5.2.1.0 (May 7, 2020)
 
 Release following the updates of vinecopulib to 0.5.2, see 

R/as_rvine_structure.R

@@ -114,7 +114,8 @@ as_rvine_matrix.rvine_structure <- function(x, ..., validate = FALSE) {
   matrix <- matrix(0, d, d)
 
   # fill output
-  diag(matrix[d:1, ]) <- order
+  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

R/bicop.R

@@ -114,7 +114,7 @@
 #' @export
 bicop <- function(data, var_types = c("c", "c"), family_set = "all",
                   par_method = "mle", nonpar_method = "quadratic", mult = 1,
-                  selcrit = "bic", weights = numeric(), psi0 = 0.9,
+                  selcrit = "aic", weights = numeric(), psi0 = 0.9,
                   presel = TRUE, keep_data = FALSE, cores = 1) {
   assert_that(
     is.character(family_set),

R/bicop_methods.R

@@ -168,6 +168,7 @@ par_to_ktau <- function(family, rotation, parameters) {
 #' @param tau Kendall's \eqn{\tau}.
 #' @export
 ktau_to_par <- function(family, tau) {
+  assert_that(is.number(tau), !is.na(tau))
   bicop <- args2bicop(family)
   if (!(bicop$family %in% family_set_rotationless)) {
     bicop$rotation <- ifelse(tau > 0, 0, 90)

R/getters.R

@@ -162,9 +162,8 @@ get_all_pair_copulas <- function(object, trees = NA) {
   if (!any(is.na(trees))) {
     assert_that(is.numeric(trees),
       all(trees >= 1),
-      all(trees <= d[2]),
-      msg = "the elements of trees should be numbers between 1 and
-                    the truncation level."
+      all(trees <= d[1] - 1),
+      msg = "the elements of trees should be numbers between 1 and d - 1."
     )
   }
 

R/rosenblatt.R

@@ -55,10 +55,12 @@
 #' @export
 rosenblatt <- function(x, model, cores = 1) {
   assert_that(
-    is.matrix(x) | is.data.frame(x),
     inherits(model, c("bicop_dist", "vinecop_dist", "vine_dist")),
     is.number(cores)
   )
+
+  to_col <- if (inherits(model, "bicop_dist")) FALSE else (dim(model)[1] == 1)
+  x <- if_vec_to_matrix(x, to_col)
   col_names <- colnames(x)
 
   if (inherits(model, "bicop_dist")) {
@@ -84,11 +86,13 @@ rosenblatt <- function(x, model, cores = 1) {
 #' @export
 inverse_rosenblatt <- function(u, model, cores = 1) {
   assert_that(
-    is.matrix(u) | is.data.frame(u),
     all((u > 0) & (u < 1)),
     inherits(model, c("bicop_dist", "vinecop_dist", "vine_dist")),
     is.number(cores)
   )
+
+  to_col <- if (inherits(model, "bicop_dist")) FALSE else (dim(model)[1] == 1)
+  u <- if_vec_to_matrix(u, to_col)
   col_names <- colnames(u)
 
   if (inherits(model, "bicop_dist")) {

R/tools.R

@@ -77,7 +77,7 @@ expand_family <- function(family) {
   switch(
     family,
     "archimedean" = family_set_archimedean,
-    "ellipiltical" = family_set_elliptical,
+    "elliptical" = family_set_elliptical,
     "bbs" = family_set_bb,
     "oneparametric" = family_set_onepar,
     "twoparametric" = family_set_twopar,

R/truncate_model.R

@@ -99,12 +99,13 @@ truncate_column <- function(column, trunc_lvl) {
 #' @noRd
 check_trunc_lvl <- function(object, trunc_lvl) {
   msg <- paste0(
-    "trunc_lvl should be a number between 1 and the number of trees (",
+    "trunc_lvl should be a number between 0 and the number of trees (",
     dim(object)["dim"] - 1, ")."
   )
   assert_that(
-    is.count(trunc_lvl),
-    trunc_lvl >= 1,
+    is.number(trunc_lvl),
+    trunc_lvl == round(trunc_lvl),
+    trunc_lvl >= 0,
     trunc_lvl < dim(object)["dim"],
     msg = msg
   )

R/vine.R

@@ -95,7 +95,7 @@ vine <- function(data,
                    par_method = "mle",
                    nonpar_method = "constant",
                    mult = 1,
-                   selcrit = "bic",
+                   selcrit = "aic",
                    psi0 = 0.9,
                    presel = TRUE,
                    trunc_lvl = Inf,
@@ -109,7 +109,6 @@ vine <- function(data,
                  keep_data = FALSE,
                  cores = 1) {
   ## basic sanity checks (copula_controls are checked by vinecop)
-  assert_that(NCOL(data) > 1, msg = "data must be multivariate.")
   data <- expand_factors(data)
 
   d <- ncol(data)

R/vinecop.R

@@ -110,9 +110,9 @@
 #' # we require two types of observations (see Details)
 #' u_disc <- cbind(ppois(x, 1), u[, 2:5], ppois(x - 1, 1))
 #' fit <- vinecop(u_disc, var_types = c("d", rep("c", 4)))
-vinecop <- function(data, var_types = rep("c", ncol(data)), family_set = "all",
+vinecop <- function(data, var_types = rep("c", NCOL(data)), family_set = "all",
                     structure = NA, par_method = "mle",
-                    nonpar_method = "constant", mult = 1, selcrit = "bic",
+                    nonpar_method = "constant", mult = 1, selcrit = "aic",
                     weights = numeric(), psi0 = 0.9, presel = TRUE,
                     trunc_lvl = Inf, tree_crit = "tau", threshold = 0,
                     keep_data = FALSE, show_trace = FALSE, cores = 1) {
@@ -148,7 +148,7 @@ vinecop <- function(data, var_types = rep("c", ncol(data)), family_set = "all",
 
   ## fit and select copula model
   vinecop <- vinecop_select_cpp(
-    data = data,
+    data = as.matrix(data),
     structure = structure,
     family_set = family_set,
     par_method = par_method,
@@ -195,7 +195,7 @@ vinecop <- function(data, var_types = rep("c", ncol(data)), family_set = "all",
     tree_crit = tree_crit,
     threshold = threshold
   )
-  vinecop$nobs <- nrow(data)
+  vinecop$nobs <- NROW(data)
   vinecop
 }
 
@@ -248,7 +248,7 @@ vinecop <- function(data, var_types = rep("c", ncol(data)), family_set = "all",
 #' # simulate from the model
 #' pairs(rvinecop(200, vc))
 vinecop_dist <- function(pair_copulas, structure,
-                         var_types = rep("c", length(pair_copulas[[1]]) + 1)) {
+                         var_types = rep("c", dim(structure)[1])) {
   # create object
   vinecop <- structure(
     list(
@@ -260,8 +260,10 @@ vinecop_dist <- function(pair_copulas, structure,
 
   # sanity checks
   assert_that(is.list(pair_copulas), correct_var_types(var_types))
-  if (length(pair_copulas) > length(pair_copulas[[1]])) {
-    stop("'pair_copulas' has more trees than variables.")
+  if (length(pair_copulas) > 0) {
+    if (length(pair_copulas) > length(pair_copulas[[1]])) {
+      stop("'pair_copulas' has more trees than variables.")
+    }
   }
 
   pc_lst <- unlist(pair_copulas, recursive = FALSE)
@@ -275,7 +277,7 @@ vinecop_dist <- function(pair_copulas, structure,
   )
   vinecop$var_types <- var_types
   vinecop_check_cpp(vinecop)
-  vinecop$npars <- sum(sapply(pc_lst, function(x) x[["npars"]]))
+  vinecop$npars <- do.call(sum, lapply(pc_lst, function(x) x[["npars"]]))
   vinecop$loglik <- NA
 
   vinecop

R/vinecop_methods.R

@@ -69,7 +69,8 @@
 #' @export
 dvinecop <- function(u, vinecop, cores = 1) {
   assert_that(inherits(vinecop, "vinecop_dist"))
-  vinecop_pdf_cpp(if_vec_to_matrix(u), vinecop, cores)
+  u <- if_vec_to_matrix(u, dim(vinecop)[1] == 1)
+  vinecop_pdf_cpp(u, vinecop, cores)
 }
 
 #' @rdname vinecop_methods
@@ -81,7 +82,8 @@ pvinecop <- function(u, vinecop, n_mc = 10^4, cores = 1) {
     inherits(vinecop, "vinecop_dist"),
     is.number(n_mc), is.count(cores)
   )
-  vinecop_cdf_cpp(if_vec_to_matrix(u), vinecop, n_mc, cores, get_seeds())
+  u <- if_vec_to_matrix(u, dim(vinecop)[1] == 1)
+  vinecop_cdf_cpp(as.matrix(u), vinecop, n_mc, cores, get_seeds())
 }
 
 #' @rdname vinecop_methods
@@ -195,7 +197,7 @@ predict.vinecop <- function(object, newdata, what = "pdf", n_mc = 10^4,
     is.number(n_mc),
     is.number(cores), cores > 0
   )
-  newdata <- if_vec_to_matrix(newdata)
+  newdata <- if_vec_to_matrix(newdata, dim(object)[1] == 1)
   switch(
     what,
     "pdf" = vinecop_pdf_cpp(newdata, object, cores),
@@ -263,7 +265,7 @@ mBICV <- function(object, psi0 = 0.9, newdata = NULL) {
     object$loglik,
     sum(log(dvinecop(newdata, object)))
   )
-  -2 * ll + compute_mBICV_penalty(object, psi0)
+  - 2 * ll + compute_mBICV_penalty(object, psi0)
 }
 
 compute_mBICV_penalty <- function(object, psi0) {

R/vinecop_plot.R

@@ -256,6 +256,10 @@ contour.vinecop_dist <- function(x, tree = "ALL", cex.nums = 1, ...) {
   assert_that((length(tree) == 1 && tree == "ALL") || all(tree <= trunc_lvl),
     msg = "Selected tree does not exist."
   )
+  if (trunc_lvl == 0) {
+    warning("Model contains no pair copulas (trunc_lvl = 0).")
+    return(invisible(NULL))
+  }
 
   if (any(tree == "ALL")) {
     tree <- seq_len(trunc_lvl)

README.md

@@ -8,11 +8,11 @@ rvinecopulib
 
 Vine copulas are a flexible class of dependence models consisting of bivariate 
 building blocks (see e.g., Aas et al., 2009). You can find a comprehensive 
-list of publications and other materials on [vine-copula.org](http://www.statistics.ma.tum.de/en/research/vine-copula-models/).
+list of publications and other materials on [vine-copula.org](https://www.groups.ma.tum.de/en/statistics/research/vine-copula-models/).
 
 This package is the [R](https://cran.r-project.org/) API to the C++ library 
 [vinecopulib](https://github.com/vinecopulib/vinecopulib), a header-only 
-C++ library for vine copula models based on [Boost](http://www.boost.org/) and 
+C++ library for vine copula models based on [Boost](https://www.boost.org/) and 
 [Eigen](http://eigen.tuxfamily.org/index.php?title=Main_Page).
 
 It provides high-performance implementations of the core features of the popular