diff --git a/.Rbuildignore b/.Rbuildignore index 895c0da..c31d9cc 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -5,4 +5,15 @@ cran-comments.md README.md ^doc$ ^Meta$ -^figure$ \ No newline at end of file +^figure$ +^\.gitignore$ +^\.github$ +^_pkgdown\.yml$ +^pkgdown$ +^\.lintr$ +^FDboost\.Rcheck$ +^FDboost\.Rcheck/ +^.*\.tar\.gz$ +^\.codex$ +^docs$ +^docs/ diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 0000000..2d19fc7 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..6f083e3 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,61 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: R-CMD-check.yaml + +permissions: read-all + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - { os: macos-latest, r: "release" } + - { os: windows-latest, r: "release" } + - { os: ubuntu-latest, r: "devel", http-user-agent: "release" } + - { os: ubuntu-latest, r: "release" } + - { os: ubuntu-latest, r: "oldrel-1" } + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/setup-tinytex@v2 + env: + TINYTEX_INSTALLER: TinyTeX + + - name: Install additional LaTeX packages + run: | + tlmgr update --self + tlmgr install doublestroke relsize + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 0000000..83e9810 --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,49 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + release: + types: [published] + workflow_dispatch: + +name: pkgdown.yaml + +permissions: read-all + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::pkgdown, local::. + needs: website + + - name: Build site + run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) + shell: Rscript {0} + + - name: Deploy to GitHub pages 🚀 + if: github.event_name != 'pull_request' + uses: JamesIves/github-pages-deploy-action@v4.7.2 + with: + clean: false + branch: gh-pages + folder: docs diff --git a/.gitignore b/.gitignore index b9e21d8..2cb98fb 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,8 @@ /vignettes/*.gz doc Meta +FDboost.Rcheck/ +*.tar.gz +.codex +Rplots.pdf +docs/ diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 51a37e5..0000000 --- a/.travis.yml +++ /dev/null @@ -1,35 +0,0 @@ -# Sample .travis.yml for R projects. -# -# See README.md for instructions, or for more configuration options, -# see the wiki: -# https://github.com/craigcitro/r-travis/wiki - -language: r - - release - - devel -sudo: required -dist: bionic - -env: - - _R_S3_METHOD_LOOKUP_BASEENV_AFTER_GLOBALENV_=true - -repos: - CRAN: https://cloud.r-project.org - -r_github_packages: - - hofnerb/stabs - - boost-R/mboost - - boost-R/gamboostLSS - - jimhester/covr - - refunders/refund - -after_failure: - - ./travis-tool.sh dump_logs - -after_success: - - Rscript -e 'library(covr); coveralls()' - -notifications: - email: - on_success: change - on_failure: change diff --git a/DESCRIPTION b/DESCRIPTION index 17f9a88..939d948 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,47 +1,56 @@ -Package: FDboost Type: Package +Package: FDboost Title: Boosting Functional Regression Models -Version: 1.0-0 -Date: 2020-08-31 -Authors@R: c(person("Sarah", "Brockhaus", role = "aut", - email = "Sarah.Brockhaus@stat.uni-muenchen.de"), - person("David", "Ruegamer", role = c("aut", "cre"), - email = "david.ruegamer@gmail.com"), - person("Almond", "Stoecker", role = "aut", - email = "almond.stoecker@hu-berlin.de"), - person("Torsten", "Hothorn", role = "ctb"), - person("with contributions by many others", "(see inst/CONTRIBUTIONS)", role = "ctb")) -Maintainer: David Ruegamer -Description: Regression models for functional data, i.e., scalar-on-function, - function-on-scalar and function-on-function regression models, are fitted - by a component-wise gradient boosting algorithm. - For a manual on how to use 'FDboost', see Brockhaus, Ruegamer, Greven (2017) . +Version: 1.1-4 +Date: 2026-03-24 +Authors@R: c( + person("Sarah", "Brockhaus", , "Sarah.Brockhaus@stat.uni-muenchen.de", role = "aut", + comment = c(ORCID = "0000-0001-9484-7488")), + person("David", "Ruegamer", , "david.ruegamer@gmail.com", role = c("aut", "cre"), + comment = c(ORCID = "0000-0002-8772-9202")), + person("Almond", "Stoecker", , "almond.stoecker@hu-berlin.de", role = "aut", + comment = c(ORCID = "0000-0001-9160-2397")), + person("Torsten", "Hothorn", role = "ctb", + comment = c(ORCID = "0000-0001-8301-0471")), + person("with contributions by many others", "(see inst/CONTRIBUTIONS)", role = "ctb") + ) +Description: Regression models for functional data, i.e., + scalar-on-function, function-on-scalar and function-on-function + regression models, are fitted by a component-wise gradient boosting + algorithm. For a manual on how to use 'FDboost', see Brockhaus, + Ruegamer, Greven (2017) . +License: GPL-2 +URL: https://github.com/boost-R/FDboost +BugReports: https://github.com/boost-R/FDboost/issues Depends: - R (>= 3.5.0), - mboost (>= 2.9-0) + mboost (>= 2.9-0), + R (>= 3.5.0) Imports: - methods, + gamboostLSS (>= 2.0-0), graphics, grDevices, - utils, - stats, + MASS, Matrix, - gamboostLSS (>= 2.0-0), - stabs, + methods, mgcv, - MASS, + stabs, + stats, + utils, zoo Suggests: fda, fields, ggplot2, - maps, - mapdata, knitr, + mapdata, + maps, refund, testthat -License: GPL-2 -Packaged: 2020-06-20 12:19:33 UTC; brockhaus +VignetteBuilder: + knitr +Encoding: UTF-8 +Packaged: 2022-06-14 12:19:33 UTC; brockhaus +RoxygenNote: 7.3.2 Collate: 'aaa.R' 'FDboost-package.R' @@ -52,12 +61,9 @@ Collate: 'clr_functions.R' 'constrainedX.R' 'crossvalidation.R' + 'factorize.R' 'FDboostLSS.R' 'hmatrix.R' 'methods.R' 'stabsel.R' 'utilityFunctions.R' -RoxygenNote: 7.1.1 -BugReports: https://github.com/boost-R/FDboost/issues -URL: https://github.com/boost-R/FDboost -VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 6fca0e5..0b1790e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ S3method("[",hmatrix) S3method(coef,FDboost) S3method(cvrisk,FDboost) S3method(cvrisk,FDboostLSS) +S3method(factorize,FDboost) S3method(fitted,FDboost) S3method(getArgvals,hmatrix) S3method(getArgvalsLab,hmatrix) @@ -18,6 +19,7 @@ S3method(plot,FDboost) S3method(plot,bootstrapCI) S3method(plot,validateFDboost) S3method(predict,FDboost) +S3method(predict,FDboost_fac) S3method(print,FDboost) S3method(print,bootstrapCI) S3method(print,validateFDboost) @@ -44,6 +46,7 @@ export(bsignal) export(clr) export(cvLong) export(cvMa) +export(factorize) export(funMRD) export(funMSE) export(funRsquared) @@ -69,10 +72,13 @@ export(subset_hmatrix) export(truncateTime) export(validateFDboost) export(wide2long) +exportClasses(FDboost_fac) import(Matrix) import(mboost) import(methods) importFrom(MASS,Null) +importFrom(MASS,ginv) +importFrom(Matrix,rankMatrix) importFrom(gamboostLSS,GaussianLSS) importFrom(gamboostLSS,GaussianMu) importFrom(gamboostLSS,GaussianSigma) @@ -91,6 +97,7 @@ importFrom(graphics,par) importFrom(graphics,persp) importFrom(graphics,plot) importFrom(graphics,points) +importFrom(methods,setOldClass) importFrom(mgcv,gam) importFrom(mgcv,s) importFrom(parallel,mclapply) @@ -112,8 +119,10 @@ importFrom(stats,na.omit) importFrom(stats,predict) importFrom(stats,quantile) importFrom(stats,sd) +importFrom(stats,setNames) importFrom(stats,terms.formula) importFrom(stats,variable.names) importFrom(utils,getS3method) importFrom(utils,packageDescription) +importFrom(utils,relist) importFrom(zoo,na.locf) diff --git a/NEWS.md b/NEWS.md new file mode 100644 index 0000000..b372b57 --- /dev/null +++ b/NEWS.md @@ -0,0 +1,232 @@ +# FDboost 1.1-4 (2026-03-24) + +## Bug fixes + +- Suppressed deprecation warnings from `refund::pffrSim()` in examples to keep checks clean with recent `refund` versions. +- Stabilized `tests/general_tests.R` by forcing serial evaluation (`mc.cores = 1`) to avoid parallel `applyFolds()` crashes on some check platforms. + +# FDboost 1.1.0 (2022-07-12) + +## Miscellaneous + +- Anisotropic tensor-product operators `b1 %A0% b2` and `b1 %Xa0% b2` now also work when `lambda` is specified for `b1` and `df` is specified for `b2` (or vice versa). + +## New features + +- New function `clr()` to compute the centered-log-ratio transform and its inverse for density-on-scalar regression in Bayes spaces. +- New dataset `birthDistribution`. +- New vignette illustrating density-on-function regression on the `birthDistribution` data. +- Function `factorize()` added for tensor-product factorization of estimated effects or models. + +# FDboost 0.3.4 (2020-08-31) + +## Bug fixes + +- Fix `predict()` for `bsignal()` with `newdata` and the functional covariate given as a numeric matrix, raised in [#17](https://github.com/boost-R/FDboost/issues/17). +- Deprecated argument `LINPACK` in `solve()` removed. + +# FDboost 0.3.3 (2020-06-13) + +## New features + +- It is now possible to specify several time variables as well as factor time variables in the `timeformula`. This feature is needed for the manifoldboost package. + +## Miscellaneous + +- The function `stabsel.FDboost()` now uses `applyFolds()` instead of `validateFDboost()` to do cross-validation with recomputation of the smooth offset. This is only relevant for models with a functional response. This will change results if the model contains base-learners like `bbsc()` or `bolsc()`, as `applyFolds()` also recomputes the Z-matrix for those base-learners. + +## Bug fixes + +- Adapted functions `integrationWeights()` and `integrationWeightsLeft()` for unsorted time variables. +- Changed code in `predict.FDboost()` such that interaction effects of two functional covariates like `bsignal() %X% bsignal()` can be predicted with new data. +- Adapt FDboost to R 4.0.1 by explicitly using the first entry of `dots$aggregate` (i.e., `dots$aggregate[1] != "sum"`) in `predict.FDboost()` so that it also works with the default, where `aggregate` is a vector of length 3 and later only the first argument is used via `match.arg()`. + +# FDboost 0.3.2 (2018-08-04) + +## Bug fixes + +- Deprecated argument `corrected` in `cvrisk()` removed. + +# FDboost 0.3.1 (2018-05-10) + +## Bug fixes + +- `cvrisk()` has by default adequate folds for a noncyclic fitted FDboostLSS model, see [#14](https://github.com/boost-R/FDboost/issues/14). + +## Miscellaneous + +- Replaced `cBind()` (which is deprecated) with `cbind()`. + +# FDboost 0.3.0 (2017-05-31) + +## User-visible changes + +- New function `bootstrapCI()` to compute bootstrapped coefficients. +- Added the dataset `emotion` containing EEG and EMG measures under different experimental conditions. +- With scalar response, `FDboost()` now works with the response as a vector (instead of a 1-row matrix); thus, `fitted()` and `predict()` return a vector. + +## Bug fixes + +- `update.FDboost()` now works with a scalar response. +- `FDboost()` works with family `Binomial(type = "glm")`, see [#1](https://github.com/boost-R/FDboost/issues/1). +- `applyFolds()` works for factor response, see [#7](https://github.com/boost-R/FDboost/issues/7). +- `cvLong()` and `cvMA()` return a matrix for only one resampling fold with `B = 1` (proposed by Almond Stoecker). + +## Miscellaneous + +- Adapt `FDboost` to `mboost` 2.8-0, which allows for `mstop = 0`. +- Restructure `FDboostLSS()` such that it calls `mboostLSS_fit()` from `gamboostLSS` 2.0-0. +- In `FDboost`, set `options("mboost_indexmin" = +Inf)` to disable internal use of ties in model fitting, as this breaks some methods for models with responses in long format and for models containing `bhistx()`, see [#10](https://github.com/boost-R/FDboost/issues/10). +- Deprecated `validateFDboost()`, use `applyFolds()` and `bootstrapCI()` instead. + +# FDboost 0.2.0 (2016-05-26) + +## User-visible changes + +- Added function `applyFolds()` to compute the optimal stopping iteration. + +## Bug fixes + +- Allows for extrapolation in `predict()` with `bbsc()`. + +# FDboost 0.1.2 (2016-04-22) + +## Bug fixes + +- Fixed a bug in `bolsc()`: correctly use the index in `bolsc()`/`bbsc()`. Previously, each observation was used only once for computing Z. + +## User-visible changes + +- Added function `%Xa0%` that computes a row-tensor product of two base-learners where the penalty in one direction is zero. +- Added function `reweightData()` that computes the data for Bootstrap or cross-validation folds. +- Added function `stabsel.FDboost()` that refits the smooth offset in each fold. +- Added argument `fun` to `validateFDboost()`. +- Added `update.FDboost()` that overwrites `update.mboost()`. + +## Miscellaneous + +- `FDboost()` works with `family = Binomial()`. + +# FDboost 0.1.1 (2016-04-06) + +## Bug fixes + +- Fixed `oobpred` in `validateFDboost()` for irregular response and resampling at the curve level so that `plot.validateFDboost()` works for that case. +- Fixed scope of formula in `FDboost()`: now the formula given to `mboost()` within `FDboost()` uses the variables in the environment of the formula specified in `FDboost()`. + +## Miscellaneous + +- `plot.FDboost()` works for more effects, especially for effects like `bolsc() %X% bhistx()`. + +# FDboost 0.1.0 (2016-03-10) + +## User-visible changes + +- New operator `%A0%` for Kronecker product of two base-learners with an anisotropic penalty for the special case where `lambda1` or `lambda2` is zero. +- The base-learner `bbsc()` can be used with `center = TRUE` (derived by Almond Stoecker). +- In `FDboostLSS()`, a list of one-sided formulas can be specified for `timeformula`. + +## Bug fixes + +- `FDboostLSS()` works with `families = GammaLSS()`. + +## Miscellaneous + +- Operator `%A%` uses weights in the model call. This only works correctly for weights on the level of `blg1` and `blg2` (same as weights on rows and columns of the response matrix). +- Calls to internal functions of `mboost` are done using `mboost_intern()`. +- `hyper_olsc()` is based on `hyper_ols()` from `mboost`. + +# FDboost 0.0.17 (2016-02-25) + +## User-visible changes + +- Changed the operator `%Xc%` for the row tensor product of two scalar covariates. The design matrix of the interaction effects is constrained such that the interaction is centered around the intercept and around the two main effects of the scalar covariates (experimental!). Use, for example, `bols(x1) %Xc% bols(x2)`. + +# FDboost 0.0.16 (2016-02-22) + +## User-visible changes + +- Changed the operator `%Xc%` for row tensor product where the sum-to-zero constraint is applied to the design matrix resulting from the row-tensor product (experimental!). Specifically, an intercept-column is first added, and then the sum-to-zero constraint is applied. Use, for example, `bolsc(x1) %Xc% bolsc(x2)`. +- The functional index `s` is now used as `argsvals` in the FPCA conducted within `bfpc()`. + +# FDboost 0.0.15 (2016-02-12) + +## User-visible changes + +- New operator `%A%` that implies anisotropic penalties for differently specified `df` in the two base-learners. + +## Bug fixes + +- No penalty is applied in the direction of `ONEx` in a smooth intercept specified implicitly by `~1`, for example, `bols(ONEx, intercept=FALSE, df=1) %A% bbs(time)`. + +## Miscellaneous + +- Effects containing `%A%` or `%O%` are not expanded with the `timeformula`, allowing for different effects over time in the model. + +# FDboost 0.0.14 (2016-02-11) + +## User-visible changes + +- Added the function `FDboostLSS()` to fit GAMLSS models with functional data using R-package `gamboostLSS`. +- New operator `%Xc%` for row tensor product where the sum-to-zero constraint is applied to the design matrix resulting from the row-tensor product (experimental!). +- Allowed `newdata` to be a list in `predict.FDboost()` when used with signal base-learners. +- Expanded `coef.FDboost()` so that it works for 3-dimensional tensor products of the form `bhistx() %X% bolsc() %X% bolsc()` (with David Ruegamer). +- Added a new possibility for scalar-on-function regression: if `timeformula=NULL`, no Kronecker product with `1` is used, which changes the penalty (otherwise, the direction of `1` would also be penalized). + +## Miscellaneous + +- New dependency on R-package `gamboostLSS`. +- Removed dependency on R-package `MASS`. +- Used the argument `prediction` in the internal computation of the base-learners (work in progress). +- Throw an error if `timeLab` of the `hmatrix`-object in `bhistx()` is not equal to the time variable in `timeformula`. + +# FDboost 0.0.13 (2015-11-17) + +## User-visible changes + +- In function `FDboost()`, the offset is supplied differently. For a scalar offset, use `offset = "scalar"`. The default remains `offset = NULL`. +- `predict.FDboost()` has a new argument `toFDboost` (logical). +- `fitted.FDboost()` has argument `toFDboost` explicitly (not only via `...`). +- New base-learner `bhistx()`, especially suited for effects used with `%X%`, e.g., `bhistx() %X% bolsc()`. +- `coef.FDboost()` and `plot.FDboost()` now handle effects like `bhistx() %X% bolsc()`. +- For `predict.FDboost()` with effects `bhistx()` and newdata, the latest `mboostPatch` is necessary. + +## Bug fixes + +- The check for the necessity of a smooth offset works for missing values in a regular response (spotted by Tore Erdmann). + +# FDboost 0.0.12 (2015-09-15) + +- Internal experimental version. + +# FDboost 0.0.11 (2015-06-01) + +## User-visible changes + +- `integrationWeights()` now gives equal weights for regular grids. +- New base-learner `bfpc()` for a functional covariate where both the functional covariate and the coefficient are expanded using fPCA (experimental feature!). Only works for regularly observed functional covariate. + +## Bug fixes + +- `coef.FDboost()` only works for `bhist()` if the time variable is the same in the timeformula and in `bhist()`. +- `predict.FDboost()` now checks that only `type = "link"` can be predicted for newdata. + +# FDboost 0.0.10 (2015-04-16) + +## User-visible changes + +- Changed the default difference penalties to first-order difference (`differences = 1`), improving identifiability. +- New method `cvrisk.FDboost()` that uses (by default) sampling on the levels of curves, which is important for functional responses. +- Reorganized documentation of `cvrisk()` and `validateFDboost()`. +- In `bhist()`, an effect can be standardized. + +## Miscellaneous + +- Added a `CITATION` file. +- Uses `mboost 2.4-2`, which exports all important functions. + +## Bug fixes + +- `main` argument is always passed in `plot.FDboost()`. +- `bhist()` and `bconcurrent()` now work for equal `time` and `s`. +- `predict.FDboost()` works with tensor-product base-learners like `bl1 %X% bl2`. diff --git a/R/FDboost-package.R b/R/FDboost-package.R index 7213a60..624c794 100644 --- a/R/FDboost-package.R +++ b/R/FDboost-package.R @@ -1,73 +1,87 @@ ################################################################################# #' FDboost: Boosting Functional Regression Models -#' -#' @description -#' Regression models for functional data, i.e., scalar-on-function, -#' function-on-scalar and function-on-function regression models, are fitted +#' +#' @description +#' Regression models for functional data, i.e., scalar-on-function, +#' function-on-scalar and function-on-function regression models, are fitted #' by a component-wise gradient boosting algorithm. -#' -#' @details -#' This package is intended to fit regression models with functional variables. -#' It is possible to fit models with functional response and/or functional covariates, -#' resulting in scalar-on-function, function-on-scalar and function-on-function regression. +#' +#' @details +#' This package is intended to fit regression models with functional variables. +#' It is possible to fit models with functional response and/or functional covariates, +#' resulting in scalar-on-function, function-on-scalar and function-on-function regression. #' Furthermore, the package can be used to fit density-on-scalar regression models. #' Details on the functional regression models that can be fitted with \pkg{FDboost} -#' can be found in Brockhaus et al. (2015, 2017, 2018) and Ruegamer et al. (2018). -#' A hands-on tutorial for the package can be found -#' in Brockhaus, Ruegamer and Greven (2017), see \url{https://arxiv.org/abs/1705.10662}. +#' can be found in Brockhaus et al. (2015, 2017, 2018) and Ruegamer et al. (2018). +#' A hands-on tutorial for the package can be found +#' in Brockhaus, Ruegamer and Greven (2020), see . #' For density-on-scalar regression models see Maier et al. (2021). -#' -#' Using component-wise gradient boosting as fitting procedure, \pkg{FDboost} relies on -#' the R package \pkg{mboost} (Hothorn et al., 2017). -#' A comprehensive tutorial to \pkg{mboost} is given in Hofner et al. (2014). -#' -#' The main fitting function is \code{\link{FDboost}}. -#' The model complexity is controlled by the number of boosting iterations (mstop). -#' Like the fitting procedures in \pkg{mboost}, the function \code{FDboost} DOES NOT -#' select an appropriate stopping iteration. This must be chosen by the user. -#' The user can determine an adequate stopping iteration by resampling methods like -#' cross-validation or bootstrap. -#' This can be done using the function \code{\link{applyFolds}}. -#' -#' @references -#' Brockhaus, S., Ruegamer, D. and Greven, S. (2017): +#' +#' Using component-wise gradient boosting as fitting procedure, \pkg{FDboost} relies on +#' the R package \pkg{mboost} (Hothorn et al., 2017). +#' A comprehensive tutorial to \pkg{mboost} is given in Hofner et al. (2014). +#' +#' The main fitting function is \code{\link{FDboost}}. +#' The model complexity is controlled by the number of boosting iterations (mstop). +#' Like the fitting procedures in \pkg{mboost}, the function \code{FDboost} DOES NOT +#' select an appropriate stopping iteration. This must be chosen by the user. +#' The user can determine an adequate stopping iteration by resampling methods like +#' cross-validation or bootstrap. +#' This can be done using the function \code{\link{applyFolds}}. +#' +#' Aside from common effect surface plots, tensor product factorization via the +#' function \code{\link{factorize}} presents an alternative tool for visualization +#' of estimated effects for non-linear function-on-scalar models +#' (Stoecker, Steyer and Greven (2022), \url{https://arxiv.org/abs/2109.02624}). +#' After factorization, effects are decomposed multiple scalar effects into +#' functional main effect directions, which can be separately plotted allowing to +#' visualize more complex effect structures. +#' +#' +#' @references +#' Brockhaus, S., Ruegamer, D. and Greven, S. (2020): #' Boosting Functional Regression Models with FDboost. +#' Journal of Statistical Software, 94(10), 1–50. #' -#' -#' Brockhaus, S., Scheipl, F., Hothorn, T. and Greven, S. (2015): -#' The functional linear array model. Statistical Modelling, 15(3), 279-300. -#' -#' Brockhaus, S., Melcher, M., Leisch, F. and Greven, S. (2017): -#' Boosting flexible functional regression models with a high number of functional historical effects, -#' Statistics and Computing, 27(4), 913-926. -#' -#' Brockhaus, S., Fuest, A., Mayr, A. and Greven, S. (2018): -#' Signal regression models for location, scale and shape with an application to stock returns. +#' +#' Brockhaus, S., Scheipl, F., Hothorn, T. and Greven, S. (2015): +#' The functional linear array model. Statistical Modelling, 15(3), 279-300. +#' +#' Brockhaus, S., Melcher, M., Leisch, F. and Greven, S. (2017): +#' Boosting flexible functional regression models with a high number of functional historical effects, +#' Statistics and Computing, 27(4), 913-926. +#' +#' Brockhaus, S., Fuest, A., Mayr, A. and Greven, S. (2018): +#' Signal regression models for location, scale and shape with an application to stock returns. #' Journal of the Royal Statistical Society: Series C (Applied Statistics), 67, 665-686. -#' -#' Hothorn T., Buehlmann P., Kneib T., Schmid M., and Hofner B. (2017). mboost: Model-Based Boosting, +#' +#' Hothorn T., Buehlmann P., Kneib T., Schmid M., and Hofner B. (2017). mboost: Model-Based Boosting, #' R package version 2.8-1, \url{https://cran.r-project.org/package=mboost} -#' -#' Hofner, B., Mayr, A., Robinzonov, N., Schmid, M. (2014). Model-based Boosting in R: -#' A Hands-on Tutorial Using the R Package mboost. Computational Statistics, 29, 3-35. +#' +#' Hofner, B., Mayr, A., Robinzonov, N., Schmid, M. (2014). Model-based Boosting in R: +#' A Hands-on Tutorial Using the R Package mboost. Computational Statistics, 29, 3-35. #' \url{https://cran.r-project.org/package=mboost/vignettes/mboost_tutorial.pdf} -#' +#' #' Maier, E.-M., Stoecker, A., Fitzenberger, B., Greven, S. (2021): #' Additive Density-on-Scalar Regression in Bayes Hilbert Spaces with an Application to Gender Economics. #' arXiv preprint arXiv:2110.11771. -#' -#' Ruegamer D., Brockhaus, S., Gentsch K., Scherer, K., Greven, S. (2018). -#' Boosting factor-specific functional historical models for the detection of synchronization in bioelectrical signals. +#' +#' Ruegamer D., Brockhaus, S., Gentsch K., Scherer, K., Greven, S. (2018). +#' Boosting factor-specific functional historical models for the detection of synchronization in bioelectrical signals. #' Journal of the Royal Statistical Society: Series C (Applied Statistics), 67, 621-642. -#' -#' @author +#' +#' Stoecker A., Steyer L., Greven S. (2022): +#' Functional Additive Models on Manifolds of Planar Shapes and Forms. +#' arXiv preprint arXiv:2109.02624. +#' +#' @author #' Sarah Brockhaus, David Ruegamer and Almond Stoecker -#' +#' #' @aliases FDboost_package package-FDboost FDboost-package -#' -#' @seealso -#' \code{\link{FDboost}} for the main fitting function and -#' \code{\link{applyFolds}} for model tuning via resampling methods. -#' +#' +#' @seealso +#' \code{\link{FDboost}} for the main fitting function and +#' \code{\link{applyFolds}} for model tuning via resampling methods. +#' "_PACKAGE" -#> [1] "_PACKAGE" \ No newline at end of file + diff --git a/R/FDboost.R b/R/FDboost.R index 3284b83..16b68a6 100644 --- a/R/FDboost.R +++ b/R/FDboost.R @@ -5,7 +5,7 @@ #' are utilized as base-learners in the case of functional responses. #' Scalar responses are treated as the special case where each functional response has #' only one observation. -#' This function is a wrapper for \code{mboost}'s \code{\link{mboost}} and its +#' This function is a wrapper for \code{mboost}'s \code{\link[mboost]{mboost}} and its #' siblings to fit models of the general form #' \deqn{\xi(Y_i(t) | X_i = x_i) = \sum_{j} h_j(x_i, t), i = 1, ..., N,} #' with a functional (but not necessarily continuous) response \eqn{Y(t)}, @@ -52,7 +52,7 @@ #' @param check0 logical, for response in matrix form, i.e. response that is observed on a common grid, #' check the fitted effects for the sum-to-zero constraint #' \eqn{h_j(x_i)(t) = 0} for all \eqn{t} and give a warning if it is not fulfilled. Defaults to \code{FALSE}. -#' @param ... additional arguments passed to \code{\link{mboost}}, +#' @param ... additional arguments passed to \code{\link[mboost]{mboost}}, #' including, \code{family} and \code{control}. #' #' @details In matrix representation of functional response and covariates each row @@ -63,7 +63,7 @@ #' #' If it is possible to represent the model as a generalized linear array model #' (Currie et al., 2006), the array structure is used for an efficient implementation, -#' see \code{\link{mboost}}. This is only possible if the design +#' see \code{\link[mboost]{mboost}}. This is only possible if the design #' matrix can be written as the Kronecker product of two marginal design #' matrices yielding a functional linear array model (FLAM), #' see Brockhaus et al. (2015) for details. @@ -93,12 +93,12 @@ #' time-direction, use \code{timeformula = ~bols(1)}. In this case, a penalty in the #' time-direction is used, see Brockhaus et al. (2015) for details. #' Alternatively, the scalar response is fitted as scalar response, like in the function -#' \code{\link{mboost}} in package mboost. +#' \code{\link[mboost]{mboost}} in package mboost. #' The advantage of using \code{FDboost} in that case #' is that methods for the functional base-learners are available, e.g., \code{plot}. #' #' The desired regression type is specified by the \code{family}-argument, -#' see the help-page of \code{\link{mboost}}. For example a mean regression model is obtained by +#' see the help-page of \code{\link[mboost]{mboost}}. For example a mean regression model is obtained by #' \code{family = Gaussian()} which is the default or median regression #' by \code{family = QuantReg()}; #' see \code{\link[mboost]{Family}} for a list of implemented families. @@ -106,7 +106,7 @@ #' With \code{FDboost} the following covariate effects can be estimated by specifying #' the following effects in the \code{formula} #' (similar to function \code{\link[refund]{pffr}} -#' in R-package \code{\link[refund:refund-package]{refund}}). +#' in R-package refund. #' The \code{timeformula} is used to expand the effects in \code{t}-direction. #' \itemize{ #' \item Linear functional effect of scalar (numeric or factor) covariate \eqn{z} that varies @@ -176,7 +176,7 @@ #' @return An object of class \code{FDboost} that inherits from \code{mboost}. #' Special \code{\link{predict.FDboost}}, \code{\link{coef.FDboost}} and #' \code{\link{plot.FDboost}} methods are available. -#' The methods of \code{\link{mboost}} are available as well, +#' The methods of \code{\link[mboost]{mboost}} are available as well, #' e.g., \code{\link[mboost:methods]{extract}}. #' The \code{FDboost}-object is a named list containing: #' \item{...}{all elements of an \code{mboost}-object} @@ -198,7 +198,7 @@ #' #' @author Sarah Brockhaus, Torsten Hothorn #' -#' @seealso Note that \link{FDboost} calls \code{\link{mboost}} directly. +#' @seealso Note that \link{FDboost} calls \code{\link[mboost]{mboost}} directly. #' See, e.g., \code{\link[FDboost]{bsignal}} and \code{\link[FDboost]{bbsc}} #' for possible base-learners. #' @@ -431,8 +431,8 @@ #' @import methods Matrix mboost #' @importFrom grDevices heat.colors rgb #' @importFrom graphics abline barplot contour legend lines matplot par persp plot points -#' @importFrom utils getS3method packageDescription -#' @importFrom stats approx as.formula coef complete.cases fitted formula lm median model.matrix model.weights na.omit predict quantile sd terms.formula variable.names +#' @importFrom utils relist getS3method packageDescription +#' @importFrom stats setNames approx as.formula coef complete.cases fitted formula lm median model.matrix model.weights na.omit predict quantile sd terms.formula variable.names #' @importFrom gamboostLSS GaussianLSS GaussianMu GaussianSigma make.grid cvrisk.mboostLSS mboostLSS_fit #' @importFrom stabs stabsel stabsel_parameters #' @importFrom splines bs splineDesign @@ -456,54 +456,54 @@ FDboost <- function(formula, ### response ~ xvars ### save formula of FDboost before it is changed formulaFDboost <- formula - tf <- terms.formula(formula, specials = c("c")) + tf <- terms.formula(formula, specials = "c") trmstrings <- attr(tf, "term.labels") equalBrackets <- NULL if(length(trmstrings) > 0){ ## insert id at end of each base-learner - trmstrings2 <- paste(substr(trmstrings, 1 , nchar(trmstrings)-1), ", index=", id[2],")", sep = "") + trmstrings2 <- paste0(substr(trmstrings, 1 , nchar(trmstrings)-1), ", index=", id[2],")") ## check if number of opening brackets is equal to number of closing brackets - equalBrackets <- sapply(1:length(trmstrings2), function(i) + equalBrackets <- sapply(seq_along(trmstrings2), function(i) { - sapply(regmatches(trmstrings2[i], gregexpr("\\(", trmstrings2[i])), length) == - sapply(regmatches(trmstrings2[i], gregexpr("\\)", trmstrings2[i])), length) + lengths(regmatches(trmstrings2[i], gregexpr("(", trmstrings2[i], fixed = TRUE))) == + lengths(regmatches(trmstrings2[i], gregexpr(")", trmstrings2[i], fixed = TRUE))) }) } ## check formulas - if(class(try(id)) == "try-error") stop("id must either be NULL or a formula object.") - if(missing(timeformula) || class(try(timeformula)) == "try-error") + if(inherits(try(id), "try-error")) stop("id must either be NULL or a formula object.") + if(missing(timeformula) || inherits(try(timeformula), "try-error")) stop("timeformula must either be NULL or a formula object.") - stopifnot(class(formula) == "formula") - if(!is.null(timeformula)) stopifnot(class(timeformula) == "formula") + stopifnot(inherits(formula, "formula")) + if(!is.null(timeformula)) stopifnot(inherits(timeformula, "formula")) ## insert the id variable into the formula, to treat it like the other variables if(!is.null(id)){ - stopifnot(class(id) == "formula") + stopifnot(inherits(id, "formula")) ##tf <- terms.formula(formula, specials = c("c")) ##trmstrings <- attr(tf, "term.labels") ##equalBrackets <- NULL if(length(trmstrings) > 0){ ## insert index into the other base-learners of the tensor-product as well - for(i in 1:length(trmstrings)){ - if(grepl( "%X", trmstrings2[i])){ - temp <- unlist(strsplit(trmstrings2[i], "%X")) + for(i in seq_along(trmstrings)){ + if(grepl( "%X", trmstrings2[i], fixed = TRUE)){ + temp <- unlist(strsplit(trmstrings2[i], "%X", fixed = TRUE)) temp1 <- temp[-length(temp)] ## http://stackoverflow.com/questions/2261079 ## delete all trailing whitespace trim.trailing <- function (x) sub("\\s+$", "", x) temp1 <- trim.trailing(temp1) - temp1 <- paste(substr(temp1, 1 , nchar(temp1)-1), ", index=", id[2],")", sep = "") + temp1 <- paste0(substr(temp1, 1 , nchar(temp1)-1), ", index=", id[2],")") trmstrings2[i] <- paste0(paste0(temp1, collapse = " %X"), " %X", temp[length(temp)]) } ## do not add index to base-learners bhistx() - if( grepl("bhistx", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] + if( grepl("bhistx", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] ## do not add an index if an index is already part of the formula if( grepl("index[[:blank:]]*=", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] ## do not add an index if an index for %A%, %A0%, %O% - if( grepl("%A%", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] - if( grepl("%A0%", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] - if( grepl("%O%", trmstrings[i]) ) trmstrings2[i] <- trmstrings[i] + if( grepl("%A%", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] + if( grepl("%A0%", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] + if( grepl("%O%", trmstrings[i], fixed = TRUE) ) trmstrings2[i] <- trmstrings[i] ## do not add an index for base-learner that do not have brackets if( i %in% which(!equalBrackets) ) trmstrings2[i] <- trmstrings[i] } @@ -538,7 +538,7 @@ FDboost <- function(formula, ### response ~ xvars scalarResponse <- TRUE if(is.null(timeformula)) scalarNoFLAM <- TRUE - if(grepl("df", formula[3]) | !grepl("lambda", formula[3]) ){ + if(grepl("df", formula[3], fixed = TRUE) || !grepl("lambda", formula[3], fixed = TRUE) ){ timeformula <- ~bols(ONEtime, intercept = FALSE, df = 1) }else{ timeformula <- ~bols(ONEtime, intercept = FALSE) @@ -555,7 +555,7 @@ FDboost <- function(formula, ### response ~ xvars } - if(scalarResponse & !identical(numInt,"equal")) + if(scalarResponse && !identical(numInt,"equal")) stop("Integration weights numInt must be set to 'equal' for scalar response.") ## extract time(s) from timeformula @@ -582,7 +582,7 @@ FDboost <- function(formula, ### response ~ xvars allCovs <- unique(c(nameid, all.vars(formula))) if(length(allCovs) > 1){ data <- data[allCovs[!allCovs %in% c(yname, nameyind)] ] - if( any(is.na(names(data))) ) data <- data[ !is.na(names(data)) ] + if( anyNA(names(data)) ) data <- data[ !is.na(names(data)) ] }else{ data <- list(NULL) # intercept-model without covariates } @@ -621,7 +621,7 @@ FDboost <- function(formula, ### response ~ xvars nr <- nrow(response) if(!is.list(time)) stopifnot(ncol(response) == length(time)) else - stopifnot(all(ncol(response) == sapply(time[sapply(time, is.vector)], length))) + stopifnot(all(ncol(response) == lengths(time[sapply(time, is.vector)]))) nc <- ncol(response) dresponse <- as.vector(response) # column-wise stacking of response ## convert characters to factor @@ -633,11 +633,11 @@ FDboost <- function(formula, ### response ~ xvars stopifnot(is.null(dim(response))) ## stopifnot(is.vector(response)) # check length of response and its time and index if(is.list(time)) - stopifnot(all(length(response) == sapply(time, length)) & length(response) == length(id)) else + stopifnot(all(length(response) == lengths(time)) & length(response) == length(id)) else stopifnot(length(response) == length(time) & length(response) == length(id)) - if(any(is.na(response))) warning("For non-grid observations the response should not contain missing values.") - if( !all(sort(unique(id)) == 1:length(unique(id))) ) stop("id has to be integers 1, 2, 3,..., N.") + if(anyNA(response)) warning("For non-grid observations the response should not contain missing values.") + if( !all(sort(unique(id)) == seq_along(unique(id))) ) stop("id has to be integers 1, 2, 3,..., N.") nr <- length(response) # total number of observations nc <- length(unique(id)) # number of trajectories @@ -671,23 +671,23 @@ FDboost <- function(formula, ### response ~ xvars ## get formula over time tfm <- paste(deparse(timeformula), collapse = "") - tfm <- strsplit(tfm, "~")[[1]] - tfm <- strsplit(tfm[2], "\\+")[[1]] + tfm <- strsplit(tfm, "~", fixed = TRUE)[[1]] + tfm <- strsplit(tfm[2], "+", fixed = TRUE)[[1]] ## get formula in covariates cfm <- paste(deparse(formula), collapse = "") - cfm <- strsplit(cfm, "~")[[1]] + cfm <- strsplit(cfm, "~", fixed = TRUE)[[1]] cfm0 <- cfm #xfm <- strsplit(cfm[2], "\\+")[[1]] xfm <- trmstrings ## check that the timevariable in timeformula and in the bhistx-base-learners have the same name - if(any(grepl("bhistx", trmstrings))){ - for(j in 1:length(trmstrings)){ - if(any(grepl("bhistx", trmstrings[j]))){ - if(grepl("%X", trmstrings[j]) ){ + if(any(grepl("bhistx", trmstrings, fixed = TRUE))){ + for(j in seq_along(trmstrings)){ + if(any(grepl("bhistx", trmstrings[j], fixed = TRUE))){ + if(grepl("%X", trmstrings[j], fixed = TRUE) ){ temp <- strsplit(trmstrings[[j]], "%X.*%")[[1]] - temp <- temp[ grepl("bhistx", temp) ] + temp <- temp[ grepl("bhistx", temp, fixed = TRUE) ] ## pryr::standardise_call(quote(bhistx(X1h, df=3))) temp_name <- all.vars(formula(paste("~", temp)))[1] }else{ @@ -707,17 +707,17 @@ FDboost <- function(formula, ### response ~ xvars } } - yfm <- strsplit(cfm[1], "\\+")[[1]] ## name of response + yfm <- strsplit(cfm[1], "+", fixed = TRUE)[[1]] ## name of response ## set up formula for effects constant in time if(length(where.c) > 0){ # set c_df to the df/lambda in timeformula - if( grepl("lambda", tfm) || - ( grepl("bols", tfm) & !grepl("df", tfm)) ){ - c_lambda <- eval(parse(text = paste(tfm, "$dpp(rep(1.0,", length(time), "))$df()", sep = "")))["lambda"] + if( grepl("lambda", tfm, fixed = TRUE) || + ( grepl("bols", tfm, fixed = TRUE) && !grepl("df", tfm, fixed = TRUE)) ){ + c_lambda <- eval(parse(text = paste0(tfm, "$dpp(rep(1.0,", length(time), "))$df()")))["lambda"] cfm <- paste("bols(ONEtime, intercept = FALSE, lambda = ", c_lambda ,")") } else{ - c_df <- eval(parse(text=paste(tfm, "$dpp(rep(1.0,", length(time), "))$df()", sep = "")))["df"] + c_df <- eval(parse(text=paste0(tfm, "$dpp(rep(1.0,", length(time), "))$df()")))["df"] cfm <- paste("bols(ONEtime, intercept = FALSE, df = ", c_df ,")") } } @@ -737,28 +737,28 @@ FDboost <- function(formula, ### response ~ xvars } else{ which_equalBrackets <- which(equalBrackets) } - xfmTemp <- paste(substr(xfm[which_equalBrackets], 1 , - nchar(xfm[which_equalBrackets]) - 1 ), ")", sep = "") # , index=id is done in the beginning + xfmTemp <- paste0(substr(xfm[which_equalBrackets], 1 , + nchar(xfm[which_equalBrackets]) - 1 ), ")") # , index=id is done in the beginning xfm[which_equalBrackets] <- xfmTemp rm(xfmTemp) tmp <- outer(xfm, tfm, function(x, y) paste(x, y, sep = "%X%")) } # do not expand an effect bconcurrent() or bhist() with timeformula - if( length(c(grep("bconcurrent", tmp), grep("bhis", tmp)) ) > 0 ) - tmp[c(grep("bconcurrent", tmp), grep("bhist", tmp))] <- xfm[c(grep("bconcurrent", tmp), grep("bhist", tmp))] + if (any(grepl("bconcurrent|bhis", tmp))) + tmp[c(grep("bconcurrent", tmp, fixed = TRUE), grep("bhist", tmp, fixed = TRUE))] <- xfm[c(grep("bconcurrent", tmp, fixed = TRUE), grep("bhist", tmp, fixed = TRUE))] ## do not expand effects in formula including %A% with timeformula - if( length(grep("%A%", xfm)) > 0 ) - tmp[grep("%A%", xfm)] <- xfm[grep("%A%", xfm)] + if( any(grepl("%A%", xfm, fixed = TRUE)) ) + tmp[grep("%A%", xfm, fixed = TRUE)] <- xfm[grep("%A%", xfm, fixed = TRUE)] ## do not expand effects in formula including %A0% with timeformula - if( length(grep("%A0%", xfm)) > 0 ) - tmp[grep("%A0%", xfm)] <- xfm[grep("%A0%", xfm)] + if( any(grepl("%A0%", xfm, fixed = TRUE)) ) + tmp[grep("%A0%", xfm, fixed = TRUE)] <- xfm[grep("%A0%", xfm, fixed = TRUE)] ## do not expand effects in formula including %O% with timeformula - if( length(grep("%O%", xfm)) > 0 ) - tmp[grep("%O%", xfm)] <- xfm[grep("%O%", xfm)] + if( any(grepl("%O%", xfm, fixed = TRUE)) ) + tmp[grep("%O%", xfm, fixed = TRUE)] <- xfm[grep("%O%", xfm, fixed = TRUE)] ## expand with a constant effect in t-direction if(length(where.c) > 0){ @@ -781,7 +781,7 @@ FDboost <- function(formula, ### response ~ xvars get_df <- function(bl){ split_bl <- unlist(strsplit(bl, split = "%.{1,3}%")) all_df <- c() - for(i in 1:length(split_bl)){ + for(i in seq_along(split_bl)){ parti <- parse(text = split_bl[i])[[1]] parti <- expand.call(definition = get(as.character(parti[[1]])), call = parti) dfi <- parti$df # df of part i in bl @@ -817,7 +817,7 @@ FDboost <- function(formula, ### response ~ xvars }else{ bl_df <- vector("list", length(tmp)) bl_df[equalBrackets] <- lapply(tmp[equalBrackets], function(x) try(get_df(x))) - bl_df <- unlist(bl_df[equalBrackets & (!sapply(bl_df, class) %in% "try-error")]) + bl_df <- unlist(bl_df[equalBrackets & (!sapply(bl_df, function(x) inherits(x, "try-error")))]) #print(bl_df) if( !is.null(bl_df) && any(abs(bl_df - bl_df[1]) > .Machine$double.eps * 10^10) ){ @@ -833,11 +833,11 @@ FDboost <- function(formula, ### response ~ xvars ### replace "1" with intercept base learner formula_intercept <- FALSE - if ( any( gsub(" ", "", strsplit(cfm0[2], "\\+")[[1]]) == "1")){ + if ( any( gsub(" ", "", strsplit(cfm0[2], "+", fixed = TRUE)[[1]], fixed = TRUE) == "1")){ formula_intercept <- TRUE ## use df or lambda as in timeformula - if( any(grepl("lambda", deparse(timeformula))) || - any(( grepl("bols", deparse(timeformula)) & !grepl("df", deparse(timeformula)))) ){ + if( any(grepl("lambda", deparse(timeformula), fixed = TRUE)) || + any(( grepl("bols", deparse(timeformula), fixed = TRUE) & !grepl("df", deparse(timeformula), fixed = TRUE))) ){ tmp <- c("bols(ONEx, intercept = FALSE, lambda = 0)", tmp) } else{ tmp <- c("bols(ONEx, intercept = FALSE, df = 1)", tmp) @@ -879,9 +879,9 @@ FDboost <- function(formula, ### response ~ xvars ## get the limits argument current_bl <- attr(terms_fm_bhist, "variables")[[places_bhist[pl] + 1]] # for base-learner with interaction, find bhistx / bhist - if(any(grepl("%X", current_bl))){ + if(any(grepl("%X", current_bl, fixed = TRUE))){ #current_bl <- current_bl[ grepl("bhist", current_bl) ] - arg_limits <- eval(as.call(as.list(current_bl[grepl("bhist", current_bl)])[[1]])$limits) + arg_limits <- eval(as.call(as.list(current_bl[grepl("bhist", current_bl, fixed = TRUE)])[[1]])$limits) }else{ # limits argument of bhist / bhistx arg_limits <- eval(as.call(current_bl)$limits) @@ -944,7 +944,7 @@ FDboost <- function(formula, ### response ~ xvars ### multiply integration weights numInt to weights and w if(is.numeric(numInt)){ .numInt_len_check <- if(is.list(time)) - all(length(numInt) == sapply(time, length)) else + all(length(numInt) == lengths(time)) else length(numInt) == length(time) if(!.numInt_len_check) stop("Length of integration weights and time vector are not equal.") @@ -973,7 +973,7 @@ FDboost <- function(formula, ### response ~ xvars ### -> use one scalar/user-specified offset like in mboost ### in case of factor or multiple time variables set offset to 0 and give a warning - if(is.list(time) | !is.numeric(time)) { + if(is.list(time) || !is.numeric(time)) { .offsetwarning <- is.null(offset) if(!.offsetwarning) { .offsetwarning <- (offset == "scalar") @@ -1045,7 +1045,7 @@ FDboost <- function(formula, ### response ~ xvars } # meanY <- sapply(1:nc, function(i) offsetFun(responseInter[,i], 1*!is.na(responseInter[,i]))) - if( is.null(meanY) || any(is.na(meanY)) ){ + if( is.null(meanY) || anyNA(meanY) ){ warning("Mean offset cannot be computed by family@offset(). Use a weighted mean instead.") meanY <- c() for(i in 1:nc){ @@ -1066,7 +1066,7 @@ FDboost <- function(formula, ### response ~ xvars silent = offset_control$silent ) } - if(any(class(modOffset) == "try-error")){ + if(inherits(modOffset, "try-error")){ warning(paste("Could not fit the smooth offset by adaptive splines (default), use a simple spline expansion with 5 df instead.", if(offset_control$cyclic) "This offset is not cyclic!")) if(round(length(time)/2) < 8) warning("Most likely because of too few time-points.") @@ -1081,7 +1081,7 @@ FDboost <- function(formula, ### response ~ xvars offset <- as.vector(matrix(offsetVec, ncol = ncol(response), nrow = nrow(response), byrow = TRUE)) }else{ ### scalar response or mean-centered response -> one constant offset value is used - if(dim(response)[2] == 1 | all(colMeans(response, na.rm = TRUE) < .Machine$double.eps *10^10)){ + if(dim(response)[2] == 1 || all(colMeans(response, na.rm = TRUE) < .Machine$double.eps *10^10)){ offsetVec <- offset predictOffset <- offset }else{ @@ -1121,7 +1121,7 @@ FDboost <- function(formula, ### response ~ xvars silent = offset_control$silent ) } - if(any(class(modOffset) == "try-error")){ + if(inherits(modOffset, "try-error")){ warning(paste("Could not fit the smooth offset by adaptive splines (default), use a simple spline expansion with 5 df instead.", if(offset_control$cyclic) "This offset is not cyclic!")) if(round(length(time)/2) < 8) warning("Most likely because of too few time-points.") @@ -1163,10 +1163,10 @@ FDboost <- function(formula, ### response ~ xvars if(check0 && length(ret$baselearner) > 1 && is.null(id) && dim(response)[2] != 1){ # do not check the smooth intercept - if(any( gsub(" ", "", strsplit(cfm[2], "\\+")[[1]]) == "1")){ + if(any( gsub(" ", "", strsplit(cfm[2], "+", fixed = TRUE)[[1]], fixed = TRUE) == "1")){ effectsToCheck <- 2:length(ret$baselearner) }else{ - effectsToCheck <- 1:length(ret$baselearner) + effectsToCheck <- seq_along(ret$baselearner) } # predict each effect separately pred <- predict(ret, which = effectsToCheck) @@ -1188,7 +1188,7 @@ FDboost <- function(formula, ### response ~ xvars ## generate an id-variable for a regular response if(is.null(id)){ if(scalarResponse){ - id <- 1:NROW(response) + id <- seq_len(NROW(response)) }else{ id <- rep(1:ydim[1], times = ydim[2]) } diff --git a/R/FDboostLSS.R b/R/FDboostLSS.R index b07e5a8..f8461fb 100644 --- a/R/FDboostLSS.R +++ b/R/FDboostLSS.R @@ -19,10 +19,10 @@ #' @param data a data frame or list containing the variables in the model. #' @param families an object of class \code{families}. It can be either one of the pre-defined distributions #' that come along with the package \code{gamboostLSS} or a new distribution specified by the user -#' (see \code{\link{Families}} for details). -#' Per default, the two-parametric \code{\link{GaussianLSS}} family is used. +#' (see \code{\link[gamboostLSS]{Families}} for details). +#' Per default, the two-parametric \code{\link[gamboostLSS]{GaussianLSS}} family is used. #' @param control a list of parameters controlling the algorithm. -#' For more details see \code{\link{boost_control}}. +#' For more details see \code{\link[mboost]{boost_control}}. #' @param weights does not work! #' @param method fitting method, currently two methods are supported: #' \code{"cyclic"} (see Mayr et al., 2012) and \code{"noncyclic"} @@ -121,11 +121,12 @@ #' m_boost <- m_boost[mstop(cvr)] ## 832 #' #' ## plot smooth effects of functional covariates for mu and sigma -#' par(mfrow = c(1,2)) +#' oldpar <- par(mfrow = c(1,2)) #' plot(m_boost$mu, which = 2, ylim = c(0,5)) #' lines(s, sin(s*pi)*5, col = 3, lwd = 2) #' plot(m_boost$sigma, which = 2, ylim = c(-2.5,2.5)) #' lines(s, -cos(s*pi)*2, col = 3, lwd = 2) +#' par(oldpar) #' } #' } #' @export @@ -170,14 +171,14 @@ FDboostLSS <- function(formula, timeformula, data = list(), families = GaussianL #' defaults to 25 bootstrap samples, resampling whole curves #' @param grid defaults to a grid up to the current number of boosting iterations. #' The default generates the grid according to the defaults of -#' \code{\link{cvrisk.mboostLSS}} which are different for models with cyclic or noncyclic fitting. -#' @param papply (parallel) apply function, defaults to \code{\link{mclapply}}, -#' see \code{\link{cvrisk.mboostLSS}} for details. +#' \code{\link[gamboostLSS]{cvrisk.mboostLSS}} which are different for models with cyclic or noncyclic fitting. +#' @param papply (parallel) apply function, defaults to \code{\link[parallel]{mclapply}}, +#' see \code{\link[gamboostLSS]{cvrisk.mboostLSS}} for details. #' @param trace print status information during cross-validation? Defaults to \code{TRUE}. #' @param fun if \code{fun} is \code{NULL}, the out-of-sample risk is returned. #' \code{fun}, as a function of \code{object}, #' may extract any other characteristic of the cross-validated models. These are returned as is. -#' @param ... additional arguments passed to \code{\link{mclapply}}. +#' @param ... additional arguments passed to \code{\link[parallel]{mclapply}}. #' #' @details The function \code{cvrisk.FDboostLSS} is a wrapper for #' \code{cvrisk.mboostLSS} in package \code{gamboostLSS}. @@ -187,9 +188,9 @@ FDboostLSS <- function(formula, timeformula, data = list(), families = GaussianL #' @return An object of class \code{cvriskLSS} (when \code{fun} was not specified), #' basically a matrix containing estimates of the empirical risk for a varying number #' of bootstrap iterations. \code{plot} and \code{print} methods are available as well as an -#' \code{mstop} method, see \code{\link{cvrisk.mboostLSS}}. +#' \code{mstop} method, see \code{\link[gamboostLSS]{cvrisk.mboostLSS}}. #' -#' @seealso \code{\link{cvrisk.mboostLSS}} in +#' @seealso \code{\link[gamboostLSS]{cvrisk.mboostLSS}} in #' package \code{gamboostLSS}. #' #' @export @@ -208,7 +209,7 @@ cvrisk.FDboostLSS <- function(object, folds = cvLong(id = object[[1]]$id, ## set up grid according to defaults of cvrisk.nc_mboostLSS and cvrisk.mboostLSS if(is.null(grid)){ - if(any(class(object) == "nc_mboostLSS")){ + if(inherits(object, "nc_mboostLSS")){ grid <- 1:sum(mstop(object)) }else{ grid <- make.grid(mstop(object)) diff --git a/R/baselearners.R b/R/baselearners.R index 01ab85e..1844c62 100644 --- a/R/baselearners.R +++ b/R/baselearners.R @@ -65,6 +65,7 @@ #' xind2 <- xind + 0.5 #' integrationWeightsLeft(X1, xind2, leftWeight = "zero") #' +#' @return Matrix with integration #' @export ################################# # Trapezoidal integration weights for a functional variable X1 on grid xind @@ -123,11 +124,11 @@ integrationWeights <- function(X1, xind, id = NULL){ } # taking into account missing values - if(any(is.na(X1))){ - Lneu <- sapply(1:nrow(X1), function(i){ + if(anyNA(X1)){ + Lneu <- sapply(seq_len(nrow(X1)), function(i){ x <- X1[i,] - if(!any(is.na(x))){ + if(!anyNA(x)){ l <- L[i, ] # no missing values in curve i }else{ xindL <- xind # lower @@ -228,14 +229,14 @@ hyper_signal <- function(mf, vary, inS="smooth", knots = 10, boundary.knots = NU # stop("variable names and knot names must be the same") # if (is.list(boundary.knots)) if(!all(names(boundary.knots) %in% nm)) # stop("variable names and boundary.knot names must be the same") - if (!identical(center, FALSE) && cyclic) + if (!isFALSE(center) && cyclic) stop("centering of cyclic covariates not yet implemented") # ret <- vector(mode = "list", length = length(nm)) # names(ret) <- nm ret <- knotf(s, knots, boundary.knots) - if (cyclic & constraint != "none") + if (cyclic && constraint != "none") stop("constraints not implemented for cyclic B-splines") stopifnot(is.numeric(deriv) & length(deriv) == 1) @@ -272,7 +273,7 @@ X_bsignal <- function(mf, vary, args) { "linear" = matrix(c(rep(1, length(xind)), xind), ncol=2), "constant"= matrix(c(rep(1, length(xind))), ncol=1)) - colnames(Bs) <- paste(xname, 1:ncol(Bs), sep="") + colnames(Bs) <- paste0(xname, seq_len(ncol(Bs))) # use cyclic splines @@ -287,7 +288,7 @@ X_bsignal <- function(mf, vary, args) { fun = "cbs") } - colnames(Bs) <- paste(xname, 1:ncol(Bs), sep="") + colnames(Bs) <- paste0(xname, seq_len(ncol(Bs))) ### Penalty matrix: product differences matrix if (args$differences > 0){ @@ -342,7 +343,7 @@ X_bsignal <- function(mf, vary, args) { # Design matrix is product of weighted X1 and basis expansion over xind X <- (L*X1) %*% Bs - colnames(X) <- paste0(xname, 1:ncol(X)) + colnames(X) <- paste0(xname, seq_len(ncol(X))) ## see Scheipl and Greven (2016): ## Identifiability in penalized function-on-function regression models @@ -362,7 +363,7 @@ X_bsignal <- function(mf, vary, args) { ##################################################### ####### K <- crossprod(K) has been computed before! - if (!identical(args$center, FALSE)) { + if (!isFALSE(args$center)) { ### L = \Gamma \Omega^1/2 in Section 2.3. of ### Fahrmeir et al. (2004, Stat Sinica); "spectralDecomp" @@ -573,9 +574,8 @@ X_bsignal <- function(mf, vary, args) { #' + bsignal(NIR, nir.lambda, knots = 40, df=4, check.ident = FALSE), #' timeformula = NULL, data = fuelSubset) #' summary(mod2) -#' ## plot(mod2) -#' #' +#' #' ############################################### #' ### data simulation like in manual of pffr::ff #' @@ -585,7 +585,7 @@ X_bsignal <- function(mf, vary, args) { #' # model with linear functional effect, use bsignal() #' # Y(t) = f(t) + \int X1(s)\beta(s,t)ds + eps #' set.seed(2121) -#' data1 <- pffrSim(scenario = "ff", n = 40) +#' data1 <- suppressWarnings(pffrSim(scenario = "ff", n = 40)) #' data1$X1 <- scale(data1$X1, scale = FALSE) #' dat_list <- as.list(data1) #' dat_list$t <- attr(data1, "yindex") @@ -608,10 +608,11 @@ X_bsignal <- function(mf, vary, args) { #' m1_pffr <- pffr(Y ~ ff(X1, xind = s), yind = t, data = data1) #' #' \donttest{ -#' par(mfrow = c(2, 2)) +#' oldpar <- par(mfrow = c(2, 2)) #' plot(m1, which = 1); plot(m1, which = 2) #' plot(m1_pffr, select = 1, shift = m1_pffr$coefficients["(Intercept)"]) #' plot(m1_pffr, select = 2) +#' par(oldpar) #' } #' #' @@ -622,7 +623,7 @@ X_bsignal <- function(mf, vary, args) { #' mylimits <- function(s, t){ #' (s < t) | (s == t) #' } -#' data2 <- pffrSim(scenario = "ff", n = 40, limits = mylimits) +#' data2 <- suppressWarnings(pffrSim(scenario = "ff", n = 40, limits = mylimits)) #' data2$X1 <- scale(data2$X1, scale = FALSE) #' dat2_list <- as.list(data2) #' dat2_list$t <- attr(data2, "yindex") @@ -645,12 +646,12 @@ X_bsignal <- function(mf, vary, args) { #' m2_pffr <- pffr(Y ~ ff(X1, xind = s, limits = "s<=t"), yind = t, data = data2) #' #' \donttest{ -#' par(mfrow = c(2, 2)) +#' oldpar <- par(mfrow = c(2, 2)) #' plot(m2, which = 1); plot(m2, which = 2) #' ## plot of smooth intercept does not contain m1_pffr$coefficients["(Intercept)"] #' plot(m2_pffr, select = 1, shift = m2_pffr$coefficients["(Intercept)"]) #' plot(m2_pffr, select = 2) -#' +#' par(oldpar) #' } #' #' @@ -679,14 +680,14 @@ bsignal <- function(x, s, index = NULL, inS = c("smooth", "linear", "constant"), varnames <- all.vars(cll) # if(length(mfL)==1){ - # mfL[[2]] <- 1:ncol(mfL[[1]]); cll[[3]] <- "xind" + # mfL[[2]] <- seq_len(ncol(mfL[[1]])); cll[[3]] <- "xind" # varnames <- c(all.vars(cll), "xindDefault") # } # Reshape mfL so that it is the dataframe of the signal with the index as attribute xname <- varnames[1] indname <- varnames[2] - if(is.null(colnames(x))) colnames(x) <- paste(xname, 1:ncol(x), sep="_") + if(is.null(colnames(x))) colnames(x) <- paste(xname, seq_len(ncol(x)), sep="_") attr(x, "signalIndex") <- s attr(x, "xname") <- xname attr(x, "indname") <- indname @@ -700,7 +701,7 @@ bsignal <- function(x, s, index = NULL, inS = c("smooth", "linear", "constant"), if(is.null(Z) && all( abs(rowMeans(x, na.rm = TRUE)-mean(rowMeans(x, na.rm = TRUE))) < .Machine$double.eps *10^10)){ - message(paste("All trajectories in ", xname, " have the same mean. Coefficient function is centered.", sep="")) + message(paste0("All trajectories in ", xname, " have the same mean. Coefficient function is centered.")) } # mf <- mfL @@ -758,7 +759,7 @@ bsignal <- function(x, s, index = NULL, inS = c("smooth", "linear", "constant"), if(length(value) != names(mf[1])) stop(sQuote("value"), " must have same length as ", sQuote("names(mf[1])")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value @@ -839,7 +840,7 @@ X_conc <- function(mf, vary, args) { ## is that line still necessary? ## important for prediction, otherwise id=NULL and yind is multiplied accordingly - if(is.null(id)) id <- 1:nrow(X1) + if(is.null(id)) id <- seq_len(nrow(X1)) ## check yind if(args$format=="long" && length(yind)!=length(id)) stop(xname, ": Index of response and id do not have the same length") @@ -869,12 +870,12 @@ X_conc <- function(mf, vary, args) { fun = "cbs") } - colnames(Bs) <- paste(xname, 1:ncol(Bs), sep="") + colnames(Bs) <- paste0(xname, seq_len(ncol(Bs))) # set up design matrix for concurrent model if(args$format=="wide"){ listCol <- list() - for(i in 1:ncol(X1)){ + for(i in seq_len(ncol(X1))){ listCol[[i]] <- X1[,i] } X1des <- as.matrix(bdiag(listCol)) @@ -957,7 +958,7 @@ bconcurrent <- function(x, s, time, index = NULL, #by = NULL, attr(x, "id") <- index if(mboost_intern(x, fun = "isMATRIX") && - is.null(colnames(x))) colnames(x) <- paste(xname, 1:ncol(x), sep="_") + is.null(colnames(x))) colnames(x) <- paste(xname, seq_len(ncol(x)), sep="_") attr(x, "signalIndex") <- s attr(x, "xname") <- xname attr(x, "indname") <- indname @@ -1041,7 +1042,7 @@ bconcurrent <- function(x, s, time, index = NULL, #by = NULL, if(length(value) != names(mf[1])) stop(sQuote("value"), " must have same length as ", sQuote("names(mf[1])")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value @@ -1101,7 +1102,7 @@ hyper_hist <- function(mf, vary, knots = 10, boundary.knots = NULL, degree = 3, # stop("variable names and knot names must be the same") # if (is.list(boundary.knots)) if(!all(names(boundary.knots) %in% nm)) # stop("variable names and boundary.knot names must be the same") - if (!identical(center, FALSE) && cyclic) + if (!isFALSE(center) && cyclic) stop("centering of cyclic covariates not yet implemented") # ret <- vector(mode = "list", length = length(nm)) # names(ret) <- nm @@ -1115,7 +1116,7 @@ hyper_hist <- function(mf, vary, knots = 10, boundary.knots = NULL, degree = 3, boundary.knots[[n]] else boundary.knots) - if (cyclic & constraint != "none") + if (cyclic && constraint != "none") stop("constraints not implemented for cyclic B-splines") stopifnot(is.numeric(deriv) & length(deriv) == 1) @@ -1155,7 +1156,7 @@ X_hist <- function(mf, vary, args) { ## is that line still necessary? should it be there in long and wide format? ###### EXTRA LINE in comparison to X_hist ## important for prediction, otherwise id=NULL and yind is multiplied accordingly - if(is.null(id)) id <- 1:nrow(X1) + if(is.null(id)) id <- seq_len(nrow(X1)) ## check yind if(args$format=="long" && length(yind)!=length(id)) stop(xname, ": Index of response and id do not have the same length") @@ -1175,7 +1176,7 @@ X_hist <- function(mf, vary, args) { "linear" = matrix(c(rep(1, length(xind)), xind), ncol = 2), "constant"= matrix(c(rep(1, length(xind))), ncol = 1)) - colnames(Bs) <- paste(xname, 1:ncol(Bs), sep="") + colnames(Bs) <- paste0(xname, seq_len(ncol(Bs))) # integration weights L <- args$intFun(X1=X1, xind=xind) @@ -1187,7 +1188,7 @@ X_hist <- function(mf, vary, args) { # # set up design matrix for historical model and s<=t with s and t equal to xind # # expand matrix of original observations to lower triangular matrix # X1des0 <- matrix(0, ncol=ncol(X1), nrow=ncol(X1)*nrow(X1)) - # for(i in 1:ncol(X1des0)){ + # for(i in seq_len(ncol(X1des0))){ # #print(nrow(X1)*(i-1)+1) # X1des0[(nrow(X1)*(i-1)+1):nrow(X1des0) ,i] <- X1[,i] # use fun. variable * integration weights # } @@ -1253,7 +1254,7 @@ X_hist <- function(mf, vary, args) { # tempj <- unlist(apply(!ind0, 1, which)) # in which columns are the values? # ## i: row numbers: one row number per observation of response, # # repeat the row number for each entry - # X1des <- sparseMatrix(i=rep(1:length(id), times=rowSums(!ind0)), j=tempj, + # X1des <- sparseMatrix(i=rep(seq_along(id), times=rowSums(!ind0)), j=tempj, # x=X1[cbind(rep(id, t=rowSums(!ind0)), tempj)], dims=dim(ind0)) # # object.size(X1des) # rm(tempj) @@ -1359,7 +1360,7 @@ X_hist <- function(mf, vary, args) { # stack design-matrix of response nobs times in wide format if(args$format == "wide"){ - Bt <- Bt[rep(1:length(yind), each=nobs), ] + Bt <- Bt[rep(seq_along(yind), each=nobs), ] } if(! mboost_intern(Bt, fun = "isMATRIX") ) Bt <- matrix(Bt, ncol=1) @@ -1367,11 +1368,11 @@ X_hist <- function(mf, vary, args) { # calculate row-tensor # X <- (X1 %x% t(rep(1, ncol(X2))) ) * ( t(rep(1, ncol(X1))) %x% X2 ) dimnames(Bt) <- NULL # otherwise warning "dimnames [2] mismatch..." - X <- X1des[,rep(1:ncol(Bs), each=ncol(Bt))] * Bt[,rep(1:ncol(Bt), times=ncol(Bs))] + X <- X1des[, rep(seq_len(ncol(Bs)), each=ncol(Bt))] * Bt[, rep(seq_len(ncol(Bt)), times=ncol(Bs))] if(! mboost_intern(X, fun = "isMATRIX") ) X <- matrix(X, ncol=1) - colnames(X) <- paste0(xname, 1:ncol(X)) + colnames(X) <- paste0(xname, seq_len(ncol(X))) ### Penalty matrix: product differences matrix for smooth effect if(args$inS == "smooth"){ @@ -1473,7 +1474,7 @@ bhist <- function(x, s, time, index = NULL, #by = NULL, # compare range of index signal and index response # minimal value of the signal-index has to be smaller than the response-index if(!is.function(limits)){ - if(limits=="s<=t" & min(s) > min(time) ) stop("Index of response has values before index of signal.") + if(limits=="s<=t" && min(s) > min(time) ) stop("Index of response has values before index of signal.") } # Reshape mfL so that it is the dataframe of the signal with @@ -1482,7 +1483,7 @@ bhist <- function(x, s, time, index = NULL, #by = NULL, indname <- varnames[2] indnameY <- varnames[3] if(length(varnames)==2) indnameY <- varnames[2] - if(is.null(colnames(x))) colnames(x) <- paste(xname, 1:ncol(x), sep="_") + if(is.null(colnames(x))) colnames(x) <- paste(xname, seq_len(ncol(x)), sep="_") attr(x, "signalIndex") <- s attr(x, "xname") <- xname attr(x, "indname") <- indname @@ -1573,7 +1574,7 @@ bhist <- function(x, s, time, index = NULL, #by = NULL, if(length(value) != names(mf[1])) stop(sQuote("value"), " must have same length as ", sQuote("names(mf[1])")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value @@ -1665,7 +1666,7 @@ X_fpc <- function(mf, vary, args) { args$klX$xind <- xind ## only use part of the eigen-functions! - args$subset <- 1:min(ncol(klX$scores), args$npc.max) + args$subset <- seq_len(min(ncol(klX$scores), args$npc.max)) ## args$a <- max(xind) - min(xind) ## scores \xi_{ik}: rows i=1,..., N and columns k=1,...,K @@ -1688,7 +1689,7 @@ X_fpc <- function(mf, vary, args) { ##stop("In bfpc the grid for the functional covariate has to be the same as in the model fit!") ## linear interpolation of the basis functions approxEfunctions <- matrix(NA, nrow=length(xind), ncol=length(args$subset)) - for(i in 1:ncol(klX$efunctions[ , args$subset, drop = FALSE])){ + for(i in seq_len(ncol(klX$efunctions[, args$subset, drop = FALSE]))){ approxEfunctions[,i] <- approx(x=args$klX$xind, y=klX$efunctions[,i], xout=xind)$y } approxMu <- approx(x=args$klX$xind, y=klX$mu, xout=xind)$y @@ -1699,7 +1700,7 @@ X_fpc <- function(mf, vary, args) { } - colnames(X) <- paste(xname, ".PC", 1:ncol(X), sep = "") + colnames(X) <- paste0(xname, ".PC", seq_len(ncol(X))) ## set up the penalty matrix K <- switch(args$penalty, @@ -1746,7 +1747,7 @@ bfpc <- function(x, s, index = NULL, df = 4, # Reshape mfL so that it is the dataframe of the signal with the index as attribute xname <- varnames[1] indname <- varnames[2] - if(is.null(colnames(x))) colnames(x) <- paste(xname, 1:ncol(x), sep="_") + if(is.null(colnames(x))) colnames(x) <- paste(xname, seq_len(ncol(x)), sep="_") attr(x, "signalIndex") <- s attr(x, "xname") <- xname attr(x, "indname") <- indname @@ -1804,7 +1805,7 @@ bfpc <- function(x, s, index = NULL, df = 4, if(length(value) != names(mf[1])) stop(sQuote("value"), " must have same length as ", sQuote("names(mf[1])")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value @@ -1866,7 +1867,7 @@ X_bbsc <- function(mf, vary, args) { MATRIX <- MATRIX && options("mboost_useMatrix")$mboost_useMatrix if (MATRIX) { diag <- Diagonal - for (i in 1:length(mm)){ + for (i in seq_along(mm)){ tmp <- attributes(mm[[i]])[c("degree", "knots", "Boundary.knots")] mm[[i]] <- Matrix(mm[[i]]) attributes(mm[[i]])[c("degree", "knots", "Boundary.knots")] <- tmp @@ -1878,7 +1879,7 @@ X_bbsc <- function(mf, vary, args) { if (vary != "") { by <- model.matrix(as.formula(paste("~", vary, collapse = "")), data = mf)[ , -1, drop = FALSE] # drop intercept - DM <- lapply(1:ncol(by), function(i) { + DM <- lapply(seq_len(ncol(by)), function(i) { ret <- X * by[, i] colnames(ret) <- paste(colnames(ret), colnames(by)[i], sep = ":") ret @@ -1989,7 +1990,7 @@ X_bbsc <- function(mf, vary, args) { if (vary != "" && ncol(by) > 1){ # build block diagonal penalty suppressMessages(K <- kronecker(diag(ncol(by)), K)) } - if (!identical(args$center, FALSE)) { + if (!isFALSE(args$center)) { ### L = \Gamma \Omega^1/2 in Section 2.3. of Fahrmeir et al. ### (2004, Stat Sinica), always L <- eigen(K, symmetric = TRUE) @@ -2009,7 +2010,7 @@ X_bbsc <- function(mf, vary, args) { ### Calculate constraints ## for center = TRUE, design matrix does not contain constant part - if(args$center != FALSE){ + if(!isFALSE(args$center)){ ## center the columns of the design matrix ## Z contains column means @@ -2284,7 +2285,7 @@ bbsc <- function(..., by = NULL, index = NULL, knots = 10, boundary.knots = NULL if(length(value) != length(colnames(mf))) stop(sQuote("value"), " must have same length as ", sQuote("colnames(mf)")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value @@ -2336,8 +2337,8 @@ X_olsc <- function(mf, vary, args) { contr <- NULL } else { ### set up model matrix - fm <- paste("~ ", paste(colnames(mf)[colnames(mf) != vary], - collapse = "+"), sep = "") + fm <- paste0("~ ", paste(colnames(mf)[colnames(mf) != vary], + collapse = "+")) fac <- sapply(mf[colnames(mf) != vary], is.factor) DUMMY <- FALSE if (any(fac)){ @@ -2367,9 +2368,11 @@ X_olsc <- function(mf, vary, args) { args$contrasts.arg <- NULL } X <- model.matrix(as.formula(fm), data = mf, contrasts.arg = args$contrasts.arg) - if (DUMMY) + if (DUMMY) { attr(X, "contrasts") <- lapply(attr(X, "contrasts"), function(x) x <- "contr.dummy") + args$contrasts.arg <- "contr.dummy" + } contr <- attr(X, "contrasts") if (!args$intercept) X <- X[ , -1, drop = FALSE] @@ -2383,7 +2386,7 @@ X_olsc <- function(mf, vary, args) { if (vary != "") { by <- model.matrix(as.formula(paste("~", vary, collapse = "")), data = mf)[ , -1, drop = FALSE] # drop intercept - DM <- lapply(1:ncol(by), function(i) { + DM <- lapply(seq_len(ncol(by)), function(i) { ret <- X * by[, i] colnames(ret) <- paste(colnames(ret), colnames(by)[i], sep = ":") ret @@ -2516,9 +2519,9 @@ bolsc <- function(..., by = NULL, index = NULL, intercept = TRUE, df = NULL, if(is.null(index)){ if(is.null(weights)){ ## use weights - w <- 1:nrow(mf) + w <- seq_len(nrow(mf)) }else{ - w <- rep(1:nrow(mf), weights) + w <- rep(seq_len(nrow(mf)), weights) } temp <- X_olsc(mf[w, , drop = FALSE], vary, @@ -2528,9 +2531,9 @@ bolsc <- function(..., by = NULL, index = NULL, intercept = TRUE, df = NULL, }else{ if(is.null(weights)){ ## use weights - w <- 1:nrow(mf[index, , drop = FALSE]) + w <- seq_len(nrow(mf[index, , drop = FALSE])) }else{ - w <- rep(1:nrow(mf[index, , drop = FALSE]), weights) + w <- rep(seq_len(nrow(mf[index, , drop = FALSE])), weights) } temp <- X_olsc(mf = (mf[index, , drop = FALSE])[w, , drop = FALSE], vary = vary, @@ -2556,7 +2559,7 @@ bolsc <- function(..., by = NULL, index = NULL, intercept = TRUE, df = NULL, if(length(value) != length(colnames(mf))) stop(sQuote("value"), " must have same length as ", sQuote("colnames(mf)")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value @@ -2597,4 +2600,3 @@ brandomc <- function (..., contrasts.arg = "contr.dummy", df = 4) { ret } - diff --git a/R/baselearnersX.R b/R/baselearnersX.R index 1ce1e4d..eb8ceb6 100644 --- a/R/baselearnersX.R +++ b/R/baselearnersX.R @@ -32,7 +32,7 @@ hyper_histx <- function(mf, vary, knots = 10, boundary.knots = NULL, degree = 3, stop("variable names and knot names must be the same") if (is.list(boundary.knots)) if(!all(names(boundary.knots) %in% nm)) stop("variable names and boundary.knot names must be the same") - if (!identical(center, FALSE) && cyclic) + if (!isFALSE(center) && cyclic) stop("centering of cyclic covariates not yet implemented") ret <- vector(mode = "list", length = length(nm)) names(ret) <- nm @@ -40,7 +40,7 @@ hyper_histx <- function(mf, vary, knots = 10, boundary.knots = NULL, degree = 3, ret[[n]] <- knotf(getTime(mf[[n]]), knots=if(is.list(knots)) knots[[n]] else knots, boundary.knots = if(is.list(boundary.knots)) boundary.knots[[n]] else boundary.knots) - if (cyclic & constraint != "none") + if (cyclic && constraint != "none") stop("constraints not implemented for cyclic B-splines") stopifnot(is.numeric(deriv) & length(deriv) == 1) @@ -92,7 +92,7 @@ X_histx <- function(mf, vary, args) { "linear" = matrix(c(rep(1, length(xind)), xind), ncol = 2), "constant"= matrix(c(rep(1, length(xind))), ncol = 1)) - colnames(Bs) <- paste(xname, 1:ncol(Bs), sep="") + colnames(Bs) <- paste0(xname, seq_len(ncol(Bs))) # integration weights L <- args$intFun(X1=X1, xind=xind) @@ -234,11 +234,11 @@ X_histx <- function(mf, vary, args) { # calculate row-tensor # X <- (X1 %x% t(rep(1, ncol(X2))) ) * ( t(rep(1, ncol(X1))) %x% X2 ) dimnames(Bt) <- NULL # otherwise warning "dimnames [2] mismatch..." - X <- X1des[,rep(1:ncol(Bs), each=ncol(Bt))] * Bt[,rep(1:ncol(Bt), times=ncol(Bs))] + X <- X1des[, rep(seq_len(ncol(Bs)), each=ncol(Bt))] * Bt[, rep(seq_len(ncol(Bt)), times=ncol(Bs))] if(! mboost_intern(X, fun = "isMATRIX") ) X <- matrix(X, ncol=1) - colnames(X) <- paste0(xname, 1:ncol(X)) + colnames(X) <- paste0(xname, seq_len(ncol(X))) ### Penalty matrix: product differences matrix for smooth effect if(args$inS == "smooth"){ @@ -395,8 +395,8 @@ X_histx <- function(mf, vary, args) { #' ## the interaction effect is in this case not necessary #' n <- 100 #' nygrid <- 35 -#' data1 <- pffrSim(scenario = c("int", "ff"), limits = function(s,t){ s <= t }, -#' n = n, nygrid = nygrid) +#' data1 <- suppressWarnings(pffrSim(scenario = c("int", "ff"), limits = function(s,t){ s <= t }, +#' n = n, nygrid = nygrid)) #' data1$X1 <- scale(data1$X1, scale = FALSE) ## center functional covariate #' dataList <- as.list(data1) #' dataList$tvals <- attr(data1, "yindex") @@ -409,8 +409,8 @@ X_histx <- function(mf, vary, args) { #' dataList$X1h <- I(X1h) #' dataList$svals <- attr(data1, "xindex") #' ## add a factor variable -#' dataList$zlong <- factor(gl(n = 2, k = n/2, length = n*nygrid), levels = 1:3) -#' dataList$z <- factor(gl(n = 2, k = n/2, length = n), levels = 1:3) +#' dataList$zlong <- factor(gl(n = 2, k = n/2, length = n*nygrid), levels = 1:2) +#' dataList$z <- factor(gl(n = 2, k = n/2, length = n), levels = 1:2) #' #' ## do the model fit with main effect of bhistx() and interaction of bhistx() and bolsc() #' mod <- FDboost(Y ~ 1 + bhistx(x = X1h, df = 5, knots = 5) + @@ -522,7 +522,7 @@ bhistx <- function(x, if(length(value) != names(mf[1])) stop(sQuote("value"), " must have same length as ", sQuote("names(mf[1])")) - for (i in 1:length(value)){ + for (i in seq_along(value)){ cll[[i+1]] <<- as.name(value[i]) } attr(mf, "names") <<- value diff --git a/R/bootstrapCIs.R b/R/bootstrapCIs.R index 8ccf2b3..f83c90f 100644 --- a/R/bootstrapCIs.R +++ b/R/bootstrapCIs.R @@ -47,7 +47,7 @@ #' #' @note Note that parallelization can be achieved by defining #' the \code{resampling_fun_outer} or \code{_inner} accordingly. -#' See, e.g., \code{\link{cvrisk}} on how to parallelize resampling +#' See, e.g., \code{\link[mboost]{cvrisk}} on how to parallelize resampling #' functions or the examples below. Also note that by defining #' a custum inner or outer resampling function the respective #' argument \code{B_inner} or \code{B_outer} is ignored. @@ -77,7 +77,7 @@ #' # model with linear functional effect, use bsignal() #' # Y(t) = f(t) + \int X1(s)\beta(s,t)ds + eps #' set.seed(2121) -#' data1 <- pffrSim(scenario = "ff", n = 40) +#' data1 <- suppressWarnings(pffrSim(scenario = "ff", n = 40)) #' data1$X1 <- scale(data1$X1, scale = FALSE) #' dat_list <- as.list(data1) #' dat_list$t <- attr(data1, "yindex") @@ -101,25 +101,22 @@ #' plot(bootCIs, ask = FALSE) #' } #' -#' ## now speed things up by defining the inner resampling -#' ## function with parallelization based on mclapply (does not work on Windows) -#' #' my_inner_fun <- function(object){ #' cvrisk(object, folds = cvLong(id = object$id, weights = -#' model.weights(object), -#' B = 10 # 10-fold for inner resampling -#' ), mc.cores = 10) # use ten cores +#' model.weights(object), B = 2) # 10-fold for inner resampling +#' ) #' } #' #' \donttest{ -#' bootCIs <- bootstrapCI(m1, resampling_fun_inner = my_inner_fun) +#' bootCIs <- bootstrapCI(m1, resampling_fun_inner = my_inner_fun, +#' B_outer = 5) # small B_outer to speed up #' } #' #' ## We can also use the ... argument to parallelize the applyFolds #' ## function in the outer resampling #' #' \donttest{ -#' bootCIs <- bootstrapCI(m1, mc.cores = 30) +#' bootCIs <- bootstrapCI(m1, B_inner = 5, B_outer = 3) #' } #' #' ## Now let's parallelize the outer resampling and use @@ -128,17 +125,21 @@ #' my_inner_fun <- function(object){ #' cvrisk(object, folds = cvLong(id = object$id, weights = #' model.weights(object), type = "kfold", # use CV -#' B = 10, # 10-fold for inner resampling -#' ), -#' mc.cores = 10) # use ten cores +#' B = 5, # 5-fold for inner resampling +#' )) # use five cores #' } #' #' # use applyFolds for outer function to avoid messing up weights #' my_outer_fun <- function(object, fun){ #' applyFolds(object = object, #' folds = cv(rep(1, length(unique(object$id))), -#' type = "bootstrap", B = 100), fun = fun, -#' mc.cores = 10) # parallelize on 10 cores +#' type = "bootstrap", B = 10), fun = fun) # parallelize on 10 cores +#' } +#' +#' \donttest{ +#' bootCIs <- bootstrapCI(m1, resampling_fun_inner = my_inner_fun, +#' resampling_fun_outer = my_outer_fun, +#' B_inner = 5, B_outer = 10) #' } #' #' ######## Example for scalar-on-function-regression with bsignal() @@ -165,15 +166,10 @@ #' #' \donttest{ #' # takes some time, because of defaults: B_outer = 100, B_inner = 25 -#' bootCIs <- bootstrapCI(mod2) +#' bootCIs <- bootstrapCI(mod2, B_outer = 10, B_inner = 5) +#' # in practice, rather set B_outer = 1000 #' } #' -#' ## run with a larger number of outer bootstrap samples -#' ## and only 10-fold for validation of each outer fold -#' ## WARNING: This may take very long! -#' \donttest{ -#' bootCIs <- bootstrapCI(mod2, B_outer = 1000, B_inner = 10) -#' } #' #' @export bootstrapCI <- function(object, which = NULL, @@ -190,7 +186,7 @@ bootstrapCI <- function(object, which = NULL, type_inner <- match.arg(type_inner) ########## check for scalar response ######### - scalarResp <- "FDboostScalar" %in% class(object) + scalarResp <- inherits(object, "FDboostScalar") ########## define outer resampling function if NULL ######### if(is.null(resampling_fun_outer)){ @@ -231,7 +227,7 @@ bootstrapCI <- function(object, which = NULL, } # 'catch' error caused by using the cvrisk function for inner and outer resampling - if(identical(resampling_fun_outer, cvrisk) & + if(identical(resampling_fun_outer, cvrisk) && identical(resampling_fun_inner, cvrisk)) stop("Please specify a different outer resampling function.") @@ -255,7 +251,7 @@ bootstrapCI <- function(object, which = NULL, ########## format coefficients ######### # number of baselearners - nrEffects <- max(sapply(1:length(coefs), + nrEffects <- max(sapply(seq_along(coefs), function(i) length(coefs[[i]]$smterms))) isFacSpecEffect <- sapply(1:nrEffects, @@ -276,10 +272,10 @@ bootstrapCI <- function(object, which = NULL, { if(isFacSpecEffect[i]){ # factor specific effect - lapply(1:length(coefs), function(j) lapply(1:(coefs[[1]]$smterms[[i]]$numberLevels), + lapply(seq_along(coefs), function(j) lapply(1:(coefs[[1]]$smterms[[i]]$numberLevels), function(k) coefs[[j]]$smterms[[i]][[k]]$value)) }else{ - lapply(1:length(coefs), function(j) coefs[[j]]$smterms[[i]]$value) + lapply(seq_along(coefs), function(j) coefs[[j]]$smterms[[i]]$value) } }) @@ -303,7 +299,7 @@ bootstrapCI <- function(object, which = NULL, # add information about the values of the covariate # and change format - for(i in 1:length(listOfCoefs)){ + for(i in seq_along(listOfCoefs)){ if(isFacSpecEffect[i]){ @@ -316,18 +312,18 @@ bootstrapCI <- function(object, which = NULL, } aty <- NA - if(isSurface[i] | isFacEffect[i]) aty <- coefs[[1]]$smterms[[i]]$y + if(isSurface[i] || isFacEffect[i]) aty <- coefs[[1]]$smterms[[i]]$y if(isFacSpecEffect[i]) aty <- coefs[[1]]$smterms[[i]][[1]]$y # format functional factors - if(is.list(listOfCoefs[[i]]) & is.factor(atx)){ + if(is.list(listOfCoefs[[i]]) && is.factor(atx)){ # combine each factor level - listOfCoefs[[i]] <- lapply(1:length(levels(droplevels(atx))), + listOfCoefs[[i]] <- lapply(seq_along(levels(droplevels(atx))), function(faclevnr) t(sapply(listOfCoefs[[i]], function(x) x[faclevnr,]))) isSurface[i] <- FALSE - }else if(is.list(listOfCoefs[[i]]) & !isFacSpecEffect[i]){ # effect surfaces + }else if(is.list(listOfCoefs[[i]]) && !isFacSpecEffect[i]){ # effect surfaces listOfCoefs[[i]] <- do.call("rbind", lapply(listOfCoefs[[i]],c)) @@ -379,10 +375,10 @@ bootstrapCI <- function(object, which = NULL, listOfQuantiles <- vector("list", length(listOfCoefs)) # calculate quantiles - for(i in 1:length(listOfCoefs)){ + for(i in seq_along(listOfCoefs)){ # for matrix object - if(is.matrix(listOfCoefs[[i]]) & !is.list(listOfCoefs[[i]])){ + if(is.matrix(listOfCoefs[[i]]) && !is.list(listOfCoefs[[i]])){ listOfQuantiles[[i]] <- apply(listOfCoefs[[i]], 2, quantile, probs = levels) attr(listOfQuantiles[[i]], "x") <- attr(listOfCoefs[[i]], "x") @@ -408,7 +404,7 @@ bootstrapCI <- function(object, which = NULL, lapply(listOfQuantiles[isSurface], function(x){ - retL <- lapply(1:nrow(x), function(i) + retL <- lapply(seq_len(nrow(x)), function(i) matrix(x[i,], nrow = length(attr(x, "y")))) names(retL) <- levels return(retL) @@ -422,7 +418,7 @@ bootstrapCI <- function(object, which = NULL, if(is.list(x)){ - for(j in 1:length(x)){ + for(j in seq_along(x)){ if(!is.null(dim(x[[j]]))){ rownames(x[[j]]) <- levels @@ -490,7 +486,7 @@ bootstrapCI <- function(object, which = NULL, #' @details \code{plot.bootstrapCI} plots the bootstrapped coefficients. #' #' @aliases print.bootstrapCI -#' +#' @return No return value (plot method) or \code{x} itself (print method) #' @method plot bootstrapCI #' #' @export @@ -502,7 +498,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, ylim = NULL, ...) { - stopifnot(class(x) == "bootstrapCI") + stopifnot(inherits(x, "bootstrapCI")) boot_offset <- 0 @@ -516,7 +512,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, } - if(is.null(which)) which <- 1:length(x$raw_results) + if(is.null(which)) which <- seq_along(x$raw_results) oldpar <- par(no.readonly = TRUE) on.exit(par(oldpar)) @@ -524,7 +520,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, if(length(which)>1) par(ask=ask) # find common range for all effects - if(commonRange & is.null(ylim)){ + if(commonRange && is.null(ylim)){ ylim <- range(x$raw_results) if(any(is.infinite(ylim))) ylim <- NULL } @@ -548,11 +544,11 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, if(!is.list(temp_CI)){ if(temp$dim >= 2){ - temp$value <- split(temp_CI, seq(nrow(temp_CI))) + temp$value <- split(temp_CI, seq_len(nrow(temp_CI))) }else{ ## temp$dim == 1 like in scalar response with bsignal() ## put each fold into one list entry - if(length(x$yind) <= 1 & x$family != "Binomial Distribution (similar to glm)"){ + if(length(x$yind) <= 1 && x$family != "Binomial Distribution (similar to glm)"){ # scalar response and not Binomial temp$value <- split(temp_CI, rep(1:x$B_outer, each = length(temp_CI)/x$B_outer)) }else{ @@ -563,7 +559,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, }else{ - if(is.null(temp$numberLevels) & is.factor(temp$x)){ + if(is.null(temp$numberLevels) && is.factor(temp$x)){ ## for time-varying factor effects temp$value <- temp_CI @@ -577,7 +573,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, } } - if(!is.null(temp$dim) && temp$dim == 2 & !is.factor(temp$x)){ + if(!is.null(temp$dim) && temp$dim == 2 && !is.factor(temp$x)){ temp$value <- lapply(temp$value, function(xx) matrix(xx, ncol = sqrt(length(xx)), nrow = sqrt(length(xx)), byrow = FALSE) ) } @@ -602,7 +598,7 @@ plot.bootstrapCI <- function(x, which = NULL, pers = TRUE, print.bootstrapCI <- function(x, ...) { - stopifnot(class(x)=="bootstrapCI") + stopifnot(inherits(x, "bootstrapCI")) cat("\n") diff --git a/R/clr_functions.R b/R/clr_functions.R index 7ad772a..c11540a 100644 --- a/R/clr_functions.R +++ b/R/clr_functions.R @@ -195,7 +195,7 @@ clr <- function(f, w = 1, inverse = FALSE) { #' # Plot densities #' year_col <- rainbow(70, start = 0.5, end = 1) #' year_lty <- c(1, 2, 4, 5) -#' par(mfrow = c(1, 2)) +#' oldpar <- par(mfrow = c(1, 2)) #' funplot(1:12, birthDistribution$birth_densities[1:70, ], ylab = "densities", xlab = "month", #' xaxp = c(1, 12, 11), pch = 20, col = year_col, lty = year_lty, main = "Male") #' funplot(1:12, birthDistribution$birth_densities[71:140, ], ylab = "densities", xlab = "month", @@ -237,5 +237,5 @@ clr <- function(f, w = 1, inverse = FALSE) { #' xaxp = c(1, 12, 11), pch = 20, col = year_col, lty = year_lty, main = "Male") #' funplot(1:12, predictions[71:140, ], ylab = "predictions", xlab = "month", ylim = pred_ylim, #' xaxp = c(1, 12, 11), pch = 20, col = year_col, lty = year_lty, main = "Female") -#' par(mfrow = c(1, 1)) +#' par(oldpar) "birthDistribution" \ No newline at end of file diff --git a/R/constrainedX.R b/R/constrainedX.R index 24c65ad..c4970fb 100644 --- a/R/constrainedX.R +++ b/R/constrainedX.R @@ -20,6 +20,9 @@ #' where \code{1} induces a global intercept and \code{x1}, \code{x2} are factor variables, #' see Ruegamer et al. (2018). #' +#' @return An object of class \code{blg} (base-learner generator) with a \code{dpp} function +#' as for other \code{\link[mboost:baselearners]{baselearners}}. +#' #' @references #' Brockhaus, S., Scheipl, F., Hothorn, T. and Greven, S. (2015): #' The functional linear array model. Statistical Modelling, 15(3), 279-300. @@ -86,8 +89,8 @@ if(any(used_bl == "bolsc")) stop("Use bols instead of bolsc with %Xc%.") if(any(used_bl == "brandomc")) stop("Use brandom instead of brandomc with %Xc%.") if(any(used_bl == "bbsc")) stop("Use bbs instead of bbsc with %Xc%.") - if( (!is.null(match.call()$bl1$intercept) && match.call()$bl1$intercept != TRUE) | - (!is.null(match.call()$bl2$intercept) && match.call()$bl2$intercept != TRUE) ){ + if( (!is.null(match.call()$bl1$intercept) && !isTRUE(match.call()$bl1$intercept)) || + (!is.null(match.call()$bl2$intercept) && !isTRUE(match.call()$bl2$intercept)) ){ stop("Set intercept = TRUE in base-learners used with %Xc%.") } @@ -101,8 +104,8 @@ mboost_intern(bl2, fun = "model.frame.blg") ) index1 <- bl1$get_index() index2 <- bl2$get_index() - if (is.null(index1)) index1 <- 1:nrow(mf) - if (is.null(index2)) index2 <- 1:nrow(mf) + if (is.null(index1)) index1 <- seq_len(nrow(mf)) + if (is.null(index2)) index2 <- seq_len(nrow(mf)) mfindex <- cbind(index1, index2) index <- NULL @@ -169,9 +172,9 @@ X1 <- X1$X if (!is.null(l1)) K1 <- l1 * K1 MATRIX <- options("mboost_useMatrix")$mboost_useMatrix - if (MATRIX & !is(X1, "Matrix")) + if (MATRIX && !is(X1, "Matrix")) X1 <- Matrix(X1) - if (MATRIX & !is(K1, "Matrix")) + if (MATRIX && !is(K1, "Matrix")) K1 <- Matrix(K1) X2 <- newX2(mf[, bl2$get_names(), drop = FALSE], @@ -179,9 +182,9 @@ K2 <- X2$K X2 <- X2$X if (!is.null(l2)) K2 <- l2 * K2 - if (MATRIX & !is(X2, "Matrix")) + if (MATRIX && !is(X2, "Matrix")) X2 <- Matrix(X2) - if (MATRIX & !is(K2, "Matrix")) + if (MATRIX && !is(K2, "Matrix")) K2 <- Matrix(K2) suppressMessages( X <- kronecker(X1, Matrix(1, ncol = ncol(X2), @@ -208,7 +211,7 @@ ## use whole matrices of marginal effects for constraints as Almond suggested C <- t(X) %*% cbind(rep(1, nrow(X)), X1, X2) qr_C <- qr(C) ## , tol = 1e-10 ## time? - if( any(class(qr_C) == "sparseQR") ){ + if( inherits(qr_C, "sparseQR") ){ rank_C <- qr_C@Dim[2] }else{ rank_C <- qr_C$rank @@ -309,8 +312,8 @@ bl_lin_matrix_a <- function(blg, Xfun, args) { # K2 <- args$K2 # ## per default do not expand the marginal design matrices - # expand_index1 <- 1:nrow(X$X1) - # expand_index2 <- 1:nrow(X$X2) + # expand_index1 <- seq_len(nrow(X$X1)) + # expand_index2 <- seq_len(nrow(X$X2)) ## weights-matrix W: weights are for single observations in the matrix Y ## but the marginal bl work either on columns or rows of Y @@ -341,7 +344,7 @@ bl_lin_matrix_a <- function(blg, Xfun, args) { if( all(abs(multFactor - multFactor[1] ) < .Machine$double.eps*10^10) ) multFactor <- multFactor[1] ## case that W and w1w2 just differ by a factor - if( all((W == w1w2)[w1w2 == 0]) & all((W == w1w2)[W == 0]) & ## check positions of zeros + if( all((W == w1w2)[w1w2 == 0]) && all((W == w1w2)[W == 0]) && ## check positions of zeros length(multFactor) == 1 ){ # check that only 1 multiplicative factor ## it is impossible to know whether multFactor is multiplied to w1 or w2! @@ -372,8 +375,8 @@ bl_lin_matrix_a <- function(blg, Xfun, args) { ### but: this does not work correctly: problem with factor remains # ## W cannot be computed from w1 and w2, # ## -> blow up the marginal design matrices and use W with them, - # expand_index1 <- rep(1:nrow(X$X1), times = nrow(X$X2)) - # expand_index2 <- rep(1:nrow(X$X2), each = nrow(X$X1)) + # expand_index1 <- rep(seq_len(nrow(X$X1)), times = nrow(X$X2)) + # expand_index2 <- rep(seq_len(nrow(X$X2)), each = nrow(X$X1)) # ## all( c(W) == weights) is TRUE, ordering of weights must match to blown-up marginal design matrices # ## standardize weights to compensate for the blow-up of the marginal design-matrices # #w1 <- c(W) / mean(rowSums(W)) ## for some special cases (e.g. BS on rows): mean(rowSums(W)) == nrow(X$X2) @@ -611,8 +614,10 @@ bl_lin_matrix_a <- function(blg, Xfun, args) { #' \code{\%Xa0\%} computes like \code{\%X\%} the row tensor product of two base-learners, #' with the difference that it sets the penalty for one direction to zero. #' Thus, \code{\%Xa0\%} behaves to \code{\%X\%} analogously like \code{\%A0\%} to \code{\%O\%}. -#' #' +#' @return An object of class \code{blg} (base-learner generator) with a \code{dpp} function +#' as for other \code{\link[mboost:baselearners]{baselearners}}. +#' #' @references #' Brockhaus, S., Scheipl, F., Hothorn, T. and Greven, S. (2015): #' The functional linear array model. Statistical Modelling, 15(3), 279-300. @@ -678,15 +683,18 @@ bl_lin_matrix_a <- function(blg, Xfun, args) { #' #' ## compare estimated coefficients #' \donttest{ -#' par(mfrow=c(4, 2)) -#' plot(mod1, which = 1) -#' plot(mod1a, which = 1) -#' plot(mod1, which = 2) -#' plot(mod1a, which = 2) -#' plot(mod1, which = 3) -#' plot(mod1a, which = 3) -#' funplot(mod1$yind, predict(mod1, which=4)) -#' funplot(mod1$yind, predict(mod1a, which=4)) +#' if (interactive()) { +#' oldpar <- par(mfrow=c(4, 2)) +#' plot(mod1, which = 1) +#' plot(mod1a, which = 1) +#' plot(mod1, which = 2) +#' plot(mod1a, which = 2) +#' plot(mod1, which = 3) +#' plot(mod1a, which = 3) +#' funplot(mod1$yind, predict(mod1, which=4)) +#' funplot(mod1$yind, predict(mod1a, which=4)) +#' par(oldpar) +#' } #' } #' #' @name anisotropic_Kronecker @@ -777,9 +785,9 @@ NULL X1 <- X1$X if (!is.null(l1)) K1 <- l1 * K1 MATRIX <- options("mboost_useMatrix")$mboost_useMatrix - if (MATRIX & !is(X1, "Matrix")) + if (MATRIX && !is(X1, "Matrix")) X1 <- Matrix(X1) - if (MATRIX & !is(K1, "Matrix")) + if (MATRIX && !is(K1, "Matrix")) K1 <- Matrix(K1) X2 <- newX2(as.data.frame(mf[bl2$get_names()]), @@ -787,9 +795,9 @@ NULL K2 <- X2$K X2 <- X2$X if (!is.null(l2)) K2 <- l2 * K2 - if (MATRIX & !is(X2, "Matrix")) + if (MATRIX && !is(X2, "Matrix")) X2 <- Matrix(X2) - if (MATRIX & !is(K2, "Matrix")) + if (MATRIX && !is(K2, "Matrix")) K2 <- Matrix(K2) suppressMessages( K <- kronecker(K2, diag(ncol(X1))) + @@ -906,7 +914,7 @@ NULL } } - if(args$lambda1 != 0 & args$lambda2 != 0) + if(args$lambda1 != 0 && args$lambda2 != 0) stop("%A0% can only be used when smoothing parameter is zero for one direction.") l1 <- args$lambda1 @@ -925,9 +933,9 @@ NULL X1 <- X1$X if (!is.null(l1)) K1 <- l1 * K1 MATRIX <- options("mboost_useMatrix")$mboost_useMatrix - if (MATRIX & !is(X1, "Matrix")) + if (MATRIX && !is(X1, "Matrix")) X1 <- Matrix(X1) - if (MATRIX & !is(K1, "Matrix")) + if (MATRIX && !is(K1, "Matrix")) K1 <- Matrix(K1) X2 <- newX2(as.data.frame(mf[bl2$get_names()]), @@ -935,9 +943,9 @@ NULL K2 <- X2$K X2 <- X2$X if (!is.null(l2)) K2 <- l2 * K2 - if (MATRIX & !is(X2, "Matrix")) + if (MATRIX && !is(X2, "Matrix")) X2 <- Matrix(X2) - if (MATRIX & !is(K2, "Matrix")) + if (MATRIX && !is(K2, "Matrix")) K2 <- Matrix(K2) suppressMessages( K <- kronecker(K2, diag(ncol(X1))) + @@ -980,8 +988,8 @@ NULL index1 <- bl1$get_index() index2 <- bl2$get_index() - if (is.null(index1)) index1 <- 1:nrow(mf) - if (is.null(index2)) index2 <- 1:nrow(mf) + if (is.null(index1)) index1 <- seq_len(nrow(mf)) + if (is.null(index2)) index2 <- seq_len(nrow(mf)) mfindex <- cbind(index1, index2) index <- NULL @@ -1069,7 +1077,7 @@ NULL } } - if(args$lambda1 != 0 & args$lambda2 != 0) + if(args$lambda1 != 0 && args$lambda2 != 0) stop("%Xa0% can only be used when smoothing parameter is zero for one direction.") l1 <- args$lambda1 @@ -1088,9 +1096,9 @@ NULL X1 <- X1$X if (!is.null(l1)) K1 <- l1 * K1 MATRIX <- options("mboost_useMatrix")$mboost_useMatrix - if (MATRIX & !is(X1, "Matrix")) + if (MATRIX && !is(X1, "Matrix")) X1 <- Matrix(X1) - if (MATRIX & !is(K1, "Matrix")) + if (MATRIX && !is(K1, "Matrix")) K1 <- Matrix(K1) X2 <- newX2(mf[, bl2$get_names(), drop = FALSE], @@ -1098,9 +1106,9 @@ NULL K2 <- X2$K X2 <- X2$X if (!is.null(l2)) K2 <- l2 * K2 - if (MATRIX & !is(X2, "Matrix")) + if (MATRIX && !is(X2, "Matrix")) X2 <- Matrix(X2) - if (MATRIX & !is(K2, "Matrix")) + if (MATRIX && !is(K2, "Matrix")) K2 <- Matrix(K2) suppressMessages( X <- kronecker(X1, Matrix(1, ncol = ncol(X2), diff --git a/R/crossvalidation.R b/R/crossvalidation.R index 3961d8e..55a1636 100644 --- a/R/crossvalidation.R +++ b/R/crossvalidation.R @@ -135,7 +135,7 @@ #' cvr <- applyFolds(mod, folds = folds_bs, grid = 1:75) #' #' ## weights per observation point -#' folds_bs_long <- folds_bs[rep(1:nrow(folds_bs), times = mod$ydim[2]), ] +#' folds_bs_long <- folds_bs[rep(seq_len(nrow(folds_bs)), times = mod$ydim[2]), ] #' attr(folds_bs_long, "type") <- "3-fold bootstrap" #' ## compute out-of-bag risk on the 3 folds for 1 to 75 boosting iterations #' cvr3 <- cvrisk(mod, folds = folds_bs_long, grid = 1:75) @@ -143,9 +143,10 @@ #' #' \donttest{ #' ## plot the out-of-bag risk -#' par(mfrow = c(1,3)) +#' oldpar <- par(mfrow = c(1,3)) #' plot(cvr); legend("topright", lty=2, paste(mstop(cvr))) #' plot(cvr3); legend("topright", lty=2, paste(mstop(cvr3))) +#' par(oldpar) #' } #' #'} @@ -171,7 +172,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ stop("The folds-matrix must have one row per observed trajectory.") } - if(any(class(object) == "FDboostLong")){ # irregular response + if(inherits(object, "FDboostLong")){ # irregular response nObs <- length(unique(object$id)) # number of curves Gy <- NULL # number of time-points per curve }else{ # regular response / scalar response @@ -200,7 +201,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ }else{ if(numInt == "Riemann"){ # use the integration scheme specified in applyFolds - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ integration_weights <- as.vector(integrationWeights(X1 = matrix(object$response, ncol = object$ydim[2]), object$yind)) }else{ @@ -215,7 +216,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ ### get yind in long format yindLong <- object$yind - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ yindLong <- rep(object$yind, each = nObs) } ### compute ("length of each trajectory")^-1 in the response @@ -234,7 +235,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ # Function to suppress the warning of missings in the response h <- function(w){ - if( any( grepl( "response contains missing values;", w) ) ) + if( any( grepl( "response contains missing values;", w, fixed = TRUE) ) ) invokeRestart( "muffleWarning" ) } @@ -247,14 +248,14 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ ## problem with index for bl containing index, and you do not get s for bsignal/bhist if(FALSE){ dathelp2 <- list() - for(j in 1:length(object$baselearner)){ + for(j in seq_along(object$baselearner)){ dat_bl_j <- object$baselearner[[j]]$get_data() ## object$baselearner[[j]]$model.frame() # if the variable is already present, do not add it again dathelp2 <- c(dathelp2, dat_bl_j[!names(dat_bl_j) %in% names(dathelp2)]) } } - if(!any(class(object) == "FDboostLong") & !any(class(object) == "FDboostScalar")){ + if(!inherits(object, "FDboostLong") && !inherits(object, "FDboostScalar")){ dathelp[[object$yname]] <- matrix(object$response, ncol=object$ydim[2]) dathelp$integration_weights <- matrix(integration_weights, ncol=object$ydim[2]) dathelp$object_id <- object$id @@ -278,13 +279,13 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ names_variables <- names_variables[names_variables != nameyind] names_variables <- names_variables[names_variables != "ONEx"] names_variables <- names_variables[names_variables != "ONEtime"] - if(!any(class(object) == "FDboostLong")) names_variables <- c(object$yname, "integration_weights", names_variables) + if(!inherits(object, "FDboostLong")) names_variables <- c(object$yname, "integration_weights", names_variables) - length_variables <- if("FDboostScalar" %in% class(object)) + length_variables <- if(inherits(object, "FDboostScalar")) lapply(dathelp[names_variables], length) else lapply(dathelp[names_variables], NROW) names_variables_long <- names_variables[ length_variables == length(object$id) ] - nothmatrix <- ! sapply(dathelp[names_variables_long], function(x) any(class(x) == "hmatrix" )) + nothmatrix <- ! sapply(dathelp[names_variables_long], is.hmatrix) names_variables_long <- names_variables_long[ nothmatrix ] if(identical(names_variables_long, character(0))) names_variables_long <- NULL @@ -295,16 +296,16 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ # the probelm with such base-learners is that their data is not contained in object$data # using object$baselearner[[j]]$get_data() is difficult as this can be blow up by index for %X% singleBls <- gsub("\\s", "", unlist(lapply(strsplit( - strsplit(object$formulaFDboost, "~")[[1]][2], # split formula - "\\+")[[1]], # split additive terms + strsplit(object$formulaFDboost, "~", fixed = TRUE)[[1]][2], # split formula + "+", fixed = TRUE)[[1]], # split additive terms function(y) strsplit(y, split = "%.{1,3}%")) # split single baselearners )) singleBls <- singleBls[singleBls != "1"] - if(any(!grepl("\\(", singleBls))) + if(any(!grepl("(", singleBls, fixed = TRUE))) stop(paste0("applyFolds can not deal with the following base-learner(s) without brackets: ", - paste(singleBls[!grepl("\\(", singleBls)], collapse = ", "))) + toString(singleBls[!grepl("(", singleBls, fixed = TRUE)]))) ## check if data includes all variables @@ -316,11 +317,11 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ # for each missing variable get the first baselearner, which contains the variable blWithMissVars <- lapply(names_variables[whMiss], function(w) - unlist(lapply(1:length(object$baselearner), function(i) if( + unlist(lapply(seq_along(object$baselearner), function(i) if( any( grepl(w, object$baselearner[[i]]$get_names() ) )) return(i)) )[1]) - stop(paste0("base-learner(s) ", paste(unlist(list(1,2)), collapse = ", "), + stop(paste0("base-learner(s) ", toString(unlist(list(1,2))), " contain(s) variables, which are not part of the data object.")) } @@ -329,7 +330,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ fitfct <- function(weights, oobweights){ ## get data according to weights - if(any(class(object) == "FDboostLong")){ + if(inherits(object, "FDboostLong")){ dat_weights <- reweightData(data = dathelp, vars = names_variables, longvars = c(object$yname, nameyind, "integration_weights", names_variables_long), weights = weights, idvars = c(attr(object$id, "nameid"), index_names), @@ -351,10 +352,10 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ if(any(isFac)){ namesFac <- names(isFac)[isFac] - for(i in 1:length(namesFac)){ + for(i in seq_along(namesFac)){ - if(length(levels(droplevels(dathelp[[namesFac[i]]]))) != - length(levels(droplevels(dat_weights[[namesFac[i]]])))) + if(nlevels(droplevels(dathelp[[namesFac[i]]])) != + nlevels(droplevels(dat_weights[[namesFac[i]]]))) stop(paste0("The factor variable '", namesFac[i], "' has unobserved levels in the training data. ", "Make sure that training data in each fold contains all factor levels.")) @@ -402,7 +403,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ } ## get data according to oobweights - if(any(class(object) == "FDboostLong")){ + if(inherits(object, "FDboostLong")){ dathelp$lengthTi1 <- c(lengthTi1) dat_oobweights <- reweightData(data = dathelp, vars = c(names_variables, "lengthTi1"), longvars = c(object$yname, nameyind, @@ -448,7 +449,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ invokeRestart( "muffleWarning" ) } - if(any(class(object) == "FDboostLong")){ + if(inherits(object, "FDboostLong")){ if(numInt == "equal"){ oobwstand <- dat_oobweights$integration_weights * (1/sum(dat_oobweights$integration_weights)) @@ -459,9 +460,10 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ } # compute risk with integration weights like in FDboost::validateFDboost - risk <- sapply(grid, function(g){riskfct( response_oobweights, - withCallingHandlers(predict(mod[g], newdata = dat_oobweights, toFDboost = FALSE), warning = h2), - w = oobwstand )}) ## oobwstand[oobweights[object$id] != 0 ] + risk <- sapply(grid, function(g){riskfct( + response_oobweights, + withCallingHandlers(predict(mod[g], newdata = dat_oobweights, toFDboost = FALSE), warning = h2), + w = oobwstand )}) ## oobwstand[oobweights[object$id] != 0 ] }else{ @@ -473,9 +475,10 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ } # compute risk with integration weights like in FDboost::validateFDboost - risk <- sapply(grid, function(g){riskfct( response_oobweights, - withCallingHandlers(predict(mod[g], newdata = dat_oobweights, toFDboost = FALSE), warning = h2), - w = oobwstand[oobweights != 0 ])}) + risk <- sapply(grid, function(g){riskfct( + response_oobweights, + withCallingHandlers(predict(mod[g], newdata = dat_oobweights, toFDboost = FALSE), warning = h2), + w = oobwstand[oobweights != 0 ])}) } @@ -502,15 +505,15 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ OOBweights <- matrix(rep(sample_weights, ncol(folds)), ncol = ncol(folds)) OOBweights[folds > 0] <- 0 - if (all.equal(papply, mclapply) == TRUE) { - oobrisk <- papply(1:ncol(folds), + if (isTRUE(all.equal(papply, mclapply))) { + oobrisk <- papply(seq_len(ncol(folds)), function(i) try(dummyfct(weights = folds[, i], oobweights = OOBweights[, i]), silent = TRUE), mc.preschedule = mc.preschedule, ...) } else { - oobrisk <- papply(1:ncol(folds), + oobrisk <- papply(seq_len(ncol(folds)), function(i) try(dummyfct(weights = folds[, i], oobweights = OOBweights[, i]), silent = TRUE), @@ -538,7 +541,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ oobrisk <- t(as.data.frame(oobrisk)) ## oobrisk <- oobrisk / colSums(OOBweights[object$id, ]) # is done in dummyfct() colnames(oobrisk) <- grid - rownames(oobrisk) <- 1:nrow(oobrisk) + rownames(oobrisk) <- seq_len(nrow(oobrisk)) attr(oobrisk, "risk") <- fam_name attr(oobrisk, "call") <- call attr(oobrisk, "mstop") <- grid @@ -643,7 +646,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ #' mod <- mod[75] #' #' #### create folds for 3-fold bootstrap: one weight for each curve -#' set.seed(123) +#' set.seed(124) #' folds_bs <- cv(weights = rep(1, mod$ydim[1]), type = "bootstrap", B = 3) #' #' ## compute out-of-bag risk on the 3 folds for 1 to 75 boosting iterations @@ -653,13 +656,13 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ #' cvr2 <- validateFDboost(mod, folds = folds_bs, grid = 1:75) #' #' ## weights per observation point -#' folds_bs_long <- folds_bs[rep(1:nrow(folds_bs), times = mod$ydim[2]), ] +#' folds_bs_long <- folds_bs[rep(seq_len(nrow(folds_bs)), times = mod$ydim[2]), ] #' attr(folds_bs_long, "type") <- "3-fold bootstrap" #' ## compute out-of-bag risk on the 3 folds for 1 to 75 boosting iterations #' cvr3 <- cvrisk(mod, folds = folds_bs_long, grid = 1:75) #' #' ## plot the out-of-bag risk -#' par(mfrow = c(1,3)) +#' oldpar <- par(mfrow = c(1,3)) #' plot(cvr); legend("topright", lty=2, paste(mstop(cvr))) #' plot(cvr2) #' plot(cvr3); legend("topright", lty=2, paste(mstop(cvr3))) @@ -667,7 +670,7 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ #' ## plot the estimated coefficients per fold #' ## more meaningful for higher number of folds, e.g., B = 100 #' par(mfrow = c(2,2)) -#' plotPredCoef(cvr2, terms = FALSE, which = 2) +#' plotPredCoef(cvr2, terms = FALSE, which = 1) #' plotPredCoef(cvr2, terms = FALSE, which = 3) #' #' ## compute out-of-bag risk and predictions for leaving-one-curve-out cross-validation @@ -678,6 +681,8 @@ applyFolds <- function(object, folds = cv(rep(1, length(unique(object$id))), typ #' plotPredCoef(cvr_jackknife, which = 3) #' ## plot coefficients per fold for 2nd effect #' plotPredCoef(cvr_jackknife, which = 2, terms = FALSE) +#' +#' par(oldpar) #' #'} #'} @@ -696,9 +701,9 @@ validateFDboost <- function(object, response = NULL, msg = "'validateFDboost' is deprecated. Use 'applyFolds' and 'bootstrapCI' instead.") names_bl <- names(object$baselearner) - if(any(grepl("brandomc", names_bl))) message("For brandomc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bolsc", names_bl))) message("For bolsc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bbsc", names_bl))) message("For bbsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("brandomc", names_bl, fixed = TRUE))) message("For brandomc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bolsc", names_bl, fixed = TRUE))) message("For bolsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bbsc", names_bl, fixed = TRUE))) message("For bbsc, the transformation matrix Z is fixed over all folds.") type <- attr(folds, "type") if(is.null(type)) type <- "unknown" @@ -710,7 +715,7 @@ validateFDboost <- function(object, response = NULL, stop("The folds-matrix must have one row per observed trajectory.") } - if(any(class(object) == "FDboostLong")){ # irregular response + if(inherits(object, "FDboostLong")){ # irregular response nObs <- length(unique(object$id)) # number of curves Gy <- NULL # number of time-points per curve }else{ # regular response / scalar response @@ -734,7 +739,7 @@ validateFDboost <- function(object, response = NULL, # intWeights <- model.weights(object) # weights are rescaled in mboost, see mboost:::rescale_weights if(!is.null(object$callEval$numInt) && object$callEval$numInt == "Riemann"){ - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ intWeights <- as.vector(integrationWeights(X1 = matrix(object$response, ncol = object$ydim[2]), object$yind)) }else{ @@ -750,13 +755,13 @@ validateFDboost <- function(object, response = NULL, # Function to suppress the warning of missings in the response h <- function(w){ - if( any( grepl( "response contains missing values;", w) ) ) + if( any( grepl( "response contains missing values;", w, fixed = TRUE) ) ) invokeRestart( "muffleWarning" ) } ### get yind in long format yindLong <- object$yind - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ yindLong <- rep(object$yind, each = nObs) } ### compute ("length of each trajectory")^-1 in the response @@ -778,7 +783,7 @@ validateFDboost <- function(object, response = NULL, nameyind <- attr(object$yind, "nameyind") dathelp[[nameyind]] <- object$yind - if(!any(class(object) == "FDboostLong") & !any(class(object) == "FDboostScalar")){ + if(!inherits(object, "FDboostLong") && !inherits(object, "FDboostScalar")){ dathelp[[object$yname]] <- matrix(object$response, ncol = Gy) }else{ dathelp[[object$yname]] <- object$response @@ -795,8 +800,8 @@ validateFDboost <- function(object, response = NULL, # Using the offset of object with the following settings # call$control <- boost_control(risk="oobag") # call$oobweights <- oobweights[id] - if(refitSmoothOffset == FALSE && is.null(call$offset) ){ - if(!any(class(object) == "FDboostLong")){ + if(!refitSmoothOffset && is.null(call$offset) ){ + if(!inherits(object, "FDboostLong")){ call$offset <- matrix(object$offset, ncol = Gy)[1, ] }else{ call$offset <- object$offset @@ -890,11 +895,11 @@ validateFDboost <- function(object, response = NULL, ### computation of models on partitions of data if(Sys.info()["sysname"]=="Linux"){ - modRisk <- mclapply(1:ncol(folds), + modRisk <- mclapply(seq_len(ncol(folds)), function(i) dummyfct(weights = folds[, i], oobweights = OOBweights[, i]), ...) }else{ - modRisk <- mclapply(1:ncol(folds), + modRisk <- mclapply(seq_len(ncol(folds)), function(i) dummyfct(weights = folds[, i], oobweights = OOBweights[, i]), mc.cores = 1) } @@ -903,13 +908,13 @@ validateFDboost <- function(object, response = NULL, # str(modRisk, max.level=5) # check whether model fit worked in all iterations - modFitted <- sapply(modRisk, function(x) class(x) == "list") + modFitted <- sapply(modRisk, is.list) if(any(!modFitted)){ # stop() or warning()? if(sum(!modFitted) > sum(modFitted)) warning("More than half of the models could not be fitted.") - warning("Model fit did not work in fold ", paste(which(!modFitted), collapse = ", ")) + warning("Model fit did not work in fold ", toString(which(!modFitted))) modRisk <- modRisk[modFitted] OOBweights <- OOBweights[,modFitted] folds <- folds[,modFitted] @@ -951,18 +956,18 @@ validateFDboost <- function(object, response = NULL, } ## only makes sense for type="curves" with leaving-out one curve per fold!! - if(grepl( "curves", type)){ + if(grepl( "curves", type, fixed = TRUE)){ # predict response for all mstops in grid out of bag # predictions for each response are in a vector! oobpreds0 <- lapply(modRisk, function(x) x$predGrid) oobpreds <- matrix(nrow = nrow(oobpreds0[[1]]), ncol = ncol(oobpreds0[[1]])) - if(any(class(object) == "FDboostLong")){ - for(i in 1:length(oobpreds0)){ # i runs over observed trajectories, i.e. over id + if(inherits(object, "FDboostLong")){ + for(i in seq_along(oobpreds0)){ # i runs over observed trajectories, i.e. over id oobpreds[id == i, ] <- oobpreds0[[i]][id == i, ] } }else{ - for(j in 1:length(oobpreds0)){ + for(j in seq_along(oobpreds0)){ oobpreds[folds[ , j] == 0] <- oobpreds0[[j]][folds[ , j] == 0] } } @@ -1003,7 +1008,7 @@ validateFDboost <- function(object, response = NULL, ### estimates of coefficients timeHelp <- seq(min(modRisk[[1]]$mod$yind), max(modRisk[[1]]$mod$yind), l = 40) - for(l in 1:length(modRisk[[1]]$mod$baselearner)){ + for(l in seq_along(modRisk[[1]]$mod$baselearner)){ # estimate the coefficients for the model of the first fold my_coef <- coef(modRisk[[1]]$mod[optimalMstop], which = l, n1 = 40, n2 = 20, n3 = 15, n4 = 10)$smterms[[1]] @@ -1018,7 +1023,7 @@ validateFDboost <- function(object, response = NULL, attr(coefCV[[l]]$value, "offset") <- NULL # as offset is the same within one model # add estimates for the models of the other folds - coefCV[[l]]$value <- lapply(1:length(modRisk), function(g){ + coefCV[[l]]$value <- lapply(seq_along(modRisk), function(g){ ret <- coef(modRisk[[g]]$mod[optimalMstop], which = l, n1 = 40, n2 = 20, n3 = 15, n4 = 10)$smterms[[1]]$value # if(l==1){ @@ -1031,7 +1036,7 @@ validateFDboost <- function(object, response = NULL, ## %X% with numberLevels coefficient values in a list ## lapply(1:coefCV[[l]]$numberLevels, function(x) coefCV[[l]][[x]]$value) for(j in 1:coefCV[[l]]$numberLevels){ - coefCV[[l]][[j]]$value <- lapply(1:length(modRisk), function(g){ + coefCV[[l]][[j]]$value <- lapply(seq_along(modRisk), function(g){ ret <- coef(modRisk[[g]]$mod[optimalMstop], which = l, n1 = 40, n2 = 20, n3 = 15, n4 = 10)$smterms[[1]][[j]]$value attr(ret, "offset") <- NULL # as offset is the same within one model @@ -1043,7 +1048,7 @@ validateFDboost <- function(object, response = NULL, } ## predict offset - offset <- sapply(1:length(modRisk), function(g){ + offset <- sapply(seq_along(modRisk), function(g){ # offset is vector of length yind or numeric of length 1 for constant offset ret <- modRisk[[g]]$mod$predictOffset(time = timeHelp) if( length(ret) == 1 & length(object$yind) > 1 ) ret <- rep(ret, length(timeHelp)) @@ -1056,14 +1061,14 @@ validateFDboost <- function(object, response = NULL, ### predictions of terms based on the coefficients for each model # only makes sense for type="curves" with leaving-out one curve per fold!! - if(grepl("curves", type)){ + if(grepl("curves", type, fixed = TRUE)){ for(l in 1:(length(modRisk[[1]]$mod$baselearner)+1)){ - predCV[[l]] <- t(sapply(1:length(modRisk), function(g){ + predCV[[l]] <- t(sapply(seq_along(modRisk), function(g){ if(l == 1){ # save offset of model # offset is vector of length yind or numeric of length 1 for constant offset ret <- modRisk[[g]]$mod[optimalMstop]$predictOffset(object$yind) # regular data or scalar response - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ if( length(ret) == 1 ) ret <- rep(ret, modRisk[[1]]$mod$ydim[2]) # irregular data }else{ @@ -1072,13 +1077,13 @@ validateFDboost <- function(object, response = NULL, }else{ # other effects ret <- predict(modRisk[[g]]$mod[optimalMstop], which = l-1) # model g if(!(l-1) %in% selected(modRisk[[g]]$mod[optimalMstop]) ){ # effect was never chosen - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ ret <- matrix(0, ncol=modRisk[[1]]$mod$ydim[2], nrow=modRisk[[1]]$mod$ydim[1]) }else{ ret <- matrix(0, nrow = length(object$id), ncol=1) } } - if(!any(class(object) == "FDboostLong")){ + if(!inherits(object, "FDboostLong")){ ret <- ret[g,] # save g-th row = preds for g-th observations }else{ ret <- ret[object$id == g] # save preds of g-th observations @@ -1107,7 +1112,7 @@ validateFDboost <- function(object, response = NULL, oobrisk0 = oobrisk0, oobmse0 = oobmse0, oobmrd0 = oobmrd0, - format = if(any(class(object) == "FDboostLong")) "FDboostLong" else "FDboost", + format = if(inherits(object, "FDboostLong")) "FDboostLong" else "FDboost", fun_ret = if(is.null(fun)) NULL else lapply(modRisk, function(x) x$fun_ret) ) rm(modRisk) @@ -1200,6 +1205,8 @@ print.validateFDboost <- function(x, ...){ #' coefficients that were estimated in the folds - only possible if the argument getCoefCV is \code{TRUE} in #' the call to \code{validateFDboost}. #' +#' @return No return value (plot method) or the object itself (print method) +#' #' @aliases mstop.validateFDboost #' #' @method plot validateFDboost @@ -1241,7 +1248,7 @@ plot.validateFDboost <- function(x, riskopt=c("mean", "median"), c(min(c(0, ylim[1] * ifelse(ylim[1] < 0, 2, 0.5))), riskMean[paste(mOptMean)]), lty = 2) legend("topright", legend=paste(c(mOptMean)), - lty=c(2), col=c("black")) + lty=2, col="black") } @@ -1254,7 +1261,7 @@ plot.validateFDboost <- function(x, riskopt=c("mean", "median"), riskMedian[paste(mOptMedian)]), lty = 2) legend("topright", legend=paste(c(mOptMedian)), - lty=c(2), col=c("black")) + lty=2, col="black") } } @@ -1280,7 +1287,7 @@ plot.validateFDboost <- function(x, riskopt=c("mean", "median"), } # Plot the predictions for the optimal mstop - if(4 %in% which | 5 %in% which){ + if(4 %in% which || 5 %in% which){ if(!is.null(x$oobpreds)){ response <- x$response @@ -1347,9 +1354,9 @@ plotPredCoef <- function(x, which = NULL, pers = TRUE, probs = c(0.25, 0.5, 0.75), # quantiles of variables to use for plotting ylim = NULL, ...){ - stopifnot(any(class(x) == "validateFDboost")) + stopifnot(inherits(x, "validateFDboost")) - if(is.null(which)) which <- 1:length(x$coefCV) + if(is.null(which)) which <- seq_along(x$coefCV) oldpar <- par(no.readonly = TRUE) on.exit(par(oldpar)) @@ -1358,7 +1365,7 @@ plotPredCoef <- function(x, which = NULL, pers = TRUE, if(terms){ - if(all(which == 1:length(x$coefCV))){ + if(all(which == seq_along(x$coefCV))){ which <- 1:(length(x$coefCV)+1) }else{ which <- which + 1 @@ -1369,7 +1376,7 @@ plotPredCoef <- function(x, which = NULL, pers = TRUE, return(NULL) } - if(commonRange & is.null(ylim)){ + if(commonRange && is.null(ylim)){ ylim <- range(x$predCV[which]) } @@ -1380,7 +1387,7 @@ plotPredCoef <- function(x, which = NULL, pers = TRUE, funplot(x$yind, unlist(x$predCV[[l]]), id=x$id, col="white", main=names(x$predCV)[l], xlab=attr(x$yind, "nameyind"), ylab="coef", ylim=ylim, ...) - for(i in 1:length(x$predCV[[l]])){ + for(i in seq_along(x$predCV[[l]])){ lines(x$yind[x$id==i], x$predCV[[l]][[i]], lwd=1, col=i) if(showNumbers){ points(x$yind[x$id==i], x$predCV[[l]][[i]], type="p", pch=paste0(i)) @@ -1400,7 +1407,7 @@ plotPredCoef <- function(x, which = NULL, pers = TRUE, }else{ # plot coefficients - if(commonRange & is.null(ylim)){ + if(commonRange && is.null(ylim)){ if(length(x$yind)>1){ if(!any(sapply(lapply(x$coefCV[which], function(x) x$value), is.null))){ ylim <- range(lapply(x$coefCV[which], function(x) x$value)) @@ -1554,8 +1561,8 @@ plot_bootstrapped_coef <- function(temp, l, quanty <- quantile(temp$y, probs=probs, type=1) # set lower triangular matrix to NA for historic effect - if(grepl("bhist", temp$main)){ - for(k in 1:length(temp$value)){ + if(grepl("bhist", temp$main, fixed = TRUE)){ + for(k in seq_along(temp$value)){ temp$value[[k]][temp$value[[k]]==0] <- NA } } @@ -1568,7 +1575,7 @@ plot_bootstrapped_coef <- function(temp, l, # plot coefficient surfaces at different pointwise quantiles if(pers){ matvec <- sapply(temp$value, c) - for(k in 1:length(probs)){ + for(k in seq_along(probs)){ tempZ <- matrix(apply(matvec, 1, quantile, probs=probs[k], na.rm=TRUE), ncol=length(temp$x)) @@ -1578,14 +1585,14 @@ plot_bootstrapped_coef <- function(temp, l, xlab=paste("\n", temp$xlab), ylab=paste("\n", temp$ylab), zlab=paste("\n", "coef"), zlim=if(any(is.null(ylim))) range(matvec, na.rm=TRUE) else ylim, - main=paste(temp$main, " at ", probs[k]*100, "%-quantile", sep=""), + main=paste0(temp$main, " at ", probs[k]*100, "%-quantile"), col=getColPersp(tempZ))) } }else{ # do 2-dim plots - # for(j in 1:length(quanty)){ + # for(j in seq_along(quanty)){ # # myCol <- sapply(temp$value, function(x) x[, quanty[j]==temp$y]) # first column # @@ -1595,7 +1602,7 @@ plot_bootstrapped_coef <- function(temp, l, # # } # end loop over quanty # - # for(j in 1:length(quantx)){ + # for(j in seq_along(quantx)){ # myRow <- sapply(temp$value, function(x) x[quantx[j]==temp$x, ]) # first column # # plot_curves(x_i = temp$x, y_i = myRow, xlab_i = temp$xlab, @@ -1605,7 +1612,7 @@ plot_bootstrapped_coef <- function(temp, l, # } matvec <- sapply(temp$value, c) - for(k in 1:length(probs)){ + for(k in seq_along(probs)){ tempZ <- matrix(apply(matvec, 1, quantile, probs=probs[k], na.rm=TRUE), ncol=length(temp$x)) @@ -1613,7 +1620,7 @@ plot_bootstrapped_coef <- function(temp, l, myargs=list(x=temp$y, y=temp$x, z=t(tempZ), xlab=paste("\n", temp$xlab), ylab=paste("\n", temp$ylab), zlim=c(min(matvec, na.rm=TRUE), max(matvec, na.rm=TRUE)), - main=paste(temp$main, " at ", probs[k]*100, "%-quantile", sep=""), + main=paste0(temp$main, " at ", probs[k]*100, "%-quantile"), col = heat.colors(length(temp$x)^2) ) ) @@ -1626,7 +1633,7 @@ plot_bootstrapped_coef <- function(temp, l, }else{ # temp$x is factor - for(j in 1:length(quantx)){ + for(j in seq_along(quantx)){ # impute matrix of 0 if effect was never chosen temp$value[sapply(temp$value, function(x) is.null(dim(x)))] <- list(matrix(0, ncol=20, nrow=length(quantx))) @@ -1636,7 +1643,7 @@ plot_bootstrapped_coef <- function(temp, l, myRow <- t(temp$value[[which(quantx[j]==temp$x)]]) plot_curves(x_i = temp$y, y_i = myRow, xlab_i = temp$ylab, - main_i = paste(temp$main, " at ", temp$xlab,"=" ,quantx[j], sep = ""), + main_i = paste0(temp$main, " at ", temp$xlab,"=" ,quantx[j]), ylim_i = ylim) }else{ @@ -1644,8 +1651,8 @@ plot_bootstrapped_coef <- function(temp, l, myRow <- sapply(temp$value, function(x) x[quantx[j]==temp$x & quantz[j]==temp$z, ]) # first column plot_curves(x_i = temp$y, y_i = myRow, xlab_i = temp$ylab, - main_i = paste(temp$main, " at ", temp$xlab, "=" , quantx[j], ", " , - temp$zlab, "=", quantz[j], sep = ""), + main_i = paste0(temp$main, " at ", temp$xlab, "=" , quantx[j], ", " , + temp$zlab, "=", quantz[j]), ylim_i = ylim) } } @@ -1668,9 +1675,9 @@ cvrisk.FDboost <- function(object, folds = cvLong(id=object$id, weights=model.we if(!length(unique(object$offset)) == 1) message("The smooth offset is fixed over all folds.") names_bl <- names(object$baselearner) - if(any(grepl("brandomc", names_bl))) message("For brandomc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bolsc", names_bl))) message("For bolsc, the transformation matrix Z is fixed over all folds.") - if(any(grepl("bbsc", names_bl))) message("For bbsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("brandomc", names_bl, fixed = TRUE))) message("For brandomc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bolsc", names_bl, fixed = TRUE))) message("For bolsc, the transformation matrix Z is fixed over all folds.") + if(any(grepl("bbsc", names_bl, fixed = TRUE))) message("For bbsc, the transformation matrix Z is fixed over all folds.") class(object) <- "mboost" @@ -1706,7 +1713,7 @@ cvLong <- function(id, weights = rep(1, l=length(id)), B = B, prob = prob, strata = strata) foldsLong <- folds[id, , drop = FALSE] * weights } - attr(foldsLong, "type") <- paste(B, "-fold ", type, sep = "") + attr(foldsLong, "type") <- paste0(B, "-fold ", type) return(foldsLong) } @@ -1732,7 +1739,7 @@ cvMa <- function(ydim, weights = rep(1, l = ydim[1] * ydim[2]), if ( (nrowY * ncolY) != n) stop("The arguments weights and ydim do not match.") ## cvMa is only a wrapper for cvLong - foldsMa <- cvLong(id = rep(1:nrowY, times = ncolY), weights = weights, + foldsMa <- cvLong(id = rep(seq_len(nrowY), times = ncolY), weights = weights, type = type, B=B, prob = 0.5, strata = NULL) return(foldsMa) } diff --git a/R/factorize.R b/R/factorize.R new file mode 100644 index 0000000..0db82cd --- /dev/null +++ b/R/factorize.R @@ -0,0 +1,359 @@ + +#' Factorize tensor product model +#' +#' Factorize an FDboost tensor product model into the response and covariate parts +#' \deqn{h_j(x, t) = \sum_{k} v_j^{(k)}(t) h_j^{(k)}(x), j = 1, ..., J,} +#' for effect visualization as proposed in Stoecker, Steyer and Greven (2022). +#' +#' @param x a model object of class FDboost. +#' @param ... other arguments passed to methods. +#' +#' @details The mboost infrastructure is used for handling the orthogonal response +#' directions \eqn{v_j^{(k)}(t)} in one \code{mboost}-object +#' (with \eqn{k} running over iteration indices) and the effects into the respective +#' directions \eqn{h_j^{(k)}(t)} in another \code{mboost}-object, +#' both of subclass \code{FDboost_fac}. +#' The number of boosting iterations of \code{FDboost_fac}-objects cannot be +#' further increased as in regular \code{mboost}-objects. +#' +#' @return a list of two mboost models of class \code{FDboost_fac} containing basis functions +#' for response and covariates, respectively, as base-learners. +#' @export +#' +#' @name factorize +#' @aliases factorise factorize.FDboost +#' @importFrom MASS ginv +#' @importFrom Matrix rankMatrix +#' @seealso [FDboost_fac-class] +#' +#' @references +#' Stoecker, A., Steyer L. and Greven, S. (2022): +#' Functional additive models on manifolds of planar shapes and forms +#' +#' +#' +#' @example tests/factorize_test_irregular.R +#' @example tests/factorize_test_regular.R +#' +factorize <- factorise <- function(x, ...) { + UseMethod("factorize") +} + +#' @param newdata new data the factorization is based on. +#' By default (\code{NULL}), the factorization is carried out on the data used for fitting. +#' @param newweights vector of the length of the data or length one, +#' containing new weights used for factorization. +#' @param blwise logical, should the factorization be carried out base-learner-wise (\code{TRUE}, default) +#' or for the whole model simultaneously. +#' +#' @method factorize FDboost +#' @return A factorized model +#' @export +#' @rdname factorize +factorize.FDboost <- function(x, newdata = NULL, newweights = 1, blwise = TRUE, ...) { + + FDboost_regular <- !inherits(x, c("FDboostScalar", "FDboostLong")) + + nd <- !is.null(newdata) + + # built subdata + dat <- list() + dat$cov <- if(!nd) x$data + else newdata[names(x$data)] + dat$cov[[x$yname]] <- rep(1, min(lengths(dat$cov))) + if(is.list(x$yind)) { + dat$resp <- if(!nd) x$yind else newdata[names(x$yind)] + } else { + dat$resp <- if(!nd) setNames(list(x$yind), + attr(x$yind, "nameyind")) else + newdata[attr(x$yind, "nameyind")] + } + dat$resp <- as.data.frame(dat$resp) + dat$resp[[x$yname]] <- 1 + + # extract formulae + formulae <- list() + formulae$cov <- as.formula(x$formulaFDboost) + formulae$resp <- as.formula(paste(x$yname, x$timeformula)) + + # set up component models + mod <- list() + # standard mboost model for covariates + mod$cov <- mboost(formulae$cov, + data = dat$cov, + offset = 0, + control = boost_control(mstop = 0, nu = 1)) + # artificial FDboost intercept model for response + mod$resp <- mboost(formulae$resp, + data = dat$resp, + offset = if(FDboost_regular) + matrix(x$offset, nrow = x$ydim[1])[1,] else + x$offset, + control = boost_control(mstop = 0, nu = 1)) + # copy essential parts from base model to response + which_vars <- c("yname", "ydim", "predictOffset", "withIntercept", + "callEval", "timeformula", "formulaFDboost", + "formulaMboost", "family", "(weights)", "id") + cls <- class(mod$resp) + mod$resp[which_vars] <- unclass(x)[which_vars] + if(FDboost_regular) mod$resp$ydim <- c(1, x$ydim[2]) + mod$resp$yind <- range(x$yind) + attr(mod$resp$yind, "nameyind") <- attr(x$yind, "nameyind") + if(FDboost_regular) + class(mod$resp) <- c("FDboostLong", class(x)) else + class(mod$resp) <- class(x) + + if(nd) { + if(length(newweights)==1) + mod$resp[["(weights)"]] <- rep(newweights, length(dat$resp[[x$yname]])) else { + stopifnot(length(newweights) == length(dat$resp[[x$yname]])) + mod$resp[["(weights)"]] <- newweights + } + mod$resp$id <- newdata[[attr(mod$resp$id, "nameid")]] + } + + # set to FDboost_fac class + for(i in names(mod)) + class(mod[[i]]) <- c("FDboost_fac", class(mod[[i]])) + + # get coefficients (only of selected learners) + bl_selected <- x$which(usedonly = TRUE) + cf <- coef(x, raw = TRUE, which = bl_selected) + + # extract design matrices + + X <- list( + cov = extract(mod$cov, what = "design", which = bl_selected), + resp = extract(mod$resp, what = "design", which = 1) + ) + index <- list( + cov = extract(mod$cov, what = "index", which = bl_selected), + resp = extract(mod$resp, what = "index", which = 1) + ) + + wghts <- mod$resp$`(weights)` + + if(is.null(wghts)) { + wghts <- list(cov = 1, resp = 1) + } else { + if(FDboost_regular) { + + dim(wghts) <- x$ydim + wghts <- list( + cov = rowMeans(wghts), + resp = wghts[1, ] + ) + } else { + wghts <- list(cov = as.vector(tapply(wghts, mod$resp$id, mean))) + wghts$resp <- mod$resp[["(weights)"]] / wghts$cov[mod$resp$id] + } + } + + wghts <- Map(function(w, idx) { + lapply(idx, function(i) { + if(is.null(i)) w else + c(tapply(w, i, sum)) + }) + }, wghts, index) + + # multiply sqrt(weights) to X to take them into account + X <- Map(function(x,w) { + Map(function(.x, .w) sqrt(.w) * .x, x,w) + }, X, wghts) + # NOTE: X is now sqrt(w) * X ! + + # do QR decomposition to achieve orthonormal basis representation + QR <- lapply(X, lapply, qr) + ## extract Q as orthonormal version of X + # Q <- lapply(QR, lapply, qr.Q) # not necessary + + # transform cf accordingly + R <- lapply(QR, lapply, function(x) { + if(inherits(x, "qr")) + qr.R(x)[, order(x$pivot)] else + qrR(x, backPermute = TRUE) }) + + cf <- Map(matrix, cf, nrow = lapply(X$cov, ncol), byrow = !FDboost_regular) + cf <- Map(function(r1, o) r1 %*% tcrossprod(o, R$resp[[1]]), R$cov, cf) + + # perform SVD on cf + if(blwise) { + SVD <- lapply(cf, svd) + Ud <- lapply(SVD, function(x) sweep(x$u, 2, x$d, "*")) + d2 <- list(cov = lapply(SVD, function(x) (x$d)^2)) + V <- lapply(SVD, `[[`, "v") + rm(SVD) + } else { + cf <- do.call(rbind, cf) + SVD <- svd(cf) + cfidx <- relist(seq_len(nrow(cf)), + lapply(X$cov, function(x) numeric(ncol(x)))) + Ud <- lapply(cfidx, function(idx) + sweep(SVD$u[idx, , drop = FALSE], 2, SVD$d, "*")) + d2 <- list( + cov = lapply(Ud, function(ud) colSums(ud^2)), + resp = SVD$d^2 + ) + V <- list(model = SVD$v) + rm(SVD) + } + + # compute new coefs + d_max <- sqrt(max(unlist(d2))) + if(d_max == 0) d_max <- 1 + cf <- list() + my_solve <- function(a, b) { + ret <- try(solve(a, b), silent = TRUE) + if(inherits(ret, "try-error")) { + ret <- ginv(a) %*% b + } + ret + } + cf$cov <- Map(function(R, du) { + as.matrix(my_solve(R, du)) / d_max + }, R$cov, Ud) + cf$resp <- setNames( + lapply(V, my_solve, a = R$resp[[1]] / d_max), + nm = if(blwise) + paste0(names(X$resp)[1], " [", names(X$cov), "]") else + names(X$resp)[1] + ) + .no_mat <- which(!sapply(cf$resp, is.matrix)) + cf$resp[.no_mat] <- + lapply(cf$resp[.no_mat], as.matrix) + # drop dimension discrepancies + if(length(cf$cov) == length(cf$resp)) { + for(bl in seq_along(cf$cov)) { + nc <- min(NCOL(cf$cov[[bl]]), NCOL(cf$resp[[bl]])) + cf$cov[[bl]] <- cf$cov[[bl]][, 1:nc, drop = FALSE] + cf$resp[[bl]] <- cf$resp[[bl]][, 1:nc, drop = FALSE] + } + } + for(bl in seq_along(cf$cov)) { + d2$cov[[bl]] <- head(d2$cov[[bl]], NCOL(cf$cov[[bl]])) + } + + # decomposition complete - now prepare output --------------- + + # get model environments + e <- lapply(mod, function(m) environment(m$predict)) + + # clone and equip baselearners + bl_dims <- lapply(cf, sapply, NCOL) + # vector for cloning bls + bl_mltpl <- list( + cov = rep(seq_along(bl_dims$cov), bl_dims$cov), + resp = rep(1, sum(bl_dims$resp)) + ) + bl_names <- Map(function(.cf, .bl_dims) + unlist(Map(function(name, len) paste0(name, " [", seq_len(len), "]"), + names(.cf), .bl_dims), use.names = FALSE), + cf, bl_dims) + # order of newly generated bls with respect to their variance + d2l <- lapply(d2, unlist) + bl_order <- Map(function(bmlt, d2) order(bmlt)[order(d2, decreasing = TRUE)], + bl_mltpl, d2l) + + for(i in names(mod)) { + this_select <- if(i=="cov") bl_selected else 1 + mod[[i]]$baselearner <- e[[i]]$blg <- setNames( + e[[i]]$blg[this_select][bl_mltpl[[i]]], bl_names[[i]]) + mod[[i]]$basemodel <- e[[i]]$bl <- setNames( + e[[i]]$bl[this_select][bl_mltpl[[i]]], bl_names[[i]]) + e[[i]]$bnames <- bl_names[[i]] + # fill in coefs with bl order decreasing with explained variance + e[[i]]$xselect <- bl_order[[i]] + e[[i]]$ens <- unlist(lapply(cf[[i]], asplit, 2), recursive = FALSE) + e[[i]]$ens <- Map( function(x, cls) { + bm <- list(model = x) + class(bm) <- gsub("bl", "bm", cls, fixed = TRUE) + bm + }, + x = e[[i]]$ens[bl_order[[i]]], + cls = lapply(mod[[i]]$basemodel, class)[bl_order[[i]]]) + # add risk + this_d2l <- d2l[[i]] + if(is.null(this_d2l)) + this_d2l <- d2l[[1]] + e[[i]]$mrisk <- sum(this_d2l) - + cumsum(c(0,sort(this_d2l, decreasing = TRUE))) + # engage full number of components + mod[[i]]$subset(sum(this_d2l>0)) + } + + # return factor models + mod +} + + +# define class and methods ---------------------------------------------------- + +#' @importFrom methods setOldClass +#' @exportClass FDboost_fac + +setOldClass("FDboost_fac") + +#' `FDboost_fac` S3 class for factorized FDboost model components +#' +#' @description Model factorization with `factorize()` decomposes an +#' `FDboost` model into two objects of class `FDboost_fac` - one for the +#' response and one for the covariate predictor. The first is essentially +#' an `FDboost` object and the second an `mboost` object, however, +#' in a 'read-only' mode and slightly adjusted methods (method defaults). +#' +#' @name FDboost_fac-class +#' @seealso [factorize(), factorize.FDboost()] +NULL + + + +#' Prediction and plotting for factorized FDboost model components +#' +#' @param object,x a model-factor given as a \code{FDboost_fac} object +#' @param newdata optionally, a data frame or list +#' in which to look for variables with which to predict. +#' See \code{\link[mboost]{predict.mboost}}. +#' @param which a subset of base-learner components to take into +#' account for computing predictions or coefficients. Different +#' components are never aggregated to a joint prediction, but always +#' returned as a matrix or list. Select the k-th component +#' by name in the format \code{bl(x, ...)[k]} or all components of a base-learner +#' by dropping the index or all base-learners of a variable by using +#' the variable name. +#' @param main the plot title. By default, base-learner names are used with +#' component numbers \code{[k]}. +#' @param ... additional arguments passed to underlying methods. +#' +#' @method predict FDboost_fac +#' +#' @export +#' @name predict.FDboost_fac +#' @aliases plot.FDboost_fac +#' @return A matrix of predictions (for predict method) or no +#' return value (plot method) +#' @seealso [factorize(), factorize.FDboost()] +#' +predict.FDboost_fac <- function(object, newdata = NULL, which = NULL, ...) { + w <- object$which(which) + if(anyNA(w)) + stop("Don't know 'which' base-learner is meant.") + names(w) <- names(object$baselearner)[w] + drop(sapply(w, + function(x) predict.mboost(which = x, + object = object, + newdata = newdata, + aggregate = "sum", ...))) +} + +#' @method plot FDboost_fac +#' @rdname predict.FDboost_fac +plot.FDboost_fac <- function(x, which = NULL, main = NULL, ...) { + w <- x$which(which, usedonly = TRUE) + if(anyNA(w)) + stop(paste("Don't know which base-learner is meant by:", + which[which.min(is.na(w))])) + if(is.null(main)) + main <- names(x$baselearner)[w] + for(i in seq_along(w)) + plot.mboost(x, which = w[i], main = main[i], ...) +} diff --git a/R/hmatrix.R b/R/hmatrix.R index a4c38a4..fef32bd 100644 --- a/R/hmatrix.R +++ b/R/hmatrix.R @@ -15,7 +15,7 @@ #' @param id specify to which curve the point belongs to, id from 1, 2, ..., n. #' @param x matrix of functional covariate, each trajectory is in one row #' @param argvals set of argument values, i.e., the common gird at which the functional covariate -#' is observed, by default \code{1:ncol(x)} +#' is observed, by default \code{seq_len(ncol(x))} #' @param timeLab name of the time axis, by default \code{t} #' @param idLab name of the id variable, by default \code{wideIndex} #' @param xLab name of the functional variable, by default NULL @@ -57,7 +57,7 @@ #' # ids and times in the time id matrix #' # for bhistx baselearner, there may be an additional id variable for the tensor product #' newdat <- reweightData(data = list(hmat = myhmatrix, -#' repIDx = rep(1:nrow(attr(myhmatrix,'x')), length(attr(myhmatrix,"argvals")))), +#' repIDx = rep(seq_len(nrow(attr(myhmatrix,'x'))), length(attr(myhmatrix,"argvals")))), #' vars = "hmat", index = c(1,1,2), idvars="repIDx") #' length(newdat$repIDx) #' @@ -66,21 +66,23 @@ #' str(mydat) #' str(mydat[id1 %in% c(2, 3), ]) #' str(myhmatrix[id1 %in% c(2, 3), ]) +#' +#' @return An matrix object of type \code{"hmatrix"} #' #' @export -hmatrix <- function(time, id, x, argvals=1:ncol(x), +hmatrix <- function(time, id, x, argvals=seq_len(ncol(x)), timeLab="t", idLab="wideIndex", xLab="x", argvalsLab="s"){ ## check that id is integer valued containing 1, 2, 3, ..., n ## and that x has n rows - stopifnot( all(sort(unique(id)) == 1:nrow(x)) ) + stopifnot( all(sort(unique(id)) == seq_len(nrow(x))) ) stopifnot(length(time)==length(id)) # convert x to a matrix, especially if x is of class AsIs x <- matrix(x, ncol=ncol(x), nrow=nrow(x)) #### check argvals and x - if( any(duplicated(argvals)) ){ + if(anyDuplicated(argvals) > 0){ stop("argvals contains duplicates.") } if( is.unsorted(argvals) ){ @@ -120,7 +122,7 @@ hmatrix <- function(time, id, x, argvals=1:ncol(x), #' @seealso \code{\link{hmatrix}} for the h.atrix class. #' #' @aliases getId getX getArgvals getTimeLab getIdLab getXLab getArgvalsLab -#' +#' @return properties of a hmatrix or fmatrix #' @export getTime <- function(object) { UseMethod("getTime", object) } @@ -165,6 +167,7 @@ getArgvalsLab <- function(object) { UseMethod("getArgvalsLab", object) } #' \code{getIdLab}, \code{getXLab}, \code{getArgvalsLab} for an object of class \code{hmatrix}. #' #' @aliases getId.hmatrix getX.hmatrix getArgvals.hmatrix getTimeLab.hmatrix getXLab.hmatrix getArgvalsLab.hmatrix +#' @return properties of a hmatrix #' #' @export getTime.hmatrix <- function(object) object[ , 1, drop=TRUE] @@ -203,7 +206,7 @@ getArgvalsLab.hmatrix <- function(object) attr(object, "argvalsLab") #' #' is.hmatrix tests if its argument is an object of class hmatrix. #' @param object object of class hmatrix -#' +#' @return logical value #' @export is.hmatrix <- function(object){ inherits(object, "hmatrix") @@ -231,7 +234,7 @@ is.hmatrix <- function(object){ #' From the functional covariate \code{x} rows are selected accordingly. #' #' @seealso ?"[" -#' +#' @return a \code{"hmatrix"} object #' @export `[.hmatrix` <- function(x, i, j, ..., drop=FALSE) { @@ -255,7 +258,7 @@ is.hmatrix <- function(object){ if(missing(j) || is.symbol(j)){ tempId <- r[ ,2] # get the id of the corresponding rows - tempId <- (1:length(unique(tempId)))[factor(tempId)] # transform the id to 1, 2, 3, ... + tempId <- (seq_along(unique(tempId)))[factor(tempId)] # transform the id to 1, 2, 3, ... return( hmatrix(time=r[ ,1], id=tempId, x=xAttr$x[unique(r[ ,2]), , drop=FALSE], argvals = xAttr$argvals, @@ -272,7 +275,7 @@ is.hmatrix <- function(object){ #' repeated accordingly so that two vectors of the same length are returned. #' @param time the observation points #' @param id the id for the curve -#' +#' @return a list with \code{time} and \code{id} #' @export wide2long <- function(time, id){ newtime <- rep(time, each=length(unique(id))) @@ -303,6 +306,8 @@ wide2long <- function(time, id){ #' try(resMat2 <- subset_hmatrix(resMat, index = index2)) #' resMat <- subset_hmatrix(hmat, index = index1, compress = FALSE) #' try(resMat2 <- subset_hmatrix(resMat, index = index2)) +#' +#' @return a \code{hmatrix} object #' #' @export subset_hmatrix <- function(x, index, compress = TRUE) @@ -327,7 +332,7 @@ subset_hmatrix <- function(x, index, compress = TRUE) resMat <- rbind(resMat, matrix(c(rep(t, sum(idInT)), # for time points in hmatrix index[idInT], # for id in hmatrix - (1:length(index))[idInT]), # for idvars + (seq_along(index))[idInT]), # for idvars ncol=3)) } @@ -340,7 +345,7 @@ subset_hmatrix <- function(x, index, compress = TRUE) # id with duplicates idvars <- c(factor(resMat[,2])) # correct ordering - idvars <- (1:length(unique(idvars)))[factor(idvars)] + idvars <- (seq_along(unique(idvars)))[factor(idvars)] # rewrite index for actual matrix index <- unique(index) diff --git a/R/methods.R b/R/methods.R index 2e62829..ebad9d9 100644 --- a/R/methods.R +++ b/R/methods.R @@ -78,7 +78,7 @@ print.FDboost <- function(x, ...) { #' Takes a fitted \code{FDboost}-object produced by \code{\link{FDboost}()} and produces #' predictions given a new set of values for the model covariates or the original #' values used for the model fit. This is a wrapper -#' function for \code{\link[mboost:methods]{predict.mboost}()} +#' function for \code{\link[mboost]{predict.mboost}()} #' #' @param object a fitted \code{FDboost}-object #' @param newdata a named list or a data frame containing the values of the model @@ -94,7 +94,7 @@ print.FDboost <- function(x, ...) { #' @param toFDboost logical, defaults to \code{TRUE}. In case of regular response in wide format #' (i.e. response is supplied as matrix): should the predictions be returned as matrix, or list #' of matrices instead of vectors -#' @param ... additional arguments passed on to \code{\link[mboost:methods]{predict.mboost}()}. +#' @param ... additional arguments passed on to \code{\link[mboost]{predict.mboost}()}. #' #' @seealso \code{\link{FDboost}} for the model fit #' and \code{\link{plotPredicted}} for a plot of the observed values and their predictions. @@ -104,16 +104,16 @@ print.FDboost <- function(x, ...) { # predict function: wrapper for predict.mboost() predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TRUE, ...){ - stopifnot(any(class(object) == "FDboost")) + stopifnot(inherits(object, "FDboost")) # print("Prediction FDboost") dots <- list(...) # toFDboost is only meaningful for array-data - if(any(class(object) == "FDboostScalar") | any(class(object) == "FDboostLong")) toFDboost <- FALSE + if(inherits(object, c("FDboostScalar", "FDboostLong"))) toFDboost <- FALSE if(!is.null(dots$aggregate) && dots$aggregate[1] != "sum"){ if(length(which) > 1 ) stop("For aggregate != 'sum', only one effect, or which=NULL are possible.") - if(toFDboost & class(object)[1] == "FDboost"){ + if(toFDboost && class(object)[1] == "FDboost"){ toFDboost <- FALSE warning("Set toFDboost to FALSE, as aggregate != 'sum'. Prediction is in long vector.") } @@ -146,11 +146,11 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR # try to get more reliable information on n (number of trajectories) # and on lengthYind (length of time) # using the hmatrix-objects in newdata if available - if(is.list(newdata) | is.data.frame(newdata)){ + if(is.list(newdata) || is.data.frame(newdata)){ classes <- lapply(newdata, class) alln <- c() alllengthYind <- c() - for(i in 1:length(classes)){ + for(i in seq_along(classes)){ if( any(classes[[i]] == "hmatrix" ) ){ # number of trajectories n <- length(unique(newdata[[i]][,2]) ) @@ -185,10 +185,10 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR n <- 1 lengthYind <- length(newdata[[nameyind]]) - if(is.list(newdata) | is.data.frame(newdata)){ + if(is.list(newdata) || is.data.frame(newdata)){ classes <- lapply(newdata, class) alllengthYind <- c(lengthYind) - for(i in 1:length(classes)){ + for(i in seq_along(classes)){ if( any(classes[[i]] == "hmatrix" ) ){ # total number of observation points lengthYind <- length(newdata[[i]][,1]) @@ -220,7 +220,7 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR posBconc <- grep("bconcurrent(", names(object$baselearner), fixed = TRUE) posBhist <- grep("bhist(", names(object$baselearner), fixed = TRUE) whichHelp <- which - if(is.null(which)) whichHelp <- 1:length(object$baselearner) + if(is.null(which)) whichHelp <- seq_along(object$baselearner) posBsignal <- whichHelp[whichHelp %in% posBsignal] posBconc <- whichHelp[whichHelp %in% posBconc] posBhist <- whichHelp[whichHelp %in% posBhist] @@ -232,9 +232,9 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR indname <- attr(object$baselearner[[i]]$get_data()[[xname]], "indname") # does not work for %X% ## if two ore more base-learners are connected by %X%, find the functional variable ## the loop is necessary if more than one functioal covaraites are used in the same bl - if(grepl("%X", names(object$baselearner)[i])){ - form <- strsplit(object$baselearner[[i]]$get_call(), "%X")[[1]] - findFun <- grepl("bhist", form) | grepl("bconcurrent", form) | grepl("bsignal", form) | grepl("bfpc", form) + if(grepl("%X", names(object$baselearner)[i], fixed = TRUE)){ + form <- strsplit(object$baselearner[[i]]$get_call(), "%X", fixed = TRUE)[[1]] + findFun <- grepl("bhist", form, fixed = TRUE) | grepl("bconcurrent", form, fixed = TRUE) | grepl("bsignal", form, fixed = TRUE) | grepl("bfpc", form, fixed = TRUE) xname <- c() indname <- c() for(j in which(findFun)){ @@ -253,7 +253,7 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR indnameY <- NULL } - for(j in 1:length(xname)){ + for(j in seq_along(xname)){ attr(newdata[[xname[j]]], "indname") <- indname[j] attr(newdata[[xname[j]]], "xname") <- xname[j] attr(newdata[[xname[j]]], "signalIndex") <- if(indname[j]!="xindDefault") newdata[[indname[j]]] else seq(0,1,l=ncol(newdata[[xname[j]]])) @@ -282,14 +282,14 @@ predict.FDboost <- function(object, newdata = NULL, which = NULL, toFDboost = TR # offset of length>1 is not used in prediction, # important when offset=NULL in FDboost() but not in mboost() muffleWarning1 <- function(w){ - if( any( grepl( "User-specified offset is not a scalar", w) ) ) + if( any( grepl("User-specified offset is not a scalar", w, fixed = TRUE) ) ) invokeRestart( "muffleWarning" ) } ## predict all effects together, model-inherent offset is included automatically if(is.null(which)){ - if(is.null(object$offsetFDboost) & !is.null(object$offsetMboost) ){ + if(is.null(object$offsetFDboost) && !is.null(object$offsetMboost) ){ # offset=NULL in FDboost, but not in mboost ## suppress the warning that the offset cannot be used if offset=NULL in FDboost ## as offset is predicted and included in prediction @@ -438,7 +438,7 @@ fitted.FDboost <- function(object, toFDboost = TRUE, ...) { if (length(args) == 0) { ## give back matrix for regular response and toFDboost == TRUE - if(toFDboost & !any(class(object) == "FDboostScalar") & !any(class(object) == "FDboostLong") ){ + if(toFDboost && !inherits(object, "FDboostScalar") && !inherits(object, "FDboostLong") ){ ret <- matrix(object$fitted(), nrow = object$ydim[1]) }else{ # give back a long vector ret <- object$fitted() @@ -478,8 +478,10 @@ fitted.FDboost <- function(object, toFDboost = TRUE, ...) { ### residuals (the current negative gradient) residuals.FDboost <- function(object, ...){ - if(!any(class(object)=="FDboostLong")){ - resid <- matrix(object$resid(), nrow=object$ydim[1]) + if(!inherits(object, "FDboostLong")){ + resid <- matrix(object$resid()) + ydim <- ifelse(is.null(object$ydim[1]), NROW(resid), object$ydim[1]) + resid <- matrix(resid, nrow = ydim) resid[is.na(object$response)] <- NA }else{ resid <- object$resid() @@ -502,7 +504,7 @@ residuals.FDboost <- function(object, ...){ #' If \code{raw = TRUE} the coefficients of the model are returned. #' @param which a subset of base-learners for which the coefficients #' should be computed (numeric vector), -#' defaults to NULL which is the same as \code{which=1:length(object$baselearner)}. +#' defaults to NULL which is the same as \code{which=seq_along(object$baselearner)}. #' In the special case of \code{which=0}, only the coefficients of the offset are returned. #' @param computeCoef defaults to \code{TRUE}, if \code{FALSE} only the names of the terms are returned #' @param returnData return the dataset which is used to get the coefficient estimates as @@ -562,7 +564,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ret$offset$main <- "offset" # For the special case of which=0, only return the coefficients of the offset - if(!is.null(which) & length(which)==1 && which==0){ + if(!is.null(which) && length(which)==1 && which==0){ if(computeCoef){ return(ret) }else{ @@ -570,7 +572,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, } } - if(is.null(which)) which <- 1:length(object$baselearner) + if(is.null(which)) which <- seq_along(object$baselearner) ## special case of ~1 intercept specification with scalar response if( inherits(object, "FDboostScalar") && @@ -601,7 +603,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, numberLevels <- 1 ### generate data in the case of an bhistx()-bl - if(grepl("bhistx", trm$get_call())){ + if(grepl("bhistx", trm$get_call(), fixed = TRUE)){ ng <- n2 # get hmatrix-object position_hmatrix <- which(sapply(trm$model.frame(), is.hmatrix)) @@ -612,10 +614,10 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, tvals <- seq(min(tvals), max(tvals), length = ng) tvals <- rep(tvals, each = ng) - if( grepl("%X", trm$get_call()) ){ + if( grepl("%X", trm$get_call(), fixed = TRUE) ){ split_bl <- strsplit(trm$get_call(), split = "%.{1,3}%")[[1]] ## save the position of bhistx() - position_bhistx <- which(grepl("bhistx", split_bl)) + position_bhistx <- grep("bhistx", split_bl, fixed = TRUE) if(length(split_bl) == 2){ # one %X% if(position_bhistx == 1){ @@ -665,7 +667,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, attr(d, "ym") <- seq(min(tvals), max(tvals), length = ng) ## for a tensor product term: add the scalar factors to d - if( grepl("%X", trm$get_call()) ){ + if( grepl("%X", trm$get_call(), fixed = TRUE) ){ if(position_hmatrix == 1){ position_z <- 2 }else{ @@ -720,9 +722,9 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, }else{ # two %X% z1levels <- sort(unique(z1)) temp_d <- 1 - for(j in 1:length(zlevels)){ # loop over z + for(j in seq_along(zlevels)){ # loop over z d[[ trm$get_names()[position_z] ]] <- zlevels[j] # use j-th factor level of z - for(k in 1:length(z1levels)){ # loop over z1 + for(k in seq_along(z1levels)){ # loop over z d[[ trm$get_names()[position_z1] ]] <- z1levels[k] # use k-th factor level of z1 attr(d, "add_main") <- paste0(trm$get_names()[position_z], "=", zlevels[j], ", ", trm$get_names()[position_z1], "=", z1levels[k]) @@ -825,7 +827,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, }else{ ### functional response ## not bhist - if( ! grepl("bhist", trm$get_call()) ){ + if( ! grepl("bhist", trm$get_call(), fixed = TRUE) ){ ## y (time variable, usually second variable) ## important in case of by-variables, then yind is third variable @@ -927,7 +929,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## add dummy signal to data for bsignal() - if(grepl("bsignal", trm$get_call()) | grepl("bfpc", trm$get_call()) ){ + if (grepl("bsignal|bfpc", trm$get_call())) { position_signal <- which(sapply(trm$model.frame(), function(x) !is.null(attr(x, "signalIndex")) )) @@ -942,7 +944,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## as they cannot be included into the variable x(s) ## use intFun() to compute the integration weights # ls(environment(trm$dpp)) - if(grepl("bhist", trm$get_call()) ){ + if(grepl("bhist", trm$get_call(), fixed = TRUE) ){ ## temp <- I(diag(ng)/integrationWeightsLeft(diag(ng), d[[varnms[1]]])) ## use intFun() of the bl to compute the integration weights temp <- environment(trm$dpp)$args$intFun(diag(ng), d[[attr(object$yind, "nameyind")]]) @@ -954,7 +956,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, } ## add dummy signal to data for bconcurrent() - if(grepl("bconcurrent", trm$get_call())){ + if(grepl("bconcurrent", trm$get_call(), fixed = TRUE)){ d[[ trm$get_names()[1] ]] <- I(matrix(rep(1.0, ng^2), ncol=ng)) } @@ -973,20 +975,20 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, # if %X% was used in combination with factor variables make a list of data-frames - if(!inherits(object, "FDboostLong") && grepl("%X", trm$get_call())){ + if(!inherits(object, "FDboostLong") && grepl("%X", trm$get_call(), fixed = TRUE)){ dlist <- NULL ## if %X% was used in combination with factor variables make a list of data-frames - if(is.factor(x) & is.factor(z)){ ## both variables are factors + if(is.factor(x) && is.factor(z)){ ## both variables are factors numberLevels <- nlevels(x) * nlevels(z) xlevels <- sort(unique(x)) zlevels <- sort(unique(z)) dlist <- vector("list", numberLevels) temp_d <- 1 - for(j in 1:length(xlevels)){ # loop over x + for(j in seq_along(xlevels)){ # loop over x d[[1]] <- xlevels[j] # use j-th factor level of x - for(k in 1:length(zlevels)){ # loop over z + for(k in seq_along(zlevels)){ # loop over z d[[3]] <- zlevels[k] # use k-th factor level of z attr(d, "xm") <- d[[1]] attr(d, "zm") <- d[[3]] @@ -1001,7 +1003,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, numberLevels <- nlevels(z) zlevels <- sort(unique(z)) dlist <- vector("list", numberLevels) - for(j in 1:length(zlevels)){ # loop over z + for(j in seq_along(zlevels)){ # loop over z d[[3]] <- rep(zlevels[j], length(d[[1]])) # use j-th factor level of z attr(d, "zm") <- d[[3]] attr(d, "add_main") <- paste0(names(d)[3], "=", zlevels[j]) @@ -1012,7 +1014,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, numberLevels <- nlevels(x) xlevels <- sort(unique(x)) dlist <- vector("list", numberLevels) - for(j in 1:length(xlevels)){ # loop over x + for(j in seq_along(xlevels)){ # loop over x d[[1]] <- rep(xlevels[j], length(d[[3]])) # use j-th factor level of x attr(d, "xm") <- d[[1]] attr(d, "add_main") <- paste0(names(d)[1], "=", xlevels[j]) @@ -1024,7 +1026,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, numberLevels <- n4 zlevels <- seq(min(z), max(z), l = n4) dlist <- vector("list", numberLevels) - for(j in 1:length(zlevels)){ # loop over x + for(j in seq_along(zlevels)){ # loop over x d[[3]] <- rep(zlevels[j], length(d[[1]])) # use j-th quantile of x attr(d, "zm") <- d[[1]] attr(d, "add_main") <- paste0(names(d)[3], "=", round(zlevels[j], 2)) @@ -1048,8 +1050,8 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, if(!is.matrix(predHelp)){ X <- predHelp }else{ - X <- if(any(trm$get_names() %in% c("ONEtime")) | - any(class(object)=="FDboostScalar")){ # effect constant in t + X <- if(any(trm$get_names() %in% "ONEtime") || + inherits(object, "FDboostScalar")){ # effect constant in t predHelp[,1] }else{ predHelp[1,] # smooth intercept/ concurrent effect @@ -1066,7 +1068,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## for bhist(), multiply with standardisation weights if necessary ## you need the args$vecStand from the prediction of X, constructed here - if(grepl("bhist", trm$get_call())){ + if(grepl("bhist", trm$get_call(), fixed = TRUE)){ myargsHist <- myargs ## use the args found in makeDataGrid() ## this should only occur for more than two %X% @@ -1108,13 +1110,13 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, z=attr(d, "zm"), zlab=varnms[3], vecStand=vecStand) ## include the second scalar covariate called z1 into the output - if( grepl("bhistx", trm$get_call()) & length(trm$get_names()) > 2){ + if( grepl("bhistx", trm$get_call(), fixed = TRUE) && length(trm$get_names()) > 2){ extra_output <- list(z1=attr(d, "z1m"), z1lab=varnms[4]) P <- c(P, extra_output) } ## save the arguments of stand and limits as part of returned object - if(grepl("bhist", trm$get_call())){ + if(grepl("bhist", trm$get_call(), fixed = TRUE)){ P$stand <- myargsHist$stand P$limits <- myargsHist$limits } @@ -1149,8 +1151,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, trm <- object$baselearner[[i]] trm$dim <- length(trm$get_names()) - if(any(grepl("ONEx", trm$get_names()), - grepl("ONEtime", trm$get_names()))) trm$dim <- trm$dim - 1 + if(any(grepl("ONE(x|time)", trm$get_names()))) trm$dim <- trm$dim - 1 ### give error for bl1 %X% bl2 %X% bl3 #if( grepl("bhistx", trm$get_call()) & trm$dim > 2){ @@ -1158,18 +1159,18 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, #} ## add 1 to dimension of bhist and bhistx, otherwise dim is only 1 - if( grepl("bhist", trm$get_call()) ){ + if( grepl("bhist", trm$get_call(), fixed = TRUE) ){ trm$dim <- trm$dim + 1 } # If a by-variable was specified, reduce number of dimensions # as smooth linear effect in several groups can be plotted in one plot - if( grepl("by =", trm$get_call()) && grepl("bols", trm$get_call()) || - grepl("by =", trm$get_call()) && grepl("bbs", trm$get_call()) ) trm$dim <- trm$dim - 1 + if( grepl("by =", trm$get_call(), fixed = TRUE) && grepl("bols", trm$get_call(), fixed = TRUE) || + grepl("by =", trm$get_call(), fixed = TRUE) && grepl("bbs", trm$get_call(), fixed = TRUE) ) trm$dim <- trm$dim - 1 # what to do with bbs(..., by=factor)? - if(trm$dim > 3 & !grepl("bhistx", trm$get_call()) ){ + if(trm$dim > 3 && !grepl("bhistx", trm$get_call(), fixed = TRUE) ){ warning("Can't deal with smooths with more than 3 dimensions, returning NULL for ", shrtlbls[i], ".") return(NULL) @@ -1178,28 +1179,27 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, d <- makeDataGrid(trm) ### better solution for %X% in base-learner!!! - if(!is.null(object$ydim) && any(grepl("%X", trm$get_call())) - && !any(grepl("bhistx", trm$get_call())) ) trm$dim <- trm$dim - 1 + if(!is.null(object$ydim) && any(grepl("%X", trm$get_call(), fixed = TRUE)) + && !any(grepl("bhistx", trm$get_call(), fixed = TRUE)) ) trm$dim <- trm$dim - 1 ## it is necessary to expand the dataframe! if(!grepl("bhistx(", trm$get_call(), fixed=TRUE) && - inherits(object, "FDboostLong") && !grepl("bconcurrent", trm$get_call())){ + inherits(object, "FDboostLong") && !grepl("bconcurrent", trm$get_call(), fixed = TRUE)){ #print(attr(d, "varnms")) vari <- names(d)[1] if(is.factor(d[[vari]])){ - d[[vari]] <- d[[vari]][ rep(1:NROW(d[[vari]]), times=length(d[[attr(object$yind ,"nameyind")]]) ) ] + d[[vari]] <- d[[vari]][ rep(seq_len(NROW(d[[vari]])), times=length(d[[attr(object$yind ,"nameyind")]]) ) ] if(trm$dim>1) d[[attr(object$yind ,"nameyind")]] <- rep(d[[attr(object$yind ,"nameyind")]], each=length(unique(d[[vari]])) ) }else{ # expand signal variable - if( grepl("bhist(", trm$get_call(), fixed = TRUE) | - grepl("bsignal", trm$get_call()) | grepl("bfpc", trm$get_call()) ){ + if (grepl("bhist\\(|bsignal|bfpc", trm$get_call())) { vari <- names(d)[!names(d) %in% attr(d, "varnms")] - d[[vari]] <- d[[vari]][ rep(1:NROW(d[[vari]]), times=NROW(d[[vari]])), ] + d[[vari]] <- d[[vari]][ rep(seq_len(NROW(d[[vari]])), times=NROW(d[[vari]])), ] }else{ # expand scalar variable vari <- names(d)[1] - if(vari!=attr(object$yind ,"nameyind")) d[[vari]] <- d[[vari]][ rep(1:NROW(d[[vari]]), times=NROW(d[[vari]])) ] + if(vari!=attr(object$yind ,"nameyind")) d[[vari]] <- d[[vari]][ rep(seq_len(NROW(d[[vari]])), times=NROW(d[[vari]])) ] } # expand yind if(trm$dim>1) d[[attr(object$yind ,"nameyind")]] <- rep(d[[attr(object$yind ,"nameyind")]], @@ -1209,14 +1209,14 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ###### just return the data, that is used for the prediction if(returnData){ - if(grepl("bhist", trm$get_call())){ + if(grepl("bhist", trm$get_call(), fixed = TRUE)){ message("If argument stand is specified !=\"no\", the standardization will be part of the predicted coefficient.") } return(d) } if( !is.null(attr(d, "numberLevels")) && attr(d, "numberLevels") > 1){ - if( grepl("bhistx", trm$get_call()) ) trm$dim <- 2 + if( grepl("bhistx", trm$get_call(), fixed = TRUE) ) trm$dim <- 2 ## get smooth coefficient estimates for several factor levels # P <- getP(d[[1]], trm = trm, myargs = attr(d, "myargsHist")) P <- lapply(d, getP, trm = trm, myargs = attr(d, "myargsHist")) @@ -1241,27 +1241,27 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, xpart <- unlist(strsplit(x, split = "%.{1,3}%")) ## find the expressions at which the split is done operator <- gregexpr(pattern = "%.{1,3}%", text = x)[[1]] - operator <- sapply(1:length(operator), + operator <- sapply(seq_along(operator), function(i) substr(x, operator[i], operator[i] + attr(operator, "match.length")[i] -1 ) ) - for(i in 1:length(xpart)){ + for(i in seq_along(xpart)){ xpart[i] <- gsub(pattern = "\\\"", replacement = "", x = xpart[i], fixed=TRUE) xpart[i] <- gsub(pattern = "\\", replacement = "", x = xpart[i], fixed=TRUE) nvar <- length(all.vars(formula(paste("Y~", xpart[i])))[-1]) - commaSep <- unlist(strsplit(xpart[i], ",")) + commaSep <- unlist(strsplit(xpart[i], ",", fixed = TRUE)) # shorten the name to first variable and delete x= if present - if(grepl("=", commaSep[1])){ - temp <- unlist(strsplit(commaSep[1], "=")) + if(grepl("=", commaSep[1], fixed = TRUE)){ + temp <- unlist(strsplit(commaSep[1], "=", fixed = TRUE)) temp[1] <- unlist(strsplit(temp[1], "(", fixed=TRUE))[1] if(substr(temp[2], 1, 1)==" ") temp[2] <- substr(temp[2], 2, nchar(temp[2])) if(length(commaSep) == 1){ - xpart[i] <- paste(temp[1], "(", temp[2], sep="") + xpart[i] <- paste0(temp[1], "(", temp[2]) }else{ - xpart[i] <- paste(temp[1], "(", temp[2], ")", sep="") + xpart[i] <- paste0(temp[1], "(", temp[2], ")") } }else{ - if(length(commaSep) > 1){ xpart[i] <- paste(commaSep[1], ")", sep="")} + if(length(commaSep) > 1){ xpart[i] <- paste0(commaSep[1], ")")} } #xpart[i] <- if(length(commaSep)==1){ # paste(paste(commaSep[1:nvar], collapse=","), sep="") @@ -1284,7 +1284,7 @@ coef.FDboost <- function(object, raw = FALSE, which = NULL, ## short names for the terms, if shortnames() does not work, use the original names shrtlbls <- try(unlist(lapply(names(object$baselearner), shortnames))) - if(class(shrtlbls)=="try-error") shrtlbls <- names(object$baselearner) + if(inherits(shrtlbls, "try-error")) shrtlbls <- names(object$baselearner) ###### just return the data that is used for the prediction if(returnData){ @@ -1373,7 +1373,7 @@ getColPersp <- function(z, col1 = "tomato", col2 = "lightblue"){ #' #' @seealso \code{\link{FDboost}} for the model fit and #' \code{\link{coef.FDboost}} for the calculation of the coefficient functions. -#' +#' @return no return value (plot method) #' @method plot FDboost #' @export ### function to plot raw values or coefficient-functions/surfaces of a model @@ -1415,7 +1415,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, ### get the effects to be plotted whichSpecified <- which - if(is.null(which)) which <- 1:length(x$baselearner) + if(is.null(which)) which <- seq_along(x$baselearner) if(onlySelected){ which <- intersect(which, c(0, selected(x))) @@ -1423,8 +1423,8 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, # In the case that intercept and offset should be plotted and the intercept was never selected # plot the offset - if( (1 %in% whichSpecified | is.null(whichSpecified)) - & ! 1 %in% which & length(x$yind) > 1) which <- c(0, which) + if( (1 %in% whichSpecified || is.null(whichSpecified)) + && ! 1 %in% which && length(x$yind) > 1) which <- c(0, which) if(length(which) == 0){ warning("Nothing selected for plotting.") @@ -1457,14 +1457,14 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, # plot the offset as extra effect # case 1: the offset should be included as extra plot # case 2: the whole model is plotted, but the intercept-base-learner was never selected - if( (! includeOffset | (includeOffset & ! 1 %in% which)) & - is.null(whichSpecified) & ! is.null(selected(x))){ + if( (! includeOffset || (includeOffset && ! 1 %in% which)) && + is.null(whichSpecified) && ! is.null(selected(x))){ terms <- c(offset = list(offsetTerms), terms) bl_data <- c(offset = list( list(x$yind) ), bl_data) names(bl_data[[1]]) <- attr(x$yind, "nameyind") } - if((length(terms) > 1 || is.null(terms[[1]]$dim) || terms[[1]]$dim == 3) & ask) par(ask = TRUE) + if((length(terms) > 1 || is.null(terms[[1]]$dim) || terms[[1]]$dim == 3) && ask) par(ask = TRUE) if(commonRange){ range <- range(lapply(terms, function(x) x$value )) @@ -1477,7 +1477,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, ## trm <- terms[[i]] myplot <- function(trm, range_i = NULL){ - if(grepl("bhist", trm$main)){ + if(grepl("bhist", trm$main, fixed = TRUE)){ # set 0 to NA so that beta only has values in its domain # get the limits-function limits <- trm$limits @@ -1504,16 +1504,16 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, ylab="coef", type="l")) } - if(rug & !is.factor(x = trm$x)){ - if(grepl("bconcurrent", trm$main) | grepl("bsignal", trm$main) | grepl("bfpc", trm$main) ){ + if(rug && !is.factor(x = trm$x)){ + if (grepl("bconcurrent|bsignal|bfpc", trm$main)) { rug(attr(bl_data[[i]][[1]], "signalIndex"), ticksize = 0.02) }else rug(bl_data[[i]][[trm$xlab]], ticksize = 0.02) } } # plot with factor variable - if( (!grepl("bhistx", trm$main)) && trm$dim==2 && - ((is.factor(trm$x) | is.factor(trm$y)) | is.factor(trm$z)) ){ + if( (!grepl("bhistx", trm$main, fixed = TRUE)) && trm$dim==2 && + ((is.factor(trm$x) || is.factor(trm$y)) || is.factor(trm$z)) ){ ## plot for the special case where factor is plotted in several plots if(!is.null(trm$add_main)){ @@ -1589,7 +1589,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, }else{ # persp-plot for 2-dim effects - if(trm$dim == 2 & pers){ + if(trm$dim == 2 && pers){ if(length(unique(as.vector(trm$value)))==1){ # persp() gives error if only a flat plane should be drawn plot(y=trm$value[1,], x=trm$x, main=trm$main, type="l", xlab=trm$ylab, @@ -1608,7 +1608,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, } } # image for 2-dim effects - if(trm$dim == 2 & !pers){ + if(trm$dim == 2 && !pers){ plotWithArgs(image, args=argsImage, myargs=list(x=trm$y, y=trm$x, z=t(trm$value), xlab=trm$ylab, ylab=trm$xlab, main=trm$main, col = heat.colors(length(trm$x)^2))) @@ -1617,14 +1617,14 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, if(rug){ ##points(expand.grid(bl_data[[i]][[1]], bl_data[[i]][[2]])) - if(grepl("bhist", trm$main)){ + if(grepl("bhist", trm$main, fixed = TRUE)){ rug(x$yind, ticksize = 0.02) }else{ - ifelse(grepl("by", trm$main) | ( !any(class(x)=="FDboostLong") && grepl("%X", trm$main) ) , + ifelse(grepl("by", trm$main, fixed = TRUE) | ( !inherits(x, "FDboostLong") && grepl("%X", trm$main, fixed = TRUE) ) , rug(bl_data[[i]][[3]], ticksize = 0.02), rug(bl_data[[i]][[2]], ticksize = 0.02)) } - ifelse(grepl("bsignal", trm$main) | grepl("bfpc", trm$main) | grepl("bhist", trm$main), + ifelse(grepl("bsignal|bfpc|bhist", trm$main), rug(attr(bl_data[[i]][[1]], "signalIndex"), ticksize = 0.02, side=2), rug(bl_data[[i]][[1]], ticksize = 0.02, side=2)) } @@ -1632,24 +1632,24 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, } ### 3 dim plots # persp-plot for 3-dim effects - if(trm$dim == 3 & pers){ - for(j in 1:length(trm$z)){ + if(trm$dim == 3 && pers){ + for(j in seq_along(trm$z)){ plotWithArgs(persp, args=argsPersp, myargs=list(x=trm$x, y=trm$y, z=trm$value[[j]], xlab=paste("\n", trm$xlab), ylab=paste("\n", trm$ylab), zlab=paste("\n", "coef"), theta=30, phi=30, ticktype="detailed", zlim=range(trm$value), col=getColPersp(trm$value[[j]]), - main= paste(trm$zlab ,"=", round(trm$z[j],2), ": ", trm$main, sep="")) + main= paste0(trm$zlab ,"=", round(trm$z[j],2), ": ", trm$main)) ) } } # image for 3-dim effects - if(trm$dim == 3 & !pers){ - for(j in 1:length(trm$z)){ + if(trm$dim == 3 && !pers){ + for(j in seq_along(trm$z)){ plotWithArgs(image, args=argsImage, myargs=list(x=trm$x, y=trm$y, z=trm$value[[j]], xlab=trm$xlab, ylab=trm$ylab, col = heat.colors(length(trm$x)^2), zlim=range(trm$value), - main= paste(trm$zlab ,"=", round(trm$z[j],2), ": ", trm$main, sep=""))) + main= paste0(trm$zlab ,"=", round(trm$z[j],2), ": ", trm$main))) plotWithArgs(contour, args=argsContour, myargs=list(trm$x, trm$y, trm$value[[j]], xlab=trm$xlab, add = TRUE)) if(rug){ @@ -1660,7 +1660,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, } ## end function myplot() - for(i in 1:length(terms)){ + for(i in seq_along(terms)){ trm <- terms[[i]] @@ -1676,7 +1676,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, } # end for-loop - if(length(terms)>1 & ask) par(ask = FALSE) + if(length(terms)>1 && ask) par(ask = FALSE) ### plot smooth effects as they are estimated for the original data }else{ @@ -1687,9 +1687,9 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, offset <- attr(terms, "offset") # convert matrix into a list, each list entry for one effect - if(is.null(x$ydim) & !is.null(dim(terms))){ + if(is.null(x$ydim) && !is.null(dim(terms))){ temp <- list() - for(i in 1:ncol(terms)){ + for(i in seq_len(ncol(terms))){ temp[[i]] <- terms[,i] } names(temp) <- colnames(terms) @@ -1697,14 +1697,14 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, rm(temp) } - if(class(terms)!="list") terms <- list(terms) + if(!inherits(terms,"list")) terms <- list(terms) if(mstop(x) > 0 && length(which) == 1 && which == 0) terms[[1]] <- offset if(length(which) == 1 && length(terms[[1]]) == 1 && terms[[1]] == 0){ terms[[1]] <- rep(0, l=length(x$yind)) } #if(length(which)==1 && !any(class(x)=="FDboostLong")) terms <- list(terms) shrtlbls <- try(coef(x, which=which, computeCoef=FALSE))# get short names - if(class(shrtlbls) == "try-error"){ + if(inherits(shrtlbls, "try-error")){ shrtlbls <- names(x$baselearner)[which[which!=0]] if(0 %in% which) shrtlbls <- c("offset", which) } @@ -1712,11 +1712,11 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, time <- x$yind # include the offset in the plot of the intercept - if( includeOffset && 1 %in% which && grepl("ONEx", shrtlbls[1]) ){ + if( includeOffset && 1 %in% which && grepl("ONEx", shrtlbls[1], fixed = TRUE) ){ terms[[1]] <- terms[[1]] + x$offset shrtlbls[1] <- paste("offset", "+", shrtlbls[1]) } - if(length(which) > 1 & ask) par(ask = TRUE) + if(length(which) > 1 && ask) par(ask = TRUE) if(commonRange){ range <- range(terms) @@ -1726,7 +1726,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, if(!is.null(dots$ylim)) range <- dots$ylim - for(i in 1:length(terms)){ + for(i in seq_along(terms)){ # set values of predicted effect to missing if response is missing if(sum(is.na(x$response)) > 0) terms[[i]][is.na(x$response)] <- NA @@ -1758,7 +1758,7 @@ plot.FDboost <- function(x, raw = FALSE, rug = TRUE, which = NULL, } } - if(length(which) > 1 & ask) par(ask = FALSE) + if(length(which) > 1 && ask) par(ask = FALSE) } } @@ -1807,7 +1807,7 @@ update.FDboost <- function(object, weights = NULL, oobweights = NULL, risk = NUL extras <- match.call(expand.dots = FALSE)$... - if (!is.null(risk) | !is.null(trace) | !is.null(extras$control)) { + if (!is.null(risk) || !is.null(trace) || !is.null(extras$control)) { cc <- as.list(call$control) if(length(cc)==0) cc <- list(as.symbol("boost_control")) @@ -1878,16 +1878,16 @@ update.FDboost <- function(object, weights = NULL, oobweights = NULL, risk = NUL ### check for brackets singleBls <- gsub("\\s", "", unlist(lapply(strsplit( - strsplit(object$formulaFDboost, "~")[[1]][2], # split formula - "\\+")[[1]], # split additive terms + strsplit(object$formulaFDboost, "~", fixed = TRUE)[[1]][2], # split formula + "+", fixed = TRUE)[[1]], # split additive terms function(y) strsplit(y, split = "%.{1,3}%")) # split single baselearners )) singleBls <- singleBls[singleBls!="1"] - if(any( !grepl("\\(",singleBls) )) + if(any( !grepl("(",singleBls, fixed = TRUE) )) stop(paste0("update can not deal with the following base-learner(s) without brackets: ", - paste(singleBls[!grepl("\\(",singleBls)], collapse=", "), ".\n", + toString(singleBls[!grepl("(", singleBls, fixed = TRUE)]), ".\n", "Please build such base-learners within the FDboost call or ", "update corresponding baselearner(s) manually and supply a new formula to the update function.")) @@ -1929,7 +1929,7 @@ extract.blg <- function(object, what = c("design", "penalty", "index"), asmatrix = FALSE, expand = FALSE, ...){ what <- match.arg(what) - if(grepl("%O%", object$get_call()) | grepl("%Oz%", object$get_call())){ + if (grepl("%O%|%Oz%", object$get_call())) { object <- object$dpp( rep(1, NROW(object$model.frame()[[1]])) ) }else{ object <- object$dpp(rep(1, nrow(object$model.frame()))) diff --git a/R/stabsel.R b/R/stabsel.R index a42229d..3842c08 100644 --- a/R/stabsel.R +++ b/R/stabsel.R @@ -138,7 +138,7 @@ stabsel.FDboost <- function(x, refitSmoothOffset = TRUE, fun <- function(model) { xs <- selected(model) - qq <- sapply(1:length(xs), function(x) length(unique(xs[1:x]))) + qq <- sapply(seq_along(xs), function(x) length(unique(xs[1:x]))) xs[qq > q] <- xs[1] xs } @@ -148,7 +148,7 @@ stabsel.FDboost <- function(x, refitSmoothOffset = TRUE, } ## for scalar response and/or scalar offset, use the more efficient cvrisk() - if( any(class(x) == "FDboostScalar" ) ) refitSmoothOffset <- FALSE + if( inherits(x, "FDboostScalar" ) ) refitSmoothOffset <- FALSE if( !is.null(x$call$offset) && x$call$offset == "scalar" ) refitSmoothOffset <- FALSE if(refitSmoothOffset){ @@ -184,7 +184,7 @@ stabsel.FDboost <- function(x, refitSmoothOffset = TRUE, m <- mstop(x) } ret <- matrix(0, nrow = length(ibase), ncol = m) - for (i in 1:length(ss)) { + for (i in seq_along(ss)) { tmp <- sapply(ibase, function(x) ifelse(x %in% ss[[i]], which(ss[[i]] == x)[1], m + 1)) ret <- ret + t(sapply(tmp, function(x) c(rep(0, x - 1), rep(1, m - x + 1)))) diff --git a/R/utilityFunctions.R b/R/utilityFunctions.R index c98e6bf..1d1ed4f 100644 --- a/R/utilityFunctions.R +++ b/R/utilityFunctions.R @@ -8,11 +8,11 @@ #' @param silent print error messages of model fit? #' @param cyclic defaults to FALSE, if TRUE cyclic splines are used #' @param knots arguments knots passed to \code{\link[mgcv]{gam}} -#' +#' @return a list with controls #' @export o_control <- function(k_min=20, rule=2, silent=TRUE, cyclic=FALSE, knots=NULL) { RET <- list(k_min=k_min, rule=rule, silent=silent, cyclic=cyclic, knots=knots) - class(RET) <- c("offset_control") + class(RET) <- "offset_control" RET } @@ -38,10 +38,11 @@ o_control <- function(k_min=20, rule=2, silent=TRUE, cyclic=FALSE, knots=NULL) { #' datTr <- truncateTime(funVar=c("hgtm","hgtf"), time="age", newtime=1:16, data=dat) #' #' \donttest{ -#' par(mfrow=c(1,2)) +#' oldpar <- par(mfrow=c(1,2)) #' with(dat, funplot(age, hgtm, main="Original data")) #' with(datTr, funplot(age, hgtm, main="Yearly data")) #' par(mfrow=c(1,1)) +#' par(oldpar) #' } #' } #' @export @@ -53,7 +54,7 @@ truncateTime <- function(funVar, time, newtime, data){ ret <- data ret[[time]] <- newtime - for(i in 1:length(funVar)){ + for(i in seq_along(funVar)){ ret[[funVar[i]]] <- ret[[funVar[i]]][ , data[[time]] %in% newtime] } rm(data) @@ -81,6 +82,7 @@ truncateTime <- function(funVar, time, newtime, data){ #' with(fda::growth, funplot(age, t(hgtm))) #' } #' } +#' @return see \code{\link[graphics]{matplot}} #' @export funplot <- function(x, y, id=NULL, rug=TRUE, ...){ @@ -151,7 +153,7 @@ funplot <- function(x, y, id=NULL, rug=TRUE, ...){ stopifnot(length(x)==length(y) & length(y)==length(id)) idOrig <- id - for(i in 1:length(unique(idOrig))){ + for(i in seq_along(unique(idOrig))){ id[idOrig==unique(idOrig)[i]] <- i } @@ -222,18 +224,18 @@ funplot <- function(x, y, id=NULL, rug=TRUE, ...){ ### function to plot the observed response and the predicted values of a model plotPredicted <- function(x, subset=NULL, posLegend="topleft", lwdObs=1, lwdPred=1, ...){ - stopifnot("FDboost" %in% class(x)) + stopifnot(inherits(x, "FDboost")) - if(any(class(x) == "FDboostScalar")){ + if(inherits(x, "FDboostScalar")){ - if(is.null(subset)) subset <- 1:length(x$response) + if(is.null(subset)) subset <- seq_along(x$response) response <- x$response[subset, drop=FALSE] pred <- fitted(x)[subset, drop=FALSE] pred[is.na(response)] <- NA }else{ - if(!any(class(x) == "FDboostLong")){ + if(!inherits(x, "FDboostLong")){ if(is.null(subset)) subset <- 1:x$ydim[1] response <- matrix(x$response, nrow=x$ydim[1], ncol=x$ydim[2])[subset, , drop=FALSE] pred <- fitted(x)[subset, , drop=FALSE] @@ -251,7 +253,7 @@ plotPredicted <- function(x, subset=NULL, posLegend="topleft", lwdObs=1, lwdPred } - if(is.character(response) | is.factor(x$response)){ + if(is.character(response) || is.factor(x$response)){ if(length(x$yind) > 1){ message("For functional response that is not continuous only the predicted values are plotted.") @@ -290,17 +292,17 @@ plotPredicted <- function(x, subset=NULL, posLegend="topleft", lwdObs=1, lwdPred ### function to plot the residuals plotResiduals <- function(x, subset=NULL, posLegend="topleft", ...){ - stopifnot("FDboost" %in% class(x)) + stopifnot(inherits(x, "FDboost")) - if(any(class(x) == "FDboostScalar")){ + if(inherits(x, "FDboostScalar")){ - if(is.null(subset)) subset <- 1:length(x$response) + if(is.null(subset)) subset <- seq_along(x$response) response <- x$response[subset, drop=FALSE] resid <- x$resid()[subset, drop=FALSE] }else{ - if(!any(class(x) == "FDboostLong")){ ## wide format + if(!inherits(x, "FDboostLong")){ ## wide format if(is.null(subset)) subset <- 1:x$ydim[1] resid <- matrix(x$resid(), nrow = x$ydim[1])[subset, , drop=FALSE] yind <- x$yind @@ -347,9 +349,9 @@ getYYhatTime <- function(object, breaks=object$yind){ yInter <- t(apply(y, 1, function(x) approx(object$yind, x, xout=time)$y)) # Get dataframe to predict values at time newdata <- list() - for(j in 1:length(object$baselearner)){ + for(j in seq_along(object$baselearner)){ datVarj <- object$baselearner[[j]]$get_data() - if(grepl("bconcurrent", names(object$baselearner)[j])){ + if(grepl("bconcurrent", names(object$baselearner)[j], fixed = TRUE)){ datVarj <- t(apply(datVarj[[1]], 1, function(x) approx(object$yind, x, xout=time)$y)) datVarj <- list(datVarj) } @@ -408,13 +410,13 @@ getYYhatTime <- function(object, breaks=object$yind){ #' @export funRsquared <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, ...){ - if(length(object$yind)<2 | any(class(object)=="FDboostLong")){ + if(length(object$yind)<2 || inherits(object, "FDboostLong")){ y <- object$response yhat <- object$fitted() time <- object$yind id <- object$id - if(is.null(id)) id <- 1:length(y) - if(overTime & !global) { + if(is.null(id)) id <- seq_along(y) + if(overTime && !global) { overTime <- FALSE message("For scalar or irregualr response the functional R-squared cannot be computed over time.") } @@ -455,7 +457,7 @@ funRsquared <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, attr(ret, "missings") <- apply(y, 2, function(x) sum(is.na(x))/length(x) ) }else{ ### for each subject i - if(length(object$yind)<2 | any(class(object)=="FDboostLong")){ + if(length(object$yind)<2 || inherits(object, "FDboostLong")){ # Mean for each subject mut <- tapply(y, id, mean, na.rm=TRUE )[id] # numerator cannot be 0 @@ -525,13 +527,13 @@ funRsquared <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, funMSE <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, relative=FALSE, root=FALSE, ...){ - if(length(object$yind)<2 | any(class(object)=="FDboostLong")){ + if(length(object$yind)<2 || inherits(object, "FDboostLong")){ y <- object$response yhat <- object$fitted() time <- object$yind id <- object$id - if(is.null(id)) id <- 1:length(y) - if(overTime & !global) { + if(is.null(id)) id <- seq_along(y) + if(overTime && !global) { overTime <- FALSE message("For scalar or irregualr response the functional MSE cannot be computed over time.") } @@ -555,7 +557,7 @@ funMSE <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, attr(ret, "missings") <- apply(y, 2, function(x) sum(is.na(x))/length(x)) }else{ ### for each subject i - if(length(object$yind)<2 | any(class(object)=="FDboostLong")){ + if(length(object$yind)<2 || inherits(object, "FDboostLong")){ ret <- tapply((y - yhat)^2, id, mean, na.rm=TRUE ) attr(ret, "name") <- "MSE over subjects" }else{ @@ -612,13 +614,13 @@ funMSE <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, #' @export funMRD <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, ...){ - if(length(object$yind)<2 | any(class(object)=="FDboostLong")){ + if(length(object$yind)<2 || inherits(object, "FDboostLong")){ y <- object$response yhat <- object$fitted() time <- object$yind id <- object$id - if(is.null(id)) id <- 1:length(y) - if(overTime & !global) { + if(is.null(id)) id <- seq_along(y) + if(overTime && !global) { overTime <- FALSE message("For scalar or irregualr response the functional MRD cannot be computed over time.") } @@ -646,7 +648,7 @@ funMRD <- function(object, overTime=TRUE, breaks=object$yind, global=FALSE, ... attr(ret, "missings") <- apply(y, 2, function(x) sum(is.na(x))/length(x)) }else{ ### for each subject i - if(length(object$yind)<2 | any(class(object)=="FDboostLong")){ + if(length(object$yind)<2 || inherits(object, "FDboostLong")){ ret <- tapply( abs((y1 - yhat) / y1), id, mean, na.rm=TRUE ) attr(ret, "name") <- "MRD over subjects" }else{ @@ -715,7 +717,7 @@ check_ident <- function(X1, L, Bs, K, xname, penalty, ## logCondDs <- log10(e_DstDs$values[1]) - log10(tail(e_DstDs$values, 1)) evDs <- svd(Ds, nu = 0, nv = 0)$d^2 ## the same as eigenvalues of DstDs logCondDs <- log10(max(evDs)) - log10(min(evDs)) - if(giveWarnings & logCondDs > 6 & is.null(limits)){ + if(giveWarnings && logCondDs > 6 && is.null(limits)){ warning("Condition number for <", xname, "> greater than 10^6 (logCondDs = ", round(logCondDs, 2),"). ", "Effect identifiable only through penalty.") } @@ -729,10 +731,10 @@ check_ident <- function(X1, L, Bs, K, xname, penalty, ind0Bs <- ((!ind0)*1) %*% Bs # matrix to check for 0 columns ## implementation is suitable for common grid of t, maybe with some missings ## common grid is assumed if Y(t) is observed at least in 80% for each point - if( length(yind) < nrow(X1des) | all(table(yind) / max(id) > 0.8) ){ + if( length(yind) < nrow(X1des) || all(table(yind) / max(id) > 0.8) ){ if(is.null(t_unique)) t_unique <- sort(unique(yind)) logCondDs_hist <- rep(NA, length=length(t_unique)) - for(k in 1:length(t_unique)){ + for(k in seq_along(t_unique)){ Ds_t <- X1des[yind==t_unique[k], ] # get rows of Ds corresponding to yind ind0Bs_t <- ind0Bs[yind==t_unique[k], ] # get rows of ind0Bs corresponding to yind # only keep columns that are not completely 0, otherwise matrix is always rank deficient @@ -750,7 +752,7 @@ check_ident <- function(X1, L, Bs, K, xname, penalty, logCondDs_hist[k] <- log10(max(evDs)) - log10(min(evDs)) } ## matplot(xind, Bs, type="l", lwd=2, ylim=c(-2,2)); rug(xind); rug(yind, col=2, lwd=2) - ## matplot(knots[1:ncol(Ds_t)], t(Ds_t), type="l", lwd=1, add=TRUE) + ## matplot(knots[seq_len(ncol(Ds_t))], t(Ds_t), type="l", lwd=1, add=TRUE) ## lines(t_unique, logCondDs_hist-6, col=2, lwd=4) } names(logCondDs_hist) <- round(t_unique,2) @@ -790,7 +792,7 @@ check_ident <- function(X1, L, Bs, K, xname, penalty, } names(logCondDs_hist) <- round(t_unique[-length(t_unique)],2) } - if(giveWarnings & any(logCondDs_hist > 6)){ + if(giveWarnings && any(logCondDs_hist > 6)){ # get the first and the last entry of t, for which the condition number is >10^6 tempL <- names(which.min(which(logCondDs_hist > 6))) tempU <- names(which.max(which(logCondDs_hist > 6))) @@ -827,20 +829,20 @@ check_ident <- function(X1, L, Bs, K, xname, penalty, if(!is.null(limits)){ subs <- list() - for(k in 1:length(t_unique)){ + for(k in seq_along(t_unique)){ subs[[k]] <- which(limits(s=xind, t=t_unique[k])) } cumOverlapKe <- sapply(subs, getOverlap, X1=X1, L=L, Bs=Bs, K=K) overlapKe <- max(cumOverlapKe, na.rm = TRUE) #cumOverlapKe[[length(cumOverlapKe)]] }else{ # overlap between whole matrix X and penalty - overlapKe <- getOverlap(subset=1:ncol(X1), X1=X1, L=L, Bs=Bs, K=K) + overlapKe <- getOverlap(subset=seq_len(ncol(X1)), X1=X1, L=L, Bs=Bs, K=K) } # look at overlap with whole functional covariate - overlapKeComplete <- getOverlap(subset=1:ncol(X1), X1=X1, L=L, Bs=Bs, K=K) + overlapKeComplete <- getOverlap(subset=seq_len(ncol(X1)), X1=X1, L=L, Bs=Bs, K=K) - if(giveWarnings & overlapKe >= 1){ + if(giveWarnings && overlapKe >= 1){ warning("Kernel overlap for <", xname, "> and the specified basis and penalty detected. ", "Changing basis for x-direction to to make model identifiable through penalty. ", "Coefficient surface estimate will be inherently unreliable. ", @@ -863,11 +865,11 @@ trace_lv <- function(A, B, tol=1e-10){ # Rolf Larsson, Mattias Villani (2001) # "A distance measure between cointegration spaces" - if(NCOL(A)==0 | NCOL(B)==0){ + if(NCOL(A)==0 || NCOL(B)==0){ return(0) } - if(NROW(A) != NROW(B) | NCOL(A) > NROW(A) | NCOL(B) > NROW(B)){ + if(NROW(A) != NROW(B) || NCOL(A) > NROW(A) || NCOL(B) > NROW(B)){ return(NA) } @@ -1016,9 +1018,9 @@ reweightData <- function(data, argvals, vars, idvars = NULL, compress = FALSE) { - if(missing(argvals) & missing(vars)) + if(missing(argvals) && missing(vars)) stop("Either argvals or vars must be supplied.") - if(missing(weights) & missing(index)) + if(missing(weights) && missing(index)) stop("Either weights or index must be supplied.") # get names of data @@ -1027,7 +1029,7 @@ reweightData <- function(data, argvals, vars, # if(missing(idvars)) idvars <- NULL # drop not used entries if both argvals and vars are given - if(!missing(argvals) & !missing(vars)){ + if(!missing(argvals) && !missing(vars)){ data[nd[!nd %in% c(argvals, vars, longvars, idvars)]] <- NULL nd <- names(data) # reset names @@ -1043,11 +1045,11 @@ reweightData <- function(data, argvals, vars, # check names if(length(whichNot) != 0) stop(paste0("Could not find ", - paste(c(argvals, vars, idvars, longvars)[whichNot], collapse = ", "), + toString(c(argvals, vars, idvars, longvars)[whichNot]), " in data.")) # check for hmatrix and delete in argvals or vars if present - whichHmat <- sapply(data[vars], function(x) "hmatrix" %in% class(x)) + whichHmat <- sapply(data[vars], is.hmatrix) # get dimensions of data dimd <- lapply(data, dim) @@ -1105,7 +1107,7 @@ reweightData <- function(data, argvals, vars, ## check that all idvars are equal if(length(idvars)>1) - if(!all(sapply(data[idvars][-1],function(x)all.equal(data[idvars][[1]],x)=="TRUE"))) + if(!all(sapply(data[idvars][-1],function(x) isTRUE(all.equal(data[idvars][[1]], x))))) stop("All idvars must be identical.") idvars_new <- NULL @@ -1126,16 +1128,16 @@ reweightData <- function(data, argvals, vars, newHmats <- vector("list", length(nhm)) ## construct the new hmatrices - for(j in 1:length(nhm)){ + for(j in seq_along(nhm)){ ## check that idvars == idvars[[1]] and match id-variables in all hmatrix-objects - if(!is.null(idvars) && !(all.equal(c(getId(data[[nhm[j]]])), c(data[[idvars[1]]])) == "TRUE")) + if(!is.null(idvars) && !isTRUE(all.equal(c(getId(data[[nhm[j]]])), c(data[[idvars[1]]])))) stop("id variable in hmatrix object must be equal to idvars") ## subset hmatrix newHmats[[j]] <- subset_hmatrix(data[[nhm[j]]], index = index, compress = compress) - if( any(class(data[[nhm[j]]]) == "AsIs") ){ + if( inherits(data[[nhm[j]]], "AsIs") ){ newHmats[[j]] <- I(newHmats[[j]]) } @@ -1155,7 +1157,7 @@ reweightData <- function(data, argvals, vars, if(any(idvars %in% longvars)) longvars <- longvars[!longvars %in% idvars] ## create weights and index in long format weights_long <- weights[data[[idvars[1]]]] - index_long <- rep(1:length(weights_long), weights_long) + index_long <- rep(seq_along(weights_long), weights_long) ## indexing variables in long format temp_long <- lapply(longvars, function(nameWithoutDim) data[[nameWithoutDim]][index_long]) @@ -1176,12 +1178,14 @@ reweightData <- function(data, argvals, vars, my_temp_idvars <- temp_idvars i <- 1 ## add 0.1^1 to duplicates, 0.1^1 + 0.1^2 = 0.11 to triplicates, ... - while(any(duplicated(my_index_long))){ # loop until no more duplicates in the data + while(anyDuplicated(my_index_long) > 0){ # loop until no more duplicates in the data my_temp_idvars[duplicated(my_index_long)] <- my_temp_idvars[duplicated(my_index_long)] + 0.1^i my_index_long[duplicated(my_index_long)] <- my_index_long[duplicated(my_index_long)] + 0.1^i i <- i + 1 } idvars_new <- c(factor(my_temp_idvars)) + # regain 1:n ids format expected by FDboost + idvars_new <- as.numeric(idvars_new) ## check whether id variable of hmatrix-object and id variable of long variables are equal if(!is.null(idvars_new_hmatrix)){ if(!all(idvars_new == idvars_new_hmatrix)) @@ -1196,7 +1200,7 @@ reweightData <- function(data, argvals, vars, if(!is.null(idvars)){ ## only works for common observation grid of response - ## idvars_new <- rep(1:length(index), nc) # index = c(1, 1, 2) -> 1, 2, 3 + ## idvars_new <- rep(seq_along(index), nc) # index = c(1, 1, 2) -> 1, 2, 3 for(ifr in idvars){ data[[ifr]] <- idvars_new diff --git a/README.md b/README.md index 8de94c9..c3a8f05 100644 --- a/README.md +++ b/README.md @@ -1,17 +1,18 @@ -FDboost -====== +# FDboost -[![Build Status (Linux)](https://travis-ci.org/boost-R/FDboost.svg?branch=master)](https://travis-ci.org/boost-R/FDboost) - -[![CRAN Status Badge](https://www.r-pkg.org/badges/version/FDboost)](https://cran.r-project.org/package=FDboost) - -[![](https://cranlogs.r-pkg.org/badges/FDboost)](https://cran.rstudio.com/web/packages/FDboost/index.html) + + +[![R-CMD-check](https://github.com/boost-R/FDboost/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/boost-R/FDboost/actions/workflows/R-CMD-check.yaml) +[![CRAN status](https://www.r-pkg.org/badges/version/FDboost)](https://CRAN.R-project.org/package=FDboost) +[![CRAN RStudio mirror downloads](https://cranlogs.r-pkg.org/badges/FDboost)](https://www.r-pkg.org/pkg/FDboost) + + `FDboost` Boosting Functional Regression Models. -The package FDboost fits regression models for functional data, i.e., +The package FDboost fits regression models for functional data, i.e., scalar-on-function, function-on-scalar, and function-on-function regression models, -by a component-wise gradient boosting algorithm. +by a component-wise gradient boosting algorithm. Furthermore, it can be used to fit density-on-scalar regression models. ## Using FDboost @@ -19,9 +20,10 @@ Furthermore, it can be used to fit density-on-scalar regression models. For installation instructions see below. Instructions on how to use `FDboost` can be found in various places: + - Read the tutorial paper [doi:10.18637/jss.v094.i10](doi:10.18637/jss.v094.i10) - Have a look at the manual, which also contains example code -- Check the vignettes: +- Check the vignettes: - [function-on-function regression](https://cran.r-project.org/web/packages/FDboost/vignettes/FLAM_canada.pdf) - [scalar-on-function regression](https://cran.r-project.org/web/packages/FDboost/vignettes/FLAM_fuel.pdf) - [function-on-scalar regression](https://cran.r-project.org/web/packages/FDboost/vignettes/FLAM_viscosity.pdf) @@ -31,30 +33,17 @@ Instructions on how to use `FDboost` can be found in various places: For issues, bugs, feature requests etc. please use the [GitHub Issues](https://github.com/boost-R/FDboost/issues). -## Installation Instructions - -- Current version (from CRAN): - ```r - install.packages("FDboost") - ``` - -- Latest **patch version** (patched version of CRAN package; under development) from GitHub: - ```r - library("devtools") - install_github("boost-R/FDboost") - library("FDboost") - ``` - - - - To be able to use the `install_github()` command, one needs to install `devtools` first: - ```r - install.packages("devtools") - ``` +## Installation + +Install the last release from [CRAN](https://cran.r-project.org): + +```r +install.packages("FDboost") +``` + +Install the development version from [GitHub](https://github.com/): +```r +# install.packages("pak") +pak::pak("boost-R/FDboost") +``` diff --git a/_pkgdown.yml b/_pkgdown.yml new file mode 100644 index 0000000..588072d --- /dev/null +++ b/_pkgdown.yml @@ -0,0 +1,5 @@ +url: https://boost-R.github.io/FDboost + +template: + bootstrap: 5 + light-switch: true diff --git a/inst/CITATION b/inst/CITATION index 54a85b4..f2622f6 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -8,8 +8,8 @@ to cite functional linear array models use Brockhaus et al. (2015); to cite models with historical effects use Brockhaus et al. (2017b); to cite models with factor-specific historical effects use Ruegamer (2018).") -citEntry( - entry = "manual", +bibentry( + bibtype = "Manual", title = "FDboost: Boosting Functional Regression Models", author = "Sarah Brockhaus and David Ruegamer", year = year, @@ -18,8 +18,8 @@ citEntry( ) -citEntry( - entry = "Article", +bibentry( + bibtype = "Article", title = "The Functional Linear Array Model", author = "Sarah Brockhaus, Fabian Scheipl, Torsten Hothorn, and Sonja Greven", journal = "Statistical Modelling", @@ -31,8 +31,8 @@ citEntry( ) -citEntry( - entry = "Article", +bibentry( + bibtype = "Article", author = "Sarah Brockhaus and Michael Melcher and Friedrich Leisch, and Sonja Greven", title = "Boosting flexible functional regression models with a high number of functional historical effects", journal = "Statistics and Computing", @@ -43,8 +43,8 @@ citEntry( textVersion = "Brockhaus, S., Melcher, M., Leisch, F., and Greven, S. (2017b), Boosting flexible functional regression models with a high number of functional historical effects. Statistics and Computing, 27(4), 913-926." ) -citEntry( - entry = "Article", +bibentry( + bibtype = "Article", author = "David Ruegamer, Sarah Brockhaus, Kornelia Gentsch, Klaus Scherer, and Sonja Greven", title = "Boosting factor-specific functional historical models for the detection of synchronization in bioelectrical signals", journal = "Journal of the Royal Statistical Society: Series C (Applied Statistics)", diff --git a/inst/NEWS.Rd b/inst/NEWS.Rd deleted file mode 100644 index 8676883..0000000 --- a/inst/NEWS.Rd +++ /dev/null @@ -1,336 +0,0 @@ -\name{NEWS} -\title{News for Package 'FDboost'} - - -\section{Changes in FDboost version 1.1-0 (2022-07-12)}{ - \subsection{Miscellaneous}{ - \itemize{ - \item Anisotropic tensor-product operators \code{b1 \%A0\% b2} and \code{b1 \%Xa0\% b2} now - also working when \code{lambda} is specified for \code{b1} and \code{df} is specified for \code{b2} - (or vice versa). - } - } - \subsection{New feature}{ - \itemize{ - \item New function \code{clr} to compute the centered-log-ratio transform and its - inverse for density-on-scalar regression in Bayes spaces. - \item New dataset \code{birthDistribution}. - \item New vignette illustrating density-on-function regression on - the \code{birthDistribution} data. - } - } -} - -\section{Changes in FDboost version 0.3-4 (2020-08-31)}{ - \subsection{Bug-fixes}{ - \itemize{ - \item Fix predict() for bsignal with newdata and the functional covariate - given as numeric matrix, raised in - \href{https://github.com/boost-R/FDboost/issues/17}{#17} - \item Deprecated argument \code{LINPACK} in \code{solve} removed. - } - } -} - -\section{Changes in FDboost version 0.3-3 (2020-06-13)}{ -\subsection{New feature}{ -\itemize{ - \item Now it is possible to specify several time variabels as well as - factor time variabels in the timeformula. - This feature is needed for the manifoldboost package. - } -} -\subsection{Miscellaneous}{ -\itemize{ - \item The function stabsel.FDboost() now uses applyFolds() instead of validateFDboost() to do - cross-validation with recomputation of the smooth offset. This is only relevant for models with functional response. - This will change the results if the model contains base-learners like bbsc() or bolsc(), - as applyFolds() also recomputes the Z-matrix for those base-learners. - } -} - \subsection{Bug-fixes}{ - \itemize{ - \item Adapted functions \code{integrationWeights} and \code{integrationWeightsLeft} for unsorted time variables. - \item Change code in predict.FDboost() such that interaction effects of two functional - covariates such as \code{bsignal() \%X\% bsignal()} can be predicted with new data. - \item Adapt FDboost to R 4.0.1: explicitely use the first entry of dots$aggregate, - by setting dots$aggregate[1] != "sum", in predict.FDboost(); such that it also works with the default, - where aggregate is a vector of length 3 and later on the first argument is used, using match.arg() - } -} -} - -\section{Changes in FDboost version 0.3-2 (2018-08-04)}{ - \subsection{Bug-fixes}{ - \itemize{ - \item Deprecated argument \code{corrected} in \code{cvrisk} removed. - } - } -} - -\section{Changes in FDboost version 0.3-1 (2018-05-10)}{ - \subsection{Bug-fixes}{ - \itemize{ - \item \code{cvrisk} has per default adequate folds for a noncyclic fitted FDboostLSS model, - see issue \href{https://github.com/boost-R/FDboost/issues/14}{#14} - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item replace cBind which is deprecated with cbind - } - } -} - -\section{Changes in FDboost version 0.3-0 (2017-05-31)}{ - \subsection{User-visible changes}{ - \itemize{ - \item new function \code{bootstrapCI()} to compute bootstrapped coefficients - \item add the dataset 'emotion' containing EEG and EMG measures under different experimental conditions - \item with scalar response, \code{FDboost()} works with the response as - vector and not as matrix with one row; - thus, \code{fitted()} and \code{predict()} return a vector - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item \code{update.FDboost()} works now with scalar response - \item \code{FDboost()} works with family \code{Binomial(type = "glm")}, - see isssue \href{https://github.com/boost-R/FDboost/issues/1}{#1} - \item \code{applyFolds()} works for factor response, - see issue \href{https://github.com/boost-R/FDboost/issues/7}{#7} - \item \code{cvLong} and \code{cvMA} return a matrix for only one resampling - fold with \code{B = 1} (proposed by Almond Stoecker) - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item adapt \pkg{FDboost} to \pkg{mboost} 2.8-0 that allows for mstop = 0 - \item restructure FDboostLSS() such that it calls mboostLSS_fit() from \pkg{gamboostLSS} 2.0-0 - \item in \pkg{FDboost}, set \code{options("mboost_indexmin" = +Inf)} to disable the - internal use of ties in model fitting, as this breaks some methods for models with response - in long format and for models containing \code{bhistx}, - see issue \href{https://github.com/boost-R/FDboost/issues/10}{#10} - \item deprecate \code{validateFDboost()}, - use \code{applyFolds()} and \code{bootstrapCI()} instead - } - } -} - - -\section{Changes in FDboost version 0.2-0 (2016-05-26)}{ - \subsection{User-visible changes}{ - \itemize{ - \item add function applyFolds() to compute the optimal stopping iteration - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item allow for extrapolation in predict() with bbsc() - } - } -} - -\section{Changes in FDboost version 0.1-2 (2016-04-22)}{ - \subsection{Bug-fixes}{ - \itemize{ - \item bugfix in bolsc(): correctly use index in bolsc() / bbsc(), - before: for the computation of Z each observation was used only once - } - } - \subsection{User-visible changes}{ - \itemize{ - \item add function \%Xa0\% that computes a row-tensor product of two base-learners where - the penalty in one direction is zero - \item add function reweightData() that computes the data for Bootstrap or cross-falidation folds - \item add function stabsel.FDboost() that refits the smooth offset in each fold - \item add argument 'fun' to validateFDboost() - \item add update.FDboost() that overwrites update.mboost() - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item FDboost() works with family = Binomial() - } - } -} - - -\section{Changes in FDboost version 0.1-1 (2016-04-06)}{ - \subsection{Bug-fixes}{ - \itemize{ - \item fix oobpred in validateFDboost() for irregular response and resampling on the level of curves - and thus plot.validateFDboost() works for that case - \item fix scope of formula in FDboost(): now the formula given to mboost() within FDboost() uses the variables in the environment of the formula specified in FDboost() - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item plot.FDboost() works for more effects, especially for effects like bolsc() \%X\% bhistx() - } - } -} - - -\section{Changes in FDboost version 0.1-0 (2016-03-10)}{ - \subsection{User-visible changes}{ - \itemize{ - \item new operator \%A0\% for Kronecker product of two base-learners with - anisotropic penalty for the special case where lambda1 or lambda2 is zero - \item the base-learner bbsc() can be used with center = TRUE, derived by Almond Stoecker - \item in FDboostLSS() a list of one-sided formulas can be specified for timeformula - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item FDboostLSS works with families = GammaLSS() - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item operator \%A\% uses weights in model call; only works correctly for weights on level - of blg1 and blg2 (which is the same as weights on rows and columns of the response matrix) - \item call to internal functions of mboost is done using mboost_intern() - \item hyper_olsc() is based on hyper_ols() of mboost - } - } -} - -\section{Changes in FDboost version 0.0-17 (2016-02-25)}{ - \subsection{User-visible changes}{ - \itemize{ - \item changed the operator \%Xc\% for row tensor product of two scalar covariates. - The design matrix of the interaction effects is constrained such that the interaction is - centred around the intercept and around the two main effects of the scalar covariates (experimental!); - use e.g. as bols(x1) \%Xc\% bols(x2) - } - } -} - -\section{Changes in FDboost version 0.0-16 (2016-02-22)}{ - \subsection{User-visible changes}{ - \itemize{ - \item changed the operator \%Xc\% for row tensor product where the sum-to-zero constraint is applied to - the design matrix resulting from the row-tensor product (experimental!), - such that first a, intercept-column is added to the design-matrix and then the sum-to-zero constraint - is applied, use e.g. as bolsc(x1) \%Xc\% bolsc(x2) - \item use the functional index s as argsvals in the FPCA conducted within bfpc() - } - } -} - -\section{Changes in FDboost version 0.0-15 (2016-02-12)}{ - \subsection{User-visible changes}{ - \itemize{ - \item new operator \%A\% that implies anisotropic penalties for differently specified df in the two base-learners - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item do not penalize in direction of ONEx in smooth intercept specified implicitly by ~1, as bols(ONEx, intercept=FALSE, df=1) \%A\% bbs(time) - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item do not expand an effect that contains \%A\% or \%O\% with the timeformula, allowing for different effects over time for the - effects in the model - } - } -} - -\section{Changes in FDboost version 0.0-14 (2016-02-11)}{ - \subsection{User-visible changes}{ - \itemize{ - \item add the function FDboostLSS() to fit GAMLSS models with functional data - using R-package gamboostLSS - \item new operator \%Xc\% for row tensor product where the sum-to-zero constraint is applied to - the design matrix resulting from the row-tensor product (experimental!) - \item allow newdata to be a list in predict.FDboost() in combination with signal base-learners - \item expand coef.FDboost() such that it works for 3-dimensional tensor products - of with bhistx() the form bhistx() \%X\% bolsc() \%X\% bolsc() (with David Ruegamer) - \item add a new possibility for scalar-on-function regression: - for timeformula=NULL, no Kronecker-product with 1 is used, which - changes the penalty as otherwise in the direction of 1 is penalized as well. - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item new dependency on R-package gamboostLSS - \item remove dependency on R-package MASS - \item use the argument 'prediction' in the internal computation - of the base-learners (work in progress) - \item throw an error if 'timeLab' of the hmatrix-object in bhistx() is not - equal to the time-variable in 'timeformula'. - } - } -} - - -\section{Changes in FDboost version 0.0-13 (2015-11-17)}{ - \subsection{User-visible changes}{ - \itemize{ - \item in function FDboost() the offset is supplied differently, for a scalar offset, use offset = "scalar", the default is still the same offset=NULL - \item predict.FDboost() has new argument toFDboost (logical) - \item fitted.FDboost() has argument toFDboost explicitly and not only in ... - \item new base-learner bhistx() especially suited for effects with \%X\%, like bhistx \%X\% bolsc - \item coef.FDboost() and plot.FDboost() suited for effects like bhistx \%X\% bolsc - \item for predict.FDboost() with effects bhistx() and newdata the latest mboostPatch is necessary - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item check for necessity of smooth offset works for missings in regular response (spotted by Tore Erdmann) - } - } -} - -\section{Changes in FDboost version 0.0-12 (2015-09-15)}{ - \itemize{ - \item Internal experimental version. - } -} - -\section{Changes in FDboost version 0.0-11 (2015-06-01)}{ - \subsection{User-visible changes}{ - \itemize{ - \item integrationWeights() gives equal weights for regular grids - \item new base-learner bfpc() for a functional covariate where - functional covariate and the coeffcient are both expanded using fPCA (experimental feature!); - only works for regularly observed functional covariate. - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item the function coef.FDboost() only works for bhist() if the time variable is the same in the timeformula and in bhist() - \item predict.FDboost() has a check that for newdata only type="link" can be predicted - } - } -} - -\section{Changes in FDboost version 0.0-10 (2015-04-16)}{ - \subsection{User-visible changes}{ - \itemize{ - \item change the default in difference-penalties to first order difference penalty - differences=1, as then the effects are better identifiable - \item new method cvrisk.FDboost() that uses per default - sampling on the levels of curves, which is important for functional response - \item reorganize documentation of cvrisk() and validateFDboost() - \item in bhist(): effect can be standardized - } - } - \subsection{Miscellaneous}{ - \itemize{ - \item add a CITATION file - \item use mboost 2.4-2 as it exports all important functions - } - } - \subsection{Bug-fixes}{ - \itemize{ - \item main argument is always passed in plot.FDboost() - \item bhist() and bconcurrent() work for equal time and s - \item predict.FDboost() works with tensor-product base-learners bl1 \%X\% bl2 - } - } -} - - diff --git a/man/FDboost-package.Rd b/man/FDboost-package.Rd index 9e1069c..cb90f8c 100644 --- a/man/FDboost-package.Rd +++ b/man/FDboost-package.Rd @@ -3,71 +3,83 @@ \docType{package} \name{FDboost-package} \alias{FDboost-package} -\alias{_PACKAGE} \alias{FDboost_package} \alias{package-FDboost} \title{FDboost: Boosting Functional Regression Models} \description{ -Regression models for functional data, i.e., scalar-on-function, -function-on-scalar and function-on-function regression models, are fitted +Regression models for functional data, i.e., scalar-on-function, +function-on-scalar and function-on-function regression models, are fitted by a component-wise gradient boosting algorithm. } \details{ -This package is intended to fit regression models with functional variables. -It is possible to fit models with functional response and/or functional covariates, -resulting in scalar-on-function, function-on-scalar and function-on-function regression. +This package is intended to fit regression models with functional variables. +It is possible to fit models with functional response and/or functional covariates, +resulting in scalar-on-function, function-on-scalar and function-on-function regression. Furthermore, the package can be used to fit density-on-scalar regression models. Details on the functional regression models that can be fitted with \pkg{FDboost} -can be found in Brockhaus et al. (2015, 2017, 2018) and Ruegamer et al. (2018). -A hands-on tutorial for the package can be found -in Brockhaus, Ruegamer and Greven (2017), see \url{https://arxiv.org/abs/1705.10662}. +can be found in Brockhaus et al. (2015, 2017, 2018) and Ruegamer et al. (2018). +A hands-on tutorial for the package can be found +in Brockhaus, Ruegamer and Greven (2020), see . For density-on-scalar regression models see Maier et al. (2021). -Using component-wise gradient boosting as fitting procedure, \pkg{FDboost} relies on -the R package \pkg{mboost} (Hothorn et al., 2017). -A comprehensive tutorial to \pkg{mboost} is given in Hofner et al. (2014). +Using component-wise gradient boosting as fitting procedure, \pkg{FDboost} relies on +the R package \pkg{mboost} (Hothorn et al., 2017). +A comprehensive tutorial to \pkg{mboost} is given in Hofner et al. (2014). -The main fitting function is \code{\link{FDboost}}. -The model complexity is controlled by the number of boosting iterations (mstop). -Like the fitting procedures in \pkg{mboost}, the function \code{FDboost} DOES NOT -select an appropriate stopping iteration. This must be chosen by the user. -The user can determine an adequate stopping iteration by resampling methods like -cross-validation or bootstrap. +The main fitting function is \code{\link{FDboost}}. +The model complexity is controlled by the number of boosting iterations (mstop). +Like the fitting procedures in \pkg{mboost}, the function \code{FDboost} DOES NOT +select an appropriate stopping iteration. This must be chosen by the user. +The user can determine an adequate stopping iteration by resampling methods like +cross-validation or bootstrap. This can be done using the function \code{\link{applyFolds}}. + +Aside from common effect surface plots, tensor product factorization via the +function \code{\link{factorize}} presents an alternative tool for visualization +of estimated effects for non-linear function-on-scalar models +(Stoecker, Steyer and Greven (2022), \url{https://arxiv.org/abs/2109.02624}). +After factorization, effects are decomposed multiple scalar effects into +functional main effect directions, which can be separately plotted allowing to +visualize more complex effect structures. } \references{ -Brockhaus, S., Ruegamer, D. and Greven, S. (2017): +Brockhaus, S., Ruegamer, D. and Greven, S. (2020): Boosting Functional Regression Models with FDboost. +Journal of Statistical Software, 94(10), 1–50. -Brockhaus, S., Scheipl, F., Hothorn, T. and Greven, S. (2015): -The functional linear array model. Statistical Modelling, 15(3), 279-300. +Brockhaus, S., Scheipl, F., Hothorn, T. and Greven, S. (2015): +The functional linear array model. Statistical Modelling, 15(3), 279-300. -Brockhaus, S., Melcher, M., Leisch, F. and Greven, S. (2017): -Boosting flexible functional regression models with a high number of functional historical effects, -Statistics and Computing, 27(4), 913-926. +Brockhaus, S., Melcher, M., Leisch, F. and Greven, S. (2017): +Boosting flexible functional regression models with a high number of functional historical effects, +Statistics and Computing, 27(4), 913-926. -Brockhaus, S., Fuest, A., Mayr, A. and Greven, S. (2018): -Signal regression models for location, scale and shape with an application to stock returns. +Brockhaus, S., Fuest, A., Mayr, A. and Greven, S. (2018): +Signal regression models for location, scale and shape with an application to stock returns. Journal of the Royal Statistical Society: Series C (Applied Statistics), 67, 665-686. -Hothorn T., Buehlmann P., Kneib T., Schmid M., and Hofner B. (2017). mboost: Model-Based Boosting, +Hothorn T., Buehlmann P., Kneib T., Schmid M., and Hofner B. (2017). mboost: Model-Based Boosting, R package version 2.8-1, \url{https://cran.r-project.org/package=mboost} -Hofner, B., Mayr, A., Robinzonov, N., Schmid, M. (2014). Model-based Boosting in R: -A Hands-on Tutorial Using the R Package mboost. Computational Statistics, 29, 3-35. +Hofner, B., Mayr, A., Robinzonov, N., Schmid, M. (2014). Model-based Boosting in R: +A Hands-on Tutorial Using the R Package mboost. Computational Statistics, 29, 3-35. \url{https://cran.r-project.org/package=mboost/vignettes/mboost_tutorial.pdf} Maier, E.-M., Stoecker, A., Fitzenberger, B., Greven, S. (2021): Additive Density-on-Scalar Regression in Bayes Hilbert Spaces with an Application to Gender Economics. arXiv preprint arXiv:2110.11771. -Ruegamer D., Brockhaus, S., Gentsch K., Scherer, K., Greven, S. (2018). -Boosting factor-specific functional historical models for the detection of synchronization in bioelectrical signals. +Ruegamer D., Brockhaus, S., Gentsch K., Scherer, K., Greven, S. (2018). +Boosting factor-specific functional historical models for the detection of synchronization in bioelectrical signals. Journal of the Royal Statistical Society: Series C (Applied Statistics), 67, 621-642. + +Stoecker A., Steyer L., Greven S. (2022): +Functional Additive Models on Manifolds of Planar Shapes and Forms. +arXiv preprint arXiv:2109.02624. } \seealso{ -\code{\link{FDboost}} for the main fitting function and +\code{\link{FDboost}} for the main fitting function and \code{\link{applyFolds}} for model tuning via resampling methods. } \author{ diff --git a/man/FDboost.Rd b/man/FDboost.Rd index 0d5b8ca..7703136 100644 --- a/man/FDboost.Rd +++ b/man/FDboost.Rd @@ -60,14 +60,14 @@ defaults to \code{o_control()}, see \code{\link{o_control}}.} check the fitted effects for the sum-to-zero constraint \eqn{h_j(x_i)(t) = 0} for all \eqn{t} and give a warning if it is not fulfilled. Defaults to \code{FALSE}.} -\item{...}{additional arguments passed to \code{\link{mboost}}, +\item{...}{additional arguments passed to \code{\link[mboost]{mboost}}, including, \code{family} and \code{control}.} } \value{ An object of class \code{FDboost} that inherits from \code{mboost}. Special \code{\link{predict.FDboost}}, \code{\link{coef.FDboost}} and \code{\link{plot.FDboost}} methods are available. -The methods of \code{\link{mboost}} are available as well, +The methods of \code{\link[mboost]{mboost}} are available as well, e.g., \code{\link[mboost:methods]{extract}}. The \code{FDboost}-object is a named list containing: \item{...}{all elements of an \code{mboost}-object} @@ -92,7 +92,7 @@ Gradient boosting for optimizing arbitrary loss functions, where component-wise are utilized as base-learners in the case of functional responses. Scalar responses are treated as the special case where each functional response has only one observation. -This function is a wrapper for \code{mboost}'s \code{\link{mboost}} and its +This function is a wrapper for \code{mboost}'s \code{\link[mboost]{mboost}} and its siblings to fit models of the general form \deqn{\xi(Y_i(t) | X_i = x_i) = \sum_{j} h_j(x_i, t), i = 1, ..., N,} with a functional (but not necessarily continuous) response \eqn{Y(t)}, @@ -115,7 +115,7 @@ response evaluations \eqn{Y_i(t_g)} are stacked internally into one long vector. If it is possible to represent the model as a generalized linear array model (Currie et al., 2006), the array structure is used for an efficient implementation, -see \code{\link{mboost}}. This is only possible if the design +see \code{\link[mboost]{mboost}}. This is only possible if the design matrix can be written as the Kronecker product of two marginal design matrices yielding a functional linear array model (FLAM), see Brockhaus et al. (2015) for details. @@ -145,12 +145,12 @@ one time-point, and thus it can be represented as FLAM with basis 1 in time-direction, use \code{timeformula = ~bols(1)}. In this case, a penalty in the time-direction is used, see Brockhaus et al. (2015) for details. Alternatively, the scalar response is fitted as scalar response, like in the function -\code{\link{mboost}} in package mboost. +\code{\link[mboost]{mboost}} in package mboost. The advantage of using \code{FDboost} in that case is that methods for the functional base-learners are available, e.g., \code{plot}. The desired regression type is specified by the \code{family}-argument, -see the help-page of \code{\link{mboost}}. For example a mean regression model is obtained by +see the help-page of \code{\link[mboost]{mboost}}. For example a mean regression model is obtained by \code{family = Gaussian()} which is the default or median regression by \code{family = QuantReg()}; see \code{\link[mboost]{Family}} for a list of implemented families. @@ -158,7 +158,7 @@ see \code{\link[mboost]{Family}} for a list of implemented families. With \code{FDboost} the following covariate effects can be estimated by specifying the following effects in the \code{formula} (similar to function \code{\link[refund]{pffr}} -in R-package \code{\link[refund:refund-package]{refund}}). +in R-package refund. The \code{timeformula} is used to expand the effects in \code{t}-direction. \itemize{ \item Linear functional effect of scalar (numeric or factor) covariate \eqn{z} that varies @@ -450,7 +450,7 @@ Scheipl, F., Staicu, A.-M. and Greven, S. (2015): Functional additive mixed models, Journal of Computational and Graphical Statistics, 24(2), 477-501. } \seealso{ -Note that \link{FDboost} calls \code{\link{mboost}} directly. +Note that \link{FDboost} calls \code{\link[mboost]{mboost}} directly. See, e.g., \code{\link[FDboost]{bsignal}} and \code{\link[FDboost]{bbsc}} for possible base-learners. } diff --git a/man/FDboostLSS.Rd b/man/FDboostLSS.Rd index 7a04ef8..6998a35 100644 --- a/man/FDboostLSS.Rd +++ b/man/FDboostLSS.Rd @@ -33,11 +33,11 @@ a named list of one-sided formulas.} \item{families}{an object of class \code{families}. It can be either one of the pre-defined distributions that come along with the package \code{gamboostLSS} or a new distribution specified by the user -(see \code{\link{Families}} for details). -Per default, the two-parametric \code{\link{GaussianLSS}} family is used.} +(see \code{\link[gamboostLSS]{Families}} for details). +Per default, the two-parametric \code{\link[gamboostLSS]{GaussianLSS}} family is used.} \item{control}{a list of parameters controlling the algorithm. -For more details see \code{\link{boost_control}}.} +For more details see \code{\link[mboost]{boost_control}}.} \item{weights}{does not work!} @@ -110,11 +110,12 @@ summary(m_boost) m_boost <- m_boost[mstop(cvr)] ## 832 ## plot smooth effects of functional covariates for mu and sigma - par(mfrow = c(1,2)) + oldpar <- par(mfrow = c(1,2)) plot(m_boost$mu, which = 2, ylim = c(0,5)) lines(s, sin(s*pi)*5, col = 3, lwd = 2) plot(m_boost$sigma, which = 2, ylim = c(-2.5,2.5)) lines(s, -cos(s*pi)*2, col = 3, lwd = 2) + par(oldpar) } } } diff --git a/man/FDboost_fac-class.Rd b/man/FDboost_fac-class.Rd new file mode 100644 index 0000000..f470d1f --- /dev/null +++ b/man/FDboost_fac-class.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/factorize.R +\name{FDboost_fac-class} +\alias{FDboost_fac-class} +\title{`FDboost_fac` S3 class for factorized FDboost model components} +\description{ +Model factorization with `factorize()` decomposes an +`FDboost` model into two objects of class `FDboost_fac` - one for the +response and one for the covariate predictor. The first is essentially +an `FDboost` object and the second an `mboost` object, however, +in a 'read-only' mode and slightly adjusted methods (method defaults). +} +\seealso{ +[factorize(), factorize.FDboost()] +} diff --git a/man/anisotropic_Kronecker.Rd b/man/anisotropic_Kronecker.Rd index 2b734e3..91fe090 100644 --- a/man/anisotropic_Kronecker.Rd +++ b/man/anisotropic_Kronecker.Rd @@ -18,6 +18,10 @@ bl1 \%Xa0\% bl2 \item{bl2}{base-learner 2, e.g. \code{bbs(x2)}} } +\value{ +An object of class \code{blg} (base-learner generator) with a \code{dpp} function +as for other \code{\link[mboost:baselearners]{baselearners}}. +} \description{ Kronecker product or row tensor product of two base-learners allowing for anisotropic penalties. For the Kronecker product, \code{\%A\%} works in the general case, \code{\%A0\%} for the special case where @@ -131,15 +135,18 @@ mod1k0$formulaMboost ## compare estimated coefficients \donttest{ -par(mfrow=c(4, 2)) -plot(mod1, which = 1) -plot(mod1a, which = 1) -plot(mod1, which = 2) -plot(mod1a, which = 2) -plot(mod1, which = 3) -plot(mod1a, which = 3) -funplot(mod1$yind, predict(mod1, which=4)) -funplot(mod1$yind, predict(mod1a, which=4)) +if (interactive()) { + oldpar <- par(mfrow=c(4, 2)) + plot(mod1, which = 1) + plot(mod1a, which = 1) + plot(mod1, which = 2) + plot(mod1a, which = 2) + plot(mod1, which = 3) + plot(mod1a, which = 3) + funplot(mod1$yind, predict(mod1, which=4)) + funplot(mod1$yind, predict(mod1a, which=4)) + par(oldpar) +} } } diff --git a/man/applyFolds.Rd b/man/applyFolds.Rd index 8ebe9c7..b11e719 100644 --- a/man/applyFolds.Rd +++ b/man/applyFolds.Rd @@ -202,7 +202,7 @@ mod <- mod[75] cvr <- applyFolds(mod, folds = folds_bs, grid = 1:75) ## weights per observation point - folds_bs_long <- folds_bs[rep(1:nrow(folds_bs), times = mod$ydim[2]), ] + folds_bs_long <- folds_bs[rep(seq_len(nrow(folds_bs)), times = mod$ydim[2]), ] attr(folds_bs_long, "type") <- "3-fold bootstrap" ## compute out-of-bag risk on the 3 folds for 1 to 75 boosting iterations cvr3 <- cvrisk(mod, folds = folds_bs_long, grid = 1:75) @@ -210,9 +210,10 @@ mod <- mod[75] \donttest{ ## plot the out-of-bag risk - par(mfrow = c(1,3)) + oldpar <- par(mfrow = c(1,3)) plot(cvr); legend("topright", lty=2, paste(mstop(cvr))) plot(cvr3); legend("topright", lty=2, paste(mstop(cvr3))) + par(oldpar) } } diff --git a/man/bhistx.Rd b/man/bhistx.Rd index dd2f13e..8f7a55c 100644 --- a/man/bhistx.Rd +++ b/man/bhistx.Rd @@ -111,8 +111,8 @@ if(require(refund)){ ## the interaction effect is in this case not necessary n <- 100 nygrid <- 35 -data1 <- pffrSim(scenario = c("int", "ff"), limits = function(s,t){ s <= t }, - n = n, nygrid = nygrid) +data1 <- suppressWarnings(pffrSim(scenario = c("int", "ff"), limits = function(s,t){ s <= t }, + n = n, nygrid = nygrid)) data1$X1 <- scale(data1$X1, scale = FALSE) ## center functional covariate dataList <- as.list(data1) dataList$tvals <- attr(data1, "yindex") @@ -125,8 +125,8 @@ X1h <- with(dataList, hmatrix(time = rep(tvals, each = n), id = rep(1:n, nygrid) dataList$X1h <- I(X1h) dataList$svals <- attr(data1, "xindex") ## add a factor variable -dataList$zlong <- factor(gl(n = 2, k = n/2, length = n*nygrid), levels = 1:3) -dataList$z <- factor(gl(n = 2, k = n/2, length = n), levels = 1:3) +dataList$zlong <- factor(gl(n = 2, k = n/2, length = n*nygrid), levels = 1:2) +dataList$z <- factor(gl(n = 2, k = n/2, length = n), levels = 1:2) ## do the model fit with main effect of bhistx() and interaction of bhistx() and bolsc() mod <- FDboost(Y ~ 1 + bhistx(x = X1h, df = 5, knots = 5) + diff --git a/man/birthDistribution.Rd b/man/birthDistribution.Rd index abe726e..60b64f5 100644 --- a/man/birthDistribution.Rd +++ b/man/birthDistribution.Rd @@ -63,7 +63,7 @@ data("birthDistribution", package = "FDboost") # Plot densities year_col <- rainbow(70, start = 0.5, end = 1) year_lty <- c(1, 2, 4, 5) -par(mfrow = c(1, 2)) +oldpar <- par(mfrow = c(1, 2)) funplot(1:12, birthDistribution$birth_densities[1:70, ], ylab = "densities", xlab = "month", xaxp = c(1, 12, 11), pch = 20, col = year_col, lty = year_lty, main = "Male") funplot(1:12, birthDistribution$birth_densities[71:140, ], ylab = "densities", xlab = "month", @@ -105,7 +105,7 @@ funplot(1:12, predictions[1:70, ], ylab = "predictions", xlab = "month", ylim = xaxp = c(1, 12, 11), pch = 20, col = year_col, lty = year_lty, main = "Male") funplot(1:12, predictions[71:140, ], ylab = "predictions", xlab = "month", ylim = pred_ylim, xaxp = c(1, 12, 11), pch = 20, col = year_col, lty = year_lty, main = "Female") -par(mfrow = c(1, 1)) +par(oldpar) } \references{ Maier, E.-M., Stoecker, A., Fitzenberger, B., Greven, S. (2021): diff --git a/man/bootstrapCI.Rd b/man/bootstrapCI.Rd index 817f423..b0e54fb 100644 --- a/man/bootstrapCI.Rd +++ b/man/bootstrapCI.Rd @@ -86,7 +86,7 @@ to bootstrap confidence intervals are biased towards zero. \note{ Note that parallelization can be achieved by defining the \code{resampling_fun_outer} or \code{_inner} accordingly. -See, e.g., \code{\link{cvrisk}} on how to parallelize resampling +See, e.g., \code{\link[mboost]{cvrisk}} on how to parallelize resampling functions or the examples below. Also note that by defining a custum inner or outer resampling function the respective argument \code{B_inner} or \code{B_outer} is ignored. @@ -104,7 +104,7 @@ if(require(refund)){ # model with linear functional effect, use bsignal() # Y(t) = f(t) + \int X1(s)\beta(s,t)ds + eps set.seed(2121) -data1 <- pffrSim(scenario = "ff", n = 40) +data1 <- suppressWarnings(pffrSim(scenario = "ff", n = 40)) data1$X1 <- scale(data1$X1, scale = FALSE) dat_list <- as.list(data1) dat_list$t <- attr(data1, "yindex") @@ -128,25 +128,22 @@ bootCIs$mstops plot(bootCIs, ask = FALSE) } -## now speed things up by defining the inner resampling -## function with parallelization based on mclapply (does not work on Windows) - my_inner_fun <- function(object){ cvrisk(object, folds = cvLong(id = object$id, weights = -model.weights(object), -B = 10 # 10-fold for inner resampling -), mc.cores = 10) # use ten cores +model.weights(object), B = 2) # 10-fold for inner resampling +) } \donttest{ -bootCIs <- bootstrapCI(m1, resampling_fun_inner = my_inner_fun) +bootCIs <- bootstrapCI(m1, resampling_fun_inner = my_inner_fun, + B_outer = 5) # small B_outer to speed up } ## We can also use the ... argument to parallelize the applyFolds ## function in the outer resampling \donttest{ -bootCIs <- bootstrapCI(m1, mc.cores = 30) +bootCIs <- bootstrapCI(m1, B_inner = 5, B_outer = 3) } ## Now let's parallelize the outer resampling and use @@ -155,17 +152,21 @@ bootCIs <- bootstrapCI(m1, mc.cores = 30) my_inner_fun <- function(object){ cvrisk(object, folds = cvLong(id = object$id, weights = model.weights(object), type = "kfold", # use CV -B = 10, # 10-fold for inner resampling -), -mc.cores = 10) # use ten cores +B = 5, # 5-fold for inner resampling +)) # use five cores } # use applyFolds for outer function to avoid messing up weights my_outer_fun <- function(object, fun){ applyFolds(object = object, folds = cv(rep(1, length(unique(object$id))), -type = "bootstrap", B = 100), fun = fun, -mc.cores = 10) # parallelize on 10 cores +type = "bootstrap", B = 10), fun = fun) # parallelize on 10 cores +} + +\donttest{ +bootCIs <- bootstrapCI(m1, resampling_fun_inner = my_inner_fun, + resampling_fun_outer = my_outer_fun, + B_inner = 5, B_outer = 10) } ######## Example for scalar-on-function-regression with bsignal() @@ -192,15 +193,10 @@ mod2 <- FDboost(heatan ~ bsignal(UVVIS, uvvis.lambda, knots = 40, df = 4, check. \donttest{ # takes some time, because of defaults: B_outer = 100, B_inner = 25 -bootCIs <- bootstrapCI(mod2) +bootCIs <- bootstrapCI(mod2, B_outer = 10, B_inner = 5) + # in practice, rather set B_outer = 1000 } -## run with a larger number of outer bootstrap samples -## and only 10-fold for validation of each outer fold -## WARNING: This may take very long! -\donttest{ -bootCIs <- bootstrapCI(mod2, B_outer = 1000, B_inner = 10) -} } \author{ diff --git a/man/bsignal.Rd b/man/bsignal.Rd index cf3c0af..a473053 100644 --- a/man/bsignal.Rd +++ b/man/bsignal.Rd @@ -245,9 +245,8 @@ mod2 <- FDboost(heatan ~ bsignal(UVVIS, uvvis.lambda, knots = 40, df = 4, check. + bsignal(NIR, nir.lambda, knots = 40, df=4, check.ident = FALSE), timeformula = NULL, data = fuelSubset) summary(mod2) -## plot(mod2) - + ############################################### ### data simulation like in manual of pffr::ff @@ -257,7 +256,7 @@ if(require(refund)){ # model with linear functional effect, use bsignal() # Y(t) = f(t) + \int X1(s)\beta(s,t)ds + eps set.seed(2121) -data1 <- pffrSim(scenario = "ff", n = 40) +data1 <- suppressWarnings(pffrSim(scenario = "ff", n = 40)) data1$X1 <- scale(data1$X1, scale = FALSE) dat_list <- as.list(data1) dat_list$t <- attr(data1, "yindex") @@ -280,10 +279,11 @@ s <- attr(data1, "xindex") m1_pffr <- pffr(Y ~ ff(X1, xind = s), yind = t, data = data1) \donttest{ - par(mfrow = c(2, 2)) + oldpar <- par(mfrow = c(2, 2)) plot(m1, which = 1); plot(m1, which = 2) plot(m1_pffr, select = 1, shift = m1_pffr$coefficients["(Intercept)"]) plot(m1_pffr, select = 2) + par(oldpar) } @@ -294,7 +294,7 @@ set.seed(2121) mylimits <- function(s, t){ (s < t) | (s == t) } -data2 <- pffrSim(scenario = "ff", n = 40, limits = mylimits) +data2 <- suppressWarnings(pffrSim(scenario = "ff", n = 40, limits = mylimits)) data2$X1 <- scale(data2$X1, scale = FALSE) dat2_list <- as.list(data2) dat2_list$t <- attr(data2, "yindex") @@ -317,12 +317,12 @@ s <- attr(data2, "xindex") m2_pffr <- pffr(Y ~ ff(X1, xind = s, limits = "s<=t"), yind = t, data = data2) \donttest{ -par(mfrow = c(2, 2)) +oldpar <- par(mfrow = c(2, 2)) plot(m2, which = 1); plot(m2, which = 2) ## plot of smooth intercept does not contain m1_pffr$coefficients["(Intercept)"] plot(m2_pffr, select = 1, shift = m2_pffr$coefficients["(Intercept)"]) plot(m2_pffr, select = 2) - +par(oldpar) } diff --git a/man/coef.FDboost.Rd b/man/coef.FDboost.Rd index 0db6969..ba39ff8 100644 --- a/man/coef.FDboost.Rd +++ b/man/coef.FDboost.Rd @@ -26,7 +26,7 @@ If \code{raw = TRUE} the coefficients of the model are returned.} \item{which}{a subset of base-learners for which the coefficients should be computed (numeric vector), -defaults to NULL which is the same as \code{which=1:length(object$baselearner)}. +defaults to NULL which is the same as \code{which=seq_along(object$baselearner)}. In the special case of \code{which=0}, only the coefficients of the offset are returned.} \item{computeCoef}{defaults to \code{TRUE}, if \code{FALSE} only the names of the terms are returned} diff --git a/man/cvrisk.FDboostLSS.Rd b/man/cvrisk.FDboostLSS.Rd index c9a4af8..996c40b 100644 --- a/man/cvrisk.FDboostLSS.Rd +++ b/man/cvrisk.FDboostLSS.Rd @@ -23,10 +23,10 @@ defaults to 25 bootstrap samples, resampling whole curves} \item{grid}{defaults to a grid up to the current number of boosting iterations. The default generates the grid according to the defaults of -\code{\link{cvrisk.mboostLSS}} which are different for models with cyclic or noncyclic fitting.} +\code{\link[gamboostLSS]{cvrisk.mboostLSS}} which are different for models with cyclic or noncyclic fitting.} -\item{papply}{(parallel) apply function, defaults to \code{\link{mclapply}}, -see \code{\link{cvrisk.mboostLSS}} for details.} +\item{papply}{(parallel) apply function, defaults to \code{\link[parallel]{mclapply}}, +see \code{\link[gamboostLSS]{cvrisk.mboostLSS}} for details.} \item{trace}{print status information during cross-validation? Defaults to \code{TRUE}.} @@ -34,13 +34,13 @@ see \code{\link{cvrisk.mboostLSS}} for details.} \code{fun}, as a function of \code{object}, may extract any other characteristic of the cross-validated models. These are returned as is.} -\item{...}{additional arguments passed to \code{\link{mclapply}}.} +\item{...}{additional arguments passed to \code{\link[parallel]{mclapply}}.} } \value{ An object of class \code{cvriskLSS} (when \code{fun} was not specified), basically a matrix containing estimates of the empirical risk for a varying number of bootstrap iterations. \code{plot} and \code{print} methods are available as well as an -\code{mstop} method, see \code{\link{cvrisk.mboostLSS}}. +\code{mstop} method, see \code{\link[gamboostLSS]{cvrisk.mboostLSS}}. } \description{ Multidimensional cross-validated estimation of the empirical risk for hyper-parameter selection, @@ -53,6 +53,6 @@ It overrides the default for the folds, so that the folds are sampled on the lev (not on the level of single observations, which does not make sense for functional response). } \seealso{ -\code{\link{cvrisk.mboostLSS}} in +\code{\link[gamboostLSS]{cvrisk.mboostLSS}} in package \code{gamboostLSS}. } diff --git a/man/factorize.Rd b/man/factorize.Rd new file mode 100644 index 0000000..b49c9da --- /dev/null +++ b/man/factorize.Rd @@ -0,0 +1,344 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/factorize.R +\name{factorize} +\alias{factorize} +\alias{factorise} +\alias{factorize.FDboost} +\title{Factorize tensor product model} +\usage{ +factorize(x, ...) + +\method{factorize}{FDboost}(x, newdata = NULL, newweights = 1, blwise = TRUE, ...) +} +\arguments{ +\item{x}{a model object of class FDboost.} + +\item{...}{other arguments passed to methods.} + +\item{newdata}{new data the factorization is based on. +By default (\code{NULL}), the factorization is carried out on the data used for fitting.} + +\item{newweights}{vector of the length of the data or length one, +containing new weights used for factorization.} + +\item{blwise}{logical, should the factorization be carried out base-learner-wise (\code{TRUE}, default) +or for the whole model simultaneously.} +} +\value{ +a list of two mboost models of class \code{FDboost_fac} containing basis functions +for response and covariates, respectively, as base-learners. + +A factorized model +} +\description{ +Factorize an FDboost tensor product model into the response and covariate parts +\deqn{h_j(x, t) = \sum_{k} v_j^{(k)}(t) h_j^{(k)}(x), j = 1, ..., J,} +for effect visualization as proposed in Stoecker, Steyer and Greven (2022). +} +\details{ +The mboost infrastructure is used for handling the orthogonal response +directions \eqn{v_j^{(k)}(t)} in one \code{mboost}-object +(with \eqn{k} running over iteration indices) and the effects into the respective +directions \eqn{h_j^{(k)}(t)} in another \code{mboost}-object, +both of subclass \code{FDboost_fac}. +The number of boosting iterations of \code{FDboost_fac}-objects cannot be +further increased as in regular \code{mboost}-objects. +} +\examples{ +library(FDboost) + +# generate irregular toy data ------------------------------------------------------- + +n <- 100 +m <- 40 +# covariates +x <- seq(0,2,len = n) +# time & id +set.seed(90384) +t <- runif(n = n*m, -pi,pi) +id <- sample(1:n, size = n*m, replace = TRUE) + +# generate components +fx <- ft <- list() +fx[[1]] <- exp(x) +d <- numeric(2) +d[1] <- sqrt(c(crossprod(fx[[1]]))) +fx[[1]] <- fx[[1]] / d[1] +fx[[2]] <- -5*x^2 +fx[[2]] <- fx[[2]] - fx[[1]] * c(crossprod(fx[[1]], fx[[2]])) # orthogonalize fx[[2]] +d[2] <- sqrt(c(crossprod(fx[[2]]))) +fx[[2]] <- fx[[2]] / d[2] +ft[[1]] <- sin(t) +ft[[2]] <- cos(t) +ft[[1]] <- ft[[1]] / sqrt(sum(ft[[1]]^2)) +ft[[2]] <- ft[[2]] / sqrt(sum(ft[[2]]^2)) + +mu1 <- d[1] * fx[[1]][id] * ft[[1]] +mu2 <- d[2] * fx[[2]][id] * ft[[2]] +# add linear covariate +ft[[3]] <- t^2 * sin(4*t) +ft[[3]] <- ft[[3]] - ft[[1]] * c(crossprod(ft[[1]], ft[[3]])) +ft[[3]] <- ft[[3]] - ft[[2]] * c(crossprod(ft[[2]], ft[[3]])) +ft[[3]] <- ft[[3]] / sqrt(sum(ft[[3]]^2)) +set.seed(9234) +fx[[3]] <- runif(0,3, n = length(x)) +fx[[3]] <- fx[[3]] - fx[[1]] * c(crossprod(fx[[1]], fx[[3]])) +fx[[3]] <- fx[[3]] - fx[[2]] * c(crossprod(fx[[2]], fx[[3]])) +d[3] <- sqrt(sum(fx[[3]]^2)) +fx[[3]] <- fx[[3]] / d[3] + +mu3 <- d[3] * fx[[3]][id] * ft[[3]] + +mu <- mu1 + mu2 + mu3 +# add some noise +y <- mu + rnorm(length(mu), 0, .01) +# and noise covariate +z <- rnorm(n) + +# fit FDboost model ------------------------------------------------------- + +dat <- list(y = y, x = x, t = t, x_lin = fx[[3]], id = id) +m <- FDboost(y ~ bbs(x, knots = 5, df = 2, differences = 0) + + # bbs(z, knots = 2, df = 2, differences = 0) + + bols(x_lin, intercept = FALSE, df = 2) + , ~ bbs(t), + id = ~ id, + offset = 0, #numInt = "Riemann", + control = boost_control(nu = 1), + data = dat) +MU <- split(mu, id) +PRED <- split(predict(m), id) +Ti <- split(t, id) +t0 <- seq(-pi, pi, length.out = 40) +MU <- do.call(cbind, Map(function(mu, t) approx(t, mu, t0)$y, + MU, Ti)) +PRED <- do.call(cbind, Map(function(mu, t) approx(t, mu, t0)$y, + PRED, Ti)) + +opar <- par(mfrow = c(2,2)) +image(t0, x, MU) +contour(t0, x, MU, add = TRUE) +image(t0, x, PRED) +contour(t0, x, PRED, add = TRUE) +persp(t0, x, MU, zlim = range(c(MU, PRED), na.rm = TRUE)) +persp(t0, x, PRED, zlim = range(c(MU, PRED), na.rm = TRUE)) +par(opar) + +# factorize model --------------------------------------------------------- + +fac <- factorize(m) + +vi <- as.data.frame(varimp(fac$cov)) +# if(require(lattice)) +# barchart(variable ~ reduction, group = blearner, vi, stack = TRUE) + +cbind(d^2, sort(vi$reduction, decreasing = TRUE)[1:3]) + + +x_plot <- list(x, x, fx[[3]]) + +cols <- c("cornflowerblue", "darkseagreen", "darkred") +opar <- par(mfrow = c(3,2)) +wch <- c(1,2,10) +for(w in seq_along(wch)) { + plot.mboost(fac$resp, which = wch[w], col = "darkgrey", ask = FALSE, + main = names(fac$resp$baselearner[wch[w]])) + lines(sort(t), ft[[w]][order(t)]*max(d), col = cols[w], lty = 2) + plot(fac$cov, which = wch[w], + main = names(fac$cov$baselearner[wch[w]])) + points(x_plot[[w]], d[w] * fx[[w]] / max(d), col = cols[w], pch = 3) +} +par(opar) + +# re-compose predictions +preds <- lapply(fac, predict) +predf <- rowSums(preds$resp * preds$cov[id, ]) +PREDf <- split(predf, id) +PREDf <- do.call(cbind, Map(function(mu, t) approx(t, mu, t0)$y, + PREDf, Ti)) +opar <- par(mfrow = c(1,2)) +image(t0,x, PRED, main = "original prediction") +contour(t0,x, PRED, add = TRUE) +image(t0,x,PREDf, main = "recomposed") +contour(t0,x, PREDf, add = TRUE) +par(opar) + +stopifnot(all.equal(PRED, PREDf)) + +# check out other methods +set.seed(8399) +newdata_resp <- list(t = sort(runif(60, min(t), max(t)))) +a <- predict(fac$resp, newdata = newdata_resp, which = 1:5) +plot(newdata_resp$t, a[, 1]) +# coef method +cf <- coef(fac$resp, which = 1) + + +# check factorization on a new dataset ------------------------------------ + +t_grid <- seq(-pi,pi,len = 30) +x_grid <- seq(0,2,len = 30) +x_lin_grid <- seq(min(dat$x_lin), max(dat$x_lin), len = 30) + +# use grid data for factorization +griddata <- expand.grid( + # time + t = t_grid, + # covariates + x = x_grid, + x_lin = 0 +) + +griddata_lin <- expand.grid( + t = seq(-pi, pi, len = 30), + x = 0, + x_lin = x_lin_grid +) + +griddata <- rbind(griddata, griddata_lin) + +griddata$id <- as.numeric(factor(paste(griddata$x, griddata$x_lin, sep = ":"))) + +fac2 <- factorize(m, newdata = griddata) + +ratio <- -max(abs(predict(fac$resp, which = 1))) / max(abs(predict(fac2$resp, which = 1))) + +opar <- par(mfrow = c(3,2)) +wch <- c(1,2,10) +for(w in seq_along(wch)) { + plot.mboost(fac$resp, which = wch[w], col = "darkgrey", ask = FALSE, + main = names(fac$resp$baselearner[wch[w]])) + + lines(sort(griddata$t), + ratio*predict(fac2$resp, which = wch[w])[order(griddata$t)], + col = cols[w], lty = 2) + plot(fac$cov, which = wch[w], + main = names(fac$cov$baselearner[wch[w]])) + this_x <- fac2$cov$model.frame(which = wch[w])[[1]][[1]] + lines(sort(this_x), 1/ratio*predict(fac2$cov, which = wch[w])[order(this_x)], + col = cols[w], lty = 1) +} +par(opar) + +# check predictions +p <- predict(fac2$resp, which = 1) +library(FDboost) + +# generate regular toy data -------------------------------------------------- + +n <- 100 +m <- 40 +# covariates +x <- seq(0,2,len = n) +# time +t <- seq(-pi,pi,len = m) +# generate components +fx <- ft <- list() +fx[[1]] <- exp(x) +d <- numeric(2) +d[1] <- sqrt(c(crossprod(fx[[1]]))) +fx[[1]] <- fx[[1]] / d[1] +fx[[2]] <- -5*x^2 +fx[[2]] <- fx[[2]] - fx[[1]] * c(crossprod(fx[[1]], fx[[2]])) # orthogonalize fx[[2]] +d[2] <- sqrt(c(crossprod(fx[[2]]))) +fx[[2]] <- fx[[2]] / d[2] +ft[[1]] <- sin(t) +ft[[2]] <- cos(t) +ft[[1]] <- ft[[1]] / sqrt(sum(ft[[1]]^2)) +ft[[2]] <- ft[[2]] / sqrt(sum(ft[[2]]^2)) +mu1 <- d[1] * fx[[1]] \%*\% t(ft[[1]]) +mu2 <- d[2] * fx[[2]] \%*\% t(ft[[2]]) +# add linear covariate +ft[[3]] <- t^2 * sin(4*t) +ft[[3]] <- ft[[3]] - ft[[1]] * c(crossprod(ft[[1]], ft[[3]])) +ft[[3]] <- ft[[3]] - ft[[2]] * c(crossprod(ft[[2]], ft[[3]])) +ft[[3]] <- ft[[3]] / sqrt(sum(ft[[3]]^2)) +set.seed(9234) +fx[[3]] <- runif(0,3, n = length(x)) +fx[[3]] <- fx[[3]] - fx[[1]] * c(crossprod(fx[[1]], fx[[3]])) +fx[[3]] <- fx[[3]] - fx[[2]] * c(crossprod(fx[[2]], fx[[3]])) +d[3] <- sqrt(sum(fx[[3]]^2)) +fx[[3]] <- fx[[3]] / d[3] +mu3 <- d[3] * fx[[3]] \%*\% t(ft[[3]]) + +mu <- mu1 + mu2 + mu3 +# add some noise +y <- mu + rnorm(length(mu), 0, .01) +# and noise covariate +z <- rnorm(n) + +# fit FDboost model ------------------------------------------------------- + +dat <- list(y = y, x = x, t = t, x_lin = fx[[3]]) +m <- FDboost(y ~ bbs(x, knots = 5, df = 2, differences = 0) + + # bbs(z, knots = 2, df = 2, differences = 0) + + bols(x_lin, intercept = FALSE, df = 2) + , ~ bbs(t), offset = 0, + control = boost_control(nu = 1), + data = dat) + +opar <- par(mfrow = c(1,2)) +image(t, x, t(mu)) +contour(t, x, t(mu), add = TRUE) +image(t, x, t(predict(m))) +contour(t, x, t(predict(m)), add = TRUE) +par(opar) + +# factorize model --------------------------------------------------------- + +fac <- factorize(m) + +vi <- as.data.frame(varimp(fac$cov)) +# if(require(lattice)) +# barchart(variable ~ reduction, group = blearner, vi, stack = TRUE) + +cbind(d^2, vi$reduction[c(1:2, 10)]) + + +x_plot <- list(x, x, fx[[3]]) + +cols <- c("cornflowerblue", "darkseagreen", "darkred") +opar <- par(mfrow = c(3,2)) +wch <- c(1,2,10) +for(w in seq_along(wch)) { + plot.mboost(fac$resp, which = wch[w], col = "darkgrey", ask = FALSE, + main = names(fac$resp$baselearner[wch[w]])) + lines(t, ft[[w]]*max(d), col = cols[w], lty = 2) + plot(fac$cov, which = wch[w], + main = names(fac$cov$baselearner[wch[w]])) + points(x_plot[[w]], d[w] * fx[[w]] / max(d), col = cols[w], pch = 3) +} +par(opar) + +# re-compose prediction +preds <- lapply(fac, predict) +PREDSf <- array(0, dim = c(nrow(preds$resp),nrow(preds$cov))) +for(i in seq_len(ncol(preds$resp))) + PREDSf <- PREDSf + preds$resp[,i] \%*\% t(preds$cov[,i]) + +opar <- par(mfrow = c(1,2)) +image(t,x, t(predict(m)), main = "original prediction") +contour(t,x, t(predict(m)), add = TRUE) +image(t,x,PREDSf, main = "recomposed") +contour(t,x, PREDSf, add = TRUE) +par(opar) +# => matches +stopifnot(all.equal(as.numeric(t(predict(m))), as.numeric(PREDSf))) + +# check out other methods +set.seed(8399) +newdata_resp <- list(t = sort(runif(60, min(t), max(t)))) +a <- predict(fac$resp, newdata = newdata_resp, which = 1:5) +plot(newdata_resp$t, a[, 1]) +# coef method +cf <- coef(fac$resp, which = 1) + +} +\references{ +Stoecker, A., Steyer L. and Greven, S. (2022): +Functional additive models on manifolds of planar shapes and forms + +} +\seealso{ +[FDboost_fac-class] +} diff --git a/man/funplot.Rd b/man/funplot.Rd index febce71..8b6198a 100644 --- a/man/funplot.Rd +++ b/man/funplot.Rd @@ -18,6 +18,9 @@ or vector or functional observations, in this case id has to be specified} \item{...}{further arguments passed to \code{\link[graphics]{matplot}}.} } +\value{ +see \code{\link[graphics]{matplot}} +} \description{ Plot functional data with linear interpolation of missing values } diff --git a/man/getTime.Rd b/man/getTime.Rd index 836c0c6..046c954 100644 --- a/man/getTime.Rd +++ b/man/getTime.Rd @@ -30,6 +30,9 @@ getArgvalsLab(object) \arguments{ \item{object}{an R-object, currently implemented for hmatrix and fmatrix} } +\value{ +properties of a hmatrix or fmatrix +} \description{ Extract attributes of an object. } diff --git a/man/getTime.hmatrix.Rd b/man/getTime.hmatrix.Rd index e21c969..6139327 100644 --- a/man/getTime.hmatrix.Rd +++ b/man/getTime.hmatrix.Rd @@ -30,6 +30,9 @@ \arguments{ \item{object}{object of class hmatrix} } +\value{ +properties of a hmatrix +} \description{ Extract attributes of an object of class \code{hmatrix}. } diff --git a/man/grapes-Xc-grapes.Rd b/man/grapes-Xc-grapes.Rd index 2c1e2cc..11f3826 100644 --- a/man/grapes-Xc-grapes.Rd +++ b/man/grapes-Xc-grapes.Rd @@ -11,6 +11,10 @@ bl1 \%Xc\% bl2 \item{bl2}{base-learner 2, e.g. \code{bols(x2)}} } +\value{ +An object of class \code{blg} (base-learner generator) with a \code{dpp} function +as for other \code{\link[mboost:baselearners]{baselearners}}. +} \description{ Combining single base-learners to form new, more complex base-learners, with an identifiability constraint to center the interaction around the intercept and diff --git a/man/hmatrix.Rd b/man/hmatrix.Rd index b692acf..1400a15 100644 --- a/man/hmatrix.Rd +++ b/man/hmatrix.Rd @@ -8,7 +8,7 @@ hmatrix( time, id, x, - argvals = 1:ncol(x), + argvals = seq_len(ncol(x)), timeLab = "t", idLab = "wideIndex", xLab = "x", @@ -24,7 +24,7 @@ i.e. at which \code{t} the response curve is observed} \item{x}{matrix of functional covariate, each trajectory is in one row} \item{argvals}{set of argument values, i.e., the common gird at which the functional covariate -is observed, by default \code{1:ncol(x)}} +is observed, by default \code{seq_len(ncol(x))}} \item{timeLab}{name of the time axis, by default \code{t}} @@ -34,6 +34,9 @@ is observed, by default \code{1:ncol(x)}} \item{argvalsLab}{name of the argument for the covariate by default \code{s}} } +\value{ +An matrix object of type \code{"hmatrix"} +} \description{ The hmatrix class represents data for a functional historical effect. The class is basically a matrix containing the time and the id for the observations of the @@ -73,7 +76,7 @@ reweightData(data = list(hmat = myhmatrix), vars = "hmat", index = c(1, 1, 2)) # ids and times in the time id matrix # for bhistx baselearner, there may be an additional id variable for the tensor product newdat <- reweightData(data = list(hmat = myhmatrix, - repIDx = rep(1:nrow(attr(myhmatrix,'x')), length(attr(myhmatrix,"argvals")))), + repIDx = rep(seq_len(nrow(attr(myhmatrix,'x'))), length(attr(myhmatrix,"argvals")))), vars = "hmat", index = c(1,1,2), idvars="repIDx") length(newdat$repIDx) @@ -82,7 +85,7 @@ mydat <- data.frame(I(myhmatrix), z=rnorm(3)[id1]) str(mydat) str(mydat[id1 \%in\% c(2, 3), ]) str(myhmatrix[id1 \%in\% c(2, 3), ]) - + } \seealso{ \code{\link{getTime.hmatrix}} to extract attributes, diff --git a/man/integrationWeights.Rd b/man/integrationWeights.Rd index 74130ce..1d6978f 100644 --- a/man/integrationWeights.Rd +++ b/man/integrationWeights.Rd @@ -25,6 +25,9 @@ The default is to use the mean over all integration weights, \code{"mean"}. Alternatively one can use the first integration weight, \code{"first"}, or use the distance to zero, \code{"zero"}.} } +\value{ +Matrix with integration +} \description{ Computes trapezoidal integration weights (Riemann sums) for a functional variable \code{X1} that has evaluation points \code{xind}. diff --git a/man/is.hmatrix.Rd b/man/is.hmatrix.Rd index 8b243a9..0348a03 100644 --- a/man/is.hmatrix.Rd +++ b/man/is.hmatrix.Rd @@ -9,6 +9,9 @@ is.hmatrix(object) \arguments{ \item{object}{object of class hmatrix} } +\value{ +logical value +} \description{ is.hmatrix tests if its argument is an object of class hmatrix. } diff --git a/man/o_control.Rd b/man/o_control.Rd index dffb138..672425f 100644 --- a/man/o_control.Rd +++ b/man/o_control.Rd @@ -19,6 +19,9 @@ closest non-missing value, see \code{\link[stats:approxfun]{approx}}} \item{knots}{arguments knots passed to \code{\link[mgcv]{gam}}} } +\value{ +a list with controls +} \description{ Function to control estimation of smooth offset } diff --git a/man/plot.FDboost.Rd b/man/plot.FDboost.Rd index c04e4a4..a59a6be 100644 --- a/man/plot.FDboost.Rd +++ b/man/plot.FDboost.Rd @@ -89,6 +89,9 @@ Per default all observations are plotted.} \item{lwdPred}{lwd of predicted curves (only used in plotPredicted)} } +\value{ +no return value (plot method) +} \description{ Takes a fitted \code{FDboost}-object produced by \code{\link{FDboost}()} and plots the fitted effects or the coefficient-functions/surfaces. diff --git a/man/plot.bootstrapCI.Rd b/man/plot.bootstrapCI.Rd index 519bd27..cdc674b 100644 --- a/man/plot.bootstrapCI.Rd +++ b/man/plot.bootstrapCI.Rd @@ -42,6 +42,9 @@ defaults to \code{probs = c(0.25, 0.5, 0.75)}} \item{...}{additional arguments passed to callies.} } +\value{ +No return value (plot method) or \code{x} itself (print method) +} \description{ Methods for objects that are fitted to compute bootstrap confidence intervals. } diff --git a/man/plot.validateFDboost.Rd b/man/plot.validateFDboost.Rd index bbaef3c..bff5eb6 100644 --- a/man/plot.validateFDboost.Rd +++ b/man/plot.validateFDboost.Rd @@ -84,6 +84,9 @@ predicted values of the whole model can be compared to the predictions of the cr \item{probs}{vector of quantiles to be used in the plotting of 2-dimensional coefficients surfaces, defaults to \code{probs = c(0.25, 0.5, 0.75)}} } +\value{ +No return value (plot method) or the object itself (print method) +} \description{ Methods for objects that are fitted to determine the optimal mstop and the prediction error of a model fitted by FDboost. diff --git a/man/predict.FDboost.Rd b/man/predict.FDboost.Rd index 6c86131..53e2d4a 100644 --- a/man/predict.FDboost.Rd +++ b/man/predict.FDboost.Rd @@ -25,7 +25,7 @@ a list is returned.} (i.e. response is supplied as matrix): should the predictions be returned as matrix, or list of matrices instead of vectors} -\item{...}{additional arguments passed on to \code{\link[mboost:methods]{predict.mboost}()}.} +\item{...}{additional arguments passed on to \code{\link[mboost]{predict.mboost}()}.} } \value{ a matrix or list of predictions depending on values of unlist and which @@ -34,7 +34,7 @@ a matrix or list of predictions depending on values of unlist and which Takes a fitted \code{FDboost}-object produced by \code{\link{FDboost}()} and produces predictions given a new set of values for the model covariates or the original values used for the model fit. This is a wrapper - function for \code{\link[mboost:methods]{predict.mboost}()} + function for \code{\link[mboost]{predict.mboost}()} } \seealso{ \code{\link{FDboost}} for the model fit diff --git a/man/predict.FDboost_fac.Rd b/man/predict.FDboost_fac.Rd new file mode 100644 index 0000000..cf757bc --- /dev/null +++ b/man/predict.FDboost_fac.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/factorize.R +\name{predict.FDboost_fac} +\alias{predict.FDboost_fac} +\alias{plot.FDboost_fac} +\title{Prediction and plotting for factorized FDboost model components} +\usage{ +\method{predict}{FDboost_fac}(object, newdata = NULL, which = NULL, ...) + +\method{plot}{FDboost_fac}(x, which = NULL, main = NULL, ...) +} +\arguments{ +\item{object, x}{a model-factor given as a \code{FDboost_fac} object} + +\item{newdata}{optionally, a data frame or list +in which to look for variables with which to predict. +See \code{\link[mboost]{predict.mboost}}.} + +\item{which}{a subset of base-learner components to take into +account for computing predictions or coefficients. Different +components are never aggregated to a joint prediction, but always +returned as a matrix or list. Select the k-th component +by name in the format \code{bl(x, ...)[k]} or all components of a base-learner +by dropping the index or all base-learners of a variable by using +the variable name.} + +\item{...}{additional arguments passed to underlying methods.} + +\item{main}{the plot title. By default, base-learner names are used with +component numbers \code{[k]}.} +} +\value{ +A matrix of predictions (for predict method) or no +return value (plot method) +} +\description{ +Prediction and plotting for factorized FDboost model components +} +\seealso{ +[factorize(), factorize.FDboost()] +} diff --git a/man/sub-.hmatrix.Rd b/man/sub-.hmatrix.Rd index 62f5c92..9e53123 100644 --- a/man/sub-.hmatrix.Rd +++ b/man/sub-.hmatrix.Rd @@ -19,6 +19,9 @@ vectors or empty (missing) or NULL. Numeric values are coerced to integer as by (or just a matrix). This only works for extracting elements, not for the replacement, defaults to \code{FALSE}.} } +\value{ +a \code{"hmatrix"} object +} \description{ Operator acting on hmatrix preserving the attributes when rows are extracted. } diff --git a/man/subset_hmatrix.Rd b/man/subset_hmatrix.Rd index e573335..7cba3cd 100644 --- a/man/subset_hmatrix.Rd +++ b/man/subset_hmatrix.Rd @@ -15,6 +15,9 @@ for each curve to select} \item{compress}{logical, defaults to \code{TRUE}. Only used to force a meaningful behaviour of \code{applyFolds} with hmatrix objects when using nested resampling.} } +\value{ +a \code{hmatrix} object +} \description{ Subsets hmatrix according to an index } diff --git a/man/truncateTime.Rd b/man/truncateTime.Rd index 6c83c0a..0534c05 100644 --- a/man/truncateTime.Rd +++ b/man/truncateTime.Rd @@ -36,10 +36,11 @@ if(require(fda)){ datTr <- truncateTime(funVar=c("hgtm","hgtf"), time="age", newtime=1:16, data=dat) \donttest{ - par(mfrow=c(1,2)) + oldpar <- par(mfrow=c(1,2)) with(dat, funplot(age, hgtm, main="Original data")) with(datTr, funplot(age, hgtm, main="Yearly data")) par(mfrow=c(1,1)) + par(oldpar) } } } diff --git a/man/validateFDboost.Rd b/man/validateFDboost.Rd index 0ed6033..2eaa37f 100644 --- a/man/validateFDboost.Rd +++ b/man/validateFDboost.Rd @@ -121,7 +121,7 @@ mod <- FDboost(l10precip ~ 1 + bolsc(region, df = 4) + mod <- mod[75] #### create folds for 3-fold bootstrap: one weight for each curve - set.seed(123) + set.seed(124) folds_bs <- cv(weights = rep(1, mod$ydim[1]), type = "bootstrap", B = 3) ## compute out-of-bag risk on the 3 folds for 1 to 75 boosting iterations @@ -131,13 +131,13 @@ mod <- mod[75] cvr2 <- validateFDboost(mod, folds = folds_bs, grid = 1:75) ## weights per observation point - folds_bs_long <- folds_bs[rep(1:nrow(folds_bs), times = mod$ydim[2]), ] + folds_bs_long <- folds_bs[rep(seq_len(nrow(folds_bs)), times = mod$ydim[2]), ] attr(folds_bs_long, "type") <- "3-fold bootstrap" ## compute out-of-bag risk on the 3 folds for 1 to 75 boosting iterations cvr3 <- cvrisk(mod, folds = folds_bs_long, grid = 1:75) ## plot the out-of-bag risk - par(mfrow = c(1,3)) + oldpar <- par(mfrow = c(1,3)) plot(cvr); legend("topright", lty=2, paste(mstop(cvr))) plot(cvr2) plot(cvr3); legend("topright", lty=2, paste(mstop(cvr3))) @@ -145,7 +145,7 @@ mod <- mod[75] ## plot the estimated coefficients per fold ## more meaningful for higher number of folds, e.g., B = 100 par(mfrow = c(2,2)) - plotPredCoef(cvr2, terms = FALSE, which = 2) + plotPredCoef(cvr2, terms = FALSE, which = 1) plotPredCoef(cvr2, terms = FALSE, which = 3) ## compute out-of-bag risk and predictions for leaving-one-curve-out cross-validation @@ -156,6 +156,8 @@ mod <- mod[75] plotPredCoef(cvr_jackknife, which = 3) ## plot coefficients per fold for 2nd effect plotPredCoef(cvr_jackknife, which = 2, terms = FALSE) + + par(oldpar) } } diff --git a/man/viscosity.Rd b/man/viscosity.Rd index bfdb9eb..2fe32ba 100644 --- a/man/viscosity.Rd +++ b/man/viscosity.Rd @@ -1,62 +1,61 @@ -\name{viscosity} -\alias{viscosity} -\docType{data} -\title{ Viscosity of resin over time} -\description{ - - In an experimental setting the viscosity of resin was measured over time - to asses the curing process depending on 5 binary factors (low-high). - -} -\usage{data("viscosity")} -\format{ - A data list with 64 observations on the following 7 variables. - \describe{ - \item{\code{visAll}}{viscosity measures over all available time points} - \item{\code{timeAll}}{time points of viscosity measures} - \item{\code{T_C}}{ temperature of tools} - \item{\code{T_A}}{temperature of resin} - \item{\code{T_B}}{temperature of curing agent} - \item{\code{rspeed}}{rotational speed} - \item{\code{mflow}}{mass flow} - } -} -\details{ -The aim is to determine factors that affect the curing process in the mold. -The desired viscosity-curve has low values in the beginning followed -by a sharp increase. -Due to technical reasons the measuring method of the rheometer has to be -changed in a certain range of viscosity. The first observations are measured -by rotation of a blade giving observations every two seconds, -the later observations are measured through oscillation of a blade giving -observations every ten seconds. In the later observations the resin is quite -hard so the measurements should be interpreted as a qualitative measure of hardening. -} -\source{ - Wolfgang Raffelt, Technical University of Munich, Institute for Carbon Composites -} -\examples{ - - data("viscosity", package = "FDboost") - ## set time-interval that should be modeled - interval <- "101" - - ## model time until "interval" and take log() of viscosity - end <- which(viscosity$timeAll==as.numeric(interval)) - viscosity$vis <- log(viscosity$visAll[,1:end]) - viscosity$time <- viscosity$timeAll[1:end] - # with(viscosity, funplot(time, vis, pch=16, cex=0.2)) - - ## fit median regression model with 100 boosting iterations, - ## step-length 0.4 and smooth time-specific offset - ## the factors are in effect coding -1, 1 for the levels - mod <- FDboost(vis ~ 1 + bols(T_C, contrasts.arg = "contr.sum", intercept=FALSE) - + bols(T_A, contrasts.arg = "contr.sum", intercept=FALSE), - timeformula=~bbs(time, lambda=100), - numInt="equal", family=QuantReg(), - offset=NULL, offset_control = o_control(k_min = 9), - data=viscosity, control=boost_control(mstop = 100, nu = 0.4)) - summary(mod) - -} -\keyword{datasets} +\name{viscosity} +\alias{viscosity} +\docType{data} +\title{ Viscosity of resin over time} +\description{ + + In an experimental setting the viscosity of resin was measured over time + to asses the curing process depending on 5 binary factors (low-high). + +} +\usage{data("viscosity")} +\format{ + A data list with 64 observations on the following 7 variables. + \describe{ + \item{\code{visAll}}{viscosity measures over all available time points} + \item{\code{timeAll}}{time points of viscosity measures} + \item{\code{T_C}}{ temperature of tools} + \item{\code{T_A}}{temperature of resin} + \item{\code{T_B}}{temperature of curing agent} + \item{\code{rspeed}}{rotational speed} + \item{\code{mflow}}{mass flow} + } +} +\details{ +The aim is to determine factors that affect the curing process in the mold. +The desired viscosity-curve has low values in the beginning followed +by a sharp increase. +Due to technical reasons the measuring method of the rheometer has to be +changed in a certain range of viscosity. The first observations are measured +by rotation of a blade giving observations every two seconds, +the later observations are measured through oscillation of a blade giving +observations every ten seconds. In the later observations the resin is quite +hard so the measurements should be interpreted as a qualitative measure of hardening. +} +\source{ + Wolfgang Raffelt, Technical University of Munich, Institute for Carbon Composites +} +\examples{ + + data("viscosity", package = "FDboost") + ## set time-interval that should be modeled + interval <- "101" + + ## model time until "interval" and take log() of viscosity + end <- which(viscosity$timeAll==as.numeric(interval)) + viscosity$vis <- log(viscosity$visAll[,1:end]) + viscosity$time <- viscosity$timeAll[1:end] + + ## fit median regression model with 100 boosting iterations, + ## step-length 0.4 and smooth time-specific offset + ## the factors are in effect coding -1, 1 for the levels + mod <- FDboost(vis ~ 1 + bols(T_C, contrasts.arg = "contr.sum", intercept=FALSE) + + bols(T_A, contrasts.arg = "contr.sum", intercept=FALSE), + timeformula=~bbs(time, lambda=100), + numInt="equal", family=QuantReg(), + offset=NULL, offset_control = o_control(k_min = 9), + data=viscosity, control=boost_control(mstop = 100, nu = 0.4)) + summary(mod) + +} +\keyword{datasets} diff --git a/man/wide2long.Rd b/man/wide2long.Rd index bc1269e..9f8b26f 100644 --- a/man/wide2long.Rd +++ b/man/wide2long.Rd @@ -11,6 +11,9 @@ wide2long(time, id) \item{id}{the id for the curve} } +\value{ +a list with \code{time} and \code{id} +} \description{ Transform id and time from wide format into long format, i.e., time and id are repeated accordingly so that two vectors of the same length are returned. diff --git a/tests/factorize_test_irregular.R b/tests/factorize_test_irregular.R new file mode 100644 index 0000000..2d9e089 --- /dev/null +++ b/tests/factorize_test_irregular.R @@ -0,0 +1,177 @@ +library(FDboost) + +# generate irregular toy data ------------------------------------------------------- + +n <- 100 +m <- 40 +# covariates +x <- seq(0,2,len = n) +# time & id +set.seed(90384) +t <- runif(n = n*m, -pi,pi) +id <- sample(1:n, size = n*m, replace = TRUE) + +# generate components +fx <- ft <- list() +fx[[1]] <- exp(x) +d <- numeric(2) +d[1] <- sqrt(c(crossprod(fx[[1]]))) +fx[[1]] <- fx[[1]] / d[1] +fx[[2]] <- -5*x^2 +fx[[2]] <- fx[[2]] - fx[[1]] * c(crossprod(fx[[1]], fx[[2]])) # orthogonalize fx[[2]] +d[2] <- sqrt(c(crossprod(fx[[2]]))) +fx[[2]] <- fx[[2]] / d[2] +ft[[1]] <- sin(t) +ft[[2]] <- cos(t) +ft[[1]] <- ft[[1]] / sqrt(sum(ft[[1]]^2)) +ft[[2]] <- ft[[2]] / sqrt(sum(ft[[2]]^2)) + +mu1 <- d[1] * fx[[1]][id] * ft[[1]] +mu2 <- d[2] * fx[[2]][id] * ft[[2]] +# add linear covariate +ft[[3]] <- t^2 * sin(4*t) +ft[[3]] <- ft[[3]] - ft[[1]] * c(crossprod(ft[[1]], ft[[3]])) +ft[[3]] <- ft[[3]] - ft[[2]] * c(crossprod(ft[[2]], ft[[3]])) +ft[[3]] <- ft[[3]] / sqrt(sum(ft[[3]]^2)) +set.seed(9234) +fx[[3]] <- runif(0,3, n = length(x)) +fx[[3]] <- fx[[3]] - fx[[1]] * c(crossprod(fx[[1]], fx[[3]])) +fx[[3]] <- fx[[3]] - fx[[2]] * c(crossprod(fx[[2]], fx[[3]])) +d[3] <- sqrt(sum(fx[[3]]^2)) +fx[[3]] <- fx[[3]] / d[3] + +mu3 <- d[3] * fx[[3]][id] * ft[[3]] + +mu <- mu1 + mu2 + mu3 +# add some noise +y <- mu + rnorm(length(mu), 0, .01) +# and noise covariate +z <- rnorm(n) + +# fit FDboost model ------------------------------------------------------- + +dat <- list(y = y, x = x, t = t, x_lin = fx[[3]], id = id) +m <- FDboost(y ~ bbs(x, knots = 5, df = 2, differences = 0) + + # bbs(z, knots = 2, df = 2, differences = 0) + + bols(x_lin, intercept = FALSE, df = 2) + , ~ bbs(t), + id = ~ id, + offset = 0, #numInt = "Riemann", + control = boost_control(nu = 1), + data = dat) +MU <- split(mu, id) +PRED <- split(predict(m), id) +Ti <- split(t, id) +t0 <- seq(-pi, pi, length.out = 40) +MU <- do.call(cbind, Map(function(mu, t) approx(t, mu, t0)$y, + MU, Ti)) +PRED <- do.call(cbind, Map(function(mu, t) approx(t, mu, t0)$y, + PRED, Ti)) + +opar <- par(mfrow = c(2,2)) +image(t0, x, MU) +contour(t0, x, MU, add = TRUE) +image(t0, x, PRED) +contour(t0, x, PRED, add = TRUE) +persp(t0, x, MU, zlim = range(c(MU, PRED), na.rm = TRUE)) +persp(t0, x, PRED, zlim = range(c(MU, PRED), na.rm = TRUE)) +par(opar) + +# factorize model --------------------------------------------------------- + +fac <- factorize(m) + +vi <- as.data.frame(varimp(fac$cov)) +# if(require(lattice)) +# barchart(variable ~ reduction, group = blearner, vi, stack = TRUE) + +cbind(d^2, sort(vi$reduction, decreasing = TRUE)[1:3]) + + +x_plot <- list(x, x, fx[[3]]) + +cols <- c("cornflowerblue", "darkseagreen", "darkred") +opar <- par(mfrow = c(3,2)) +wch <- c(1,2,10) +for(w in seq_along(wch)) { + plot.mboost(fac$resp, which = wch[w], col = "darkgrey", ask = FALSE, + main = names(fac$resp$baselearner[wch[w]])) + lines(sort(t), ft[[w]][order(t)]*max(d), col = cols[w], lty = 2) + plot(fac$cov, which = wch[w], + main = names(fac$cov$baselearner[wch[w]])) + points(x_plot[[w]], d[w] * fx[[w]] / max(d), col = cols[w], pch = 3) +} +par(opar) + +# re-compose predictions +preds <- lapply(fac, predict) +predf <- rowSums(preds$resp * preds$cov[id, ]) +PREDf <- split(predf, id) +PREDf <- do.call(cbind, Map(function(mu, t) approx(t, mu, t0)$y, + PREDf, Ti)) +opar <- par(mfrow = c(1,2)) +image(t0,x, PRED, main = "original prediction") +contour(t0,x, PRED, add = TRUE) +image(t0,x,PREDf, main = "recomposed") +contour(t0,x, PREDf, add = TRUE) +par(opar) + +stopifnot(all.equal(PRED, PREDf)) + +# check out other methods +set.seed(8399) +newdata_resp <- list(t = sort(runif(60, min(t), max(t)))) +a <- predict(fac$resp, newdata = newdata_resp, which = 1:5) +plot(newdata_resp$t, a[, 1]) +# coef method +cf <- coef(fac$resp, which = 1) + + +# check factorization on a new dataset ------------------------------------ + +t_grid <- seq(-pi,pi,len = 30) +x_grid <- seq(0,2,len = 30) +x_lin_grid <- seq(min(dat$x_lin), max(dat$x_lin), len = 30) + +# use grid data for factorization +griddata <- expand.grid( + # time + t = t_grid, + # covariates + x = x_grid, + x_lin = 0 +) + +griddata_lin <- expand.grid( + t = seq(-pi, pi, len = 30), + x = 0, + x_lin = x_lin_grid +) + +griddata <- rbind(griddata, griddata_lin) + +griddata$id <- as.numeric(factor(paste(griddata$x, griddata$x_lin, sep = ":"))) + +fac2 <- factorize(m, newdata = griddata) + +ratio <- -max(abs(predict(fac$resp, which = 1))) / max(abs(predict(fac2$resp, which = 1))) + +opar <- par(mfrow = c(3,2)) +wch <- c(1,2,10) +for(w in seq_along(wch)) { + plot.mboost(fac$resp, which = wch[w], col = "darkgrey", ask = FALSE, + main = names(fac$resp$baselearner[wch[w]])) + + lines(sort(griddata$t), + ratio*predict(fac2$resp, which = wch[w])[order(griddata$t)], + col = cols[w], lty = 2) + plot(fac$cov, which = wch[w], + main = names(fac$cov$baselearner[wch[w]])) + this_x <- fac2$cov$model.frame(which = wch[w])[[1]][[1]] + lines(sort(this_x), 1/ratio*predict(fac2$cov, which = wch[w])[order(this_x)], + col = cols[w], lty = 1) +} +par(opar) + +# check predictions +p <- predict(fac2$resp, which = 1) diff --git a/tests/factorize_test_regular.R b/tests/factorize_test_regular.R new file mode 100644 index 0000000..a7bf644 --- /dev/null +++ b/tests/factorize_test_regular.R @@ -0,0 +1,111 @@ +library(FDboost) + +# generate regular toy data -------------------------------------------------- + +n <- 100 +m <- 40 +# covariates +x <- seq(0,2,len = n) +# time +t <- seq(-pi,pi,len = m) +# generate components +fx <- ft <- list() +fx[[1]] <- exp(x) +d <- numeric(2) +d[1] <- sqrt(c(crossprod(fx[[1]]))) +fx[[1]] <- fx[[1]] / d[1] +fx[[2]] <- -5*x^2 +fx[[2]] <- fx[[2]] - fx[[1]] * c(crossprod(fx[[1]], fx[[2]])) # orthogonalize fx[[2]] +d[2] <- sqrt(c(crossprod(fx[[2]]))) +fx[[2]] <- fx[[2]] / d[2] +ft[[1]] <- sin(t) +ft[[2]] <- cos(t) +ft[[1]] <- ft[[1]] / sqrt(sum(ft[[1]]^2)) +ft[[2]] <- ft[[2]] / sqrt(sum(ft[[2]]^2)) +mu1 <- d[1] * fx[[1]] %*% t(ft[[1]]) +mu2 <- d[2] * fx[[2]] %*% t(ft[[2]]) +# add linear covariate +ft[[3]] <- t^2 * sin(4*t) +ft[[3]] <- ft[[3]] - ft[[1]] * c(crossprod(ft[[1]], ft[[3]])) +ft[[3]] <- ft[[3]] - ft[[2]] * c(crossprod(ft[[2]], ft[[3]])) +ft[[3]] <- ft[[3]] / sqrt(sum(ft[[3]]^2)) +set.seed(9234) +fx[[3]] <- runif(0,3, n = length(x)) +fx[[3]] <- fx[[3]] - fx[[1]] * c(crossprod(fx[[1]], fx[[3]])) +fx[[3]] <- fx[[3]] - fx[[2]] * c(crossprod(fx[[2]], fx[[3]])) +d[3] <- sqrt(sum(fx[[3]]^2)) +fx[[3]] <- fx[[3]] / d[3] +mu3 <- d[3] * fx[[3]] %*% t(ft[[3]]) + +mu <- mu1 + mu2 + mu3 +# add some noise +y <- mu + rnorm(length(mu), 0, .01) +# and noise covariate +z <- rnorm(n) + +# fit FDboost model ------------------------------------------------------- + +dat <- list(y = y, x = x, t = t, x_lin = fx[[3]]) +m <- FDboost(y ~ bbs(x, knots = 5, df = 2, differences = 0) + + # bbs(z, knots = 2, df = 2, differences = 0) + + bols(x_lin, intercept = FALSE, df = 2) + , ~ bbs(t), offset = 0, + control = boost_control(nu = 1), + data = dat) + +opar <- par(mfrow = c(1,2)) +image(t, x, t(mu)) +contour(t, x, t(mu), add = TRUE) +image(t, x, t(predict(m))) +contour(t, x, t(predict(m)), add = TRUE) +par(opar) + +# factorize model --------------------------------------------------------- + +fac <- factorize(m) + +vi <- as.data.frame(varimp(fac$cov)) +# if(require(lattice)) +# barchart(variable ~ reduction, group = blearner, vi, stack = TRUE) + +cbind(d^2, vi$reduction[c(1:2, 10)]) + + +x_plot <- list(x, x, fx[[3]]) + +cols <- c("cornflowerblue", "darkseagreen", "darkred") +opar <- par(mfrow = c(3,2)) +wch <- c(1,2,10) +for(w in seq_along(wch)) { + plot.mboost(fac$resp, which = wch[w], col = "darkgrey", ask = FALSE, + main = names(fac$resp$baselearner[wch[w]])) + lines(t, ft[[w]]*max(d), col = cols[w], lty = 2) + plot(fac$cov, which = wch[w], + main = names(fac$cov$baselearner[wch[w]])) + points(x_plot[[w]], d[w] * fx[[w]] / max(d), col = cols[w], pch = 3) +} +par(opar) + +# re-compose prediction +preds <- lapply(fac, predict) +PREDSf <- array(0, dim = c(nrow(preds$resp),nrow(preds$cov))) +for(i in seq_len(ncol(preds$resp))) + PREDSf <- PREDSf + preds$resp[,i] %*% t(preds$cov[,i]) + +opar <- par(mfrow = c(1,2)) +image(t,x, t(predict(m)), main = "original prediction") +contour(t,x, t(predict(m)), add = TRUE) +image(t,x,PREDSf, main = "recomposed") +contour(t,x, PREDSf, add = TRUE) +par(opar) +# => matches +stopifnot(all.equal(as.numeric(t(predict(m))), as.numeric(PREDSf))) + +# check out other methods +set.seed(8399) +newdata_resp <- list(t = sort(runif(60, min(t), max(t)))) +a <- predict(fac$resp, newdata = newdata_resp, which = 1:5) +plot(newdata_resp$t, a[, 1]) +# coef method +cf <- coef(fac$resp, which = 1) + diff --git a/tests/general_tests.R b/tests/general_tests.R index 1080a1d..50d5fe6 100644 --- a/tests/general_tests.R +++ b/tests/general_tests.R @@ -10,10 +10,14 @@ library(gamboostLSS) if(require(refund)){ + old_mc_cores <- getOption("mc.cores") + options(mc.cores = 1L) + on.exit(options(mc.cores = old_mc_cores), add = TRUE) + ## simulate a small data set print("simulate data") set.seed(230) - pffr_data <- pffrSim(n = 25, nxgrid = 21, nygrid = 19) + pffr_data <- suppressWarnings(pffrSim(n = 25, nxgrid = 21, nygrid = 19)) pffr_data$X1 <- scale(pffr_data$X1, scale = FALSE) dat <- as.list(pffr_data) @@ -24,7 +28,7 @@ if(require(refund)){ dat$Y_long <- c(dat$Y) dat$tvals_long <- rep(dat$tvals, each = nrow(dat$Y)) - dat$id_long <- rep(1:nrow(dat$Y), ncol(dat$Y)) + dat$id_long <- rep(seq_len(nrow(dat$Y)), ncol(dat$Y)) # second functional covariate dat$s2 <- seq(0, 1, l = 15) @@ -210,4 +214,3 @@ pred <- predict(fof, newdata = fuelSubset) - diff --git a/vignettes/density-on-scalar_birth.Rnw b/vignettes/density-on-scalar_birth.Rnw index 85e5119..1bbacb6 100644 --- a/vignettes/density-on-scalar_birth.Rnw +++ b/vignettes/density-on-scalar_birth.Rnw @@ -10,6 +10,8 @@ \usepackage{authblk} \usepackage[left=25mm, right=25mm, top=20mm, bottom=20mm]{geometry} %\usepackage[nolists]{endfloat} +%\usepackage{mathspec} +\usepackage{dsfont} \usepackage{bbm} %\VignetteEngine{knitr::knitr} @@ -211,7 +213,7 @@ In the continuous case, the sum is proportional to the integral numerically, if Thus, using \texttt{bbsc} is suitable in this case, as well. Second, we must specify the B-spline basis in \texttt{bbsc} appropriately. The continuous case is straightforward, e.g., by using cubic B-splines. -In our discrete case, a suitable (unconstrained) basis is $(\mathbbm{1}_{\{1\}}, \ldots, \mathbbm{1}_{\{12\}}) \in L^2 ( \delta)^{12}$, where $\mathbbm{1}_{A}$ denotes the indicator function of $A \in \mathcal{A}$. +In our discrete case, a suitable (unconstrained) basis is $(\mathds{1}_{\{1\}}, \ldots, \mathds{1}_{\{12\}}) \in L^2 ( \delta)^{12}$, where $\mathds{1}_{A}$ denotes the indicator function of $A \in \mathcal{A}$. This results in the identity matrix as design matrix. In \texttt{bbs()} (or \texttt{bbsc()}, which yields the corresponding constrained basis), this can be achieved using \texttt{degree = 1} with knots equal to $\mathcal{T}$. @@ -233,11 +235,13 @@ model <- FDboost(birth_densities_clr ~ 1 + bolsc(sex, df = 1) + @ To determine the optimal stopping iteration we perform a $10$-fold bootstrap. -This is rather time-consuming (especially in the continuous case, when the response densities are evaluated at many grid-values) and preferably should be executed parallelized on multiple cores. +This is rather time-consuming (especially in the continuous case, when the response densities are evaluated at many grid-values) and preferably should be executed parallelized on multiple cores. In order to avoid long compilation times for the vignette, the following code is commented out, but it should be possible to obtain the same stopping iteration within a few minutes. <>= -set.seed(1708) -folds <- applyFolds(model, folds = cv(rep(1, model$ydim[1]), type = "bootstrap", B = 10)) -model <- model[mstop(folds)] # mstop(folds): 999 +# set.seed(1708) +# folds <- applyFolds(model, folds = cv(rep(1, model$ydim[1]), type = "bootstrap", B = 10)) +# ms <- mstop(folds) # = 999 +ms <- 999 +model <- model[ms] @ Our final object \texttt{model} contains the fit of model~\eqref{model_clr}, i.e., on clr-level. diff --git a/vignettes/density-on-scalar_birth.pdf b/vignettes/density-on-scalar_birth.pdf index 6d9bfc2..fe37e55 100644 Binary files a/vignettes/density-on-scalar_birth.pdf and b/vignettes/density-on-scalar_birth.pdf differ