├── .Rbuildignore ├── .gitattributes ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── Makefile ├── NAMESPACE ├── R ├── by-variable-utilities.R ├── confint-methods.R ├── datagen-methods.R ├── datasets.R ├── draw-methods.R ├── evaluate_smooth.R ├── fderiv.R ├── other-scam-methods.R ├── simulate-methods.R └── utililties.R ├── README.md ├── appveyor.yml ├── data └── smallAges.rda ├── man ├── coef.scam.Rd ├── confint.fderiv.Rd ├── confint.gam.Rd ├── datagen.Rd ├── draw.Rd ├── draw.evaluated_smooth.Rd ├── draw.gam.Rd ├── evaluate_smooth.Rd ├── fderiv.Rd ├── fix_offset.Rd ├── is_by_smooth.Rd ├── is_offset.Rd ├── simulate.Rd ├── smallAges.Rd └── smooth_dim.Rd └── tests ├── Examples └── schoenberg-Ex.Rout.save ├── figs ├── deps.txt ├── draw-methods │ ├── draw-1d-smooth-for-selected-smooth.svg │ ├── draw-2d-smooth.svg │ ├── draw-am-with-2d-smooth.svg │ ├── draw-am-with-continuous-by-var-fixed-scale.svg │ ├── draw-am-with-continuous-by-variable-smooth.svg │ ├── draw-am-with-factor-by-variable-smooth-with-fixed-scales.svg │ ├── draw-am-with-factor-by-variable-smooth.svg │ ├── draw-evaluated-re-smooth.svg │ ├── draw-gam-model-with-ranef-smooth-factor-by-fixed-scales.svg │ ├── draw-gam-model-with-ranef-smooth-factor-by.svg │ ├── draw-gam-model-with-ranef-smooth-fixed-scales.svg │ ├── draw-gam-model-with-ranef-smooth.svg │ ├── draw-simple-multi-smooth-am-with-fixed-scales.svg │ ├── draw-simple-multi-smooth-am.svg │ └── draw-std-error-of-2d-smooth.svg └── test-by-variables │ └── continuous-by-variable-smmoth.svg ├── test-all.R └── testthat ├── test-by-variables.R ├── test-confint-methods.R ├── test-draw-methods.R ├── test-fderiv.R ├── test-other-scam-methods.R ├── test-simulate-methods.R └── test-utilities.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\.travis\.yml$ 2 | ^LICENSE\.md$ 3 | \.Rproj$ 4 | ^\.Rproj\.user$ 5 | Makefile 6 | appveyor.yml 7 | .gitattributes 8 | .gitignore 9 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | * text=auto 2 | data/* binary 3 | src/* text=lf 4 | R/* text=lf 5 | 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | .Rapp.history 4 | 5 | # Example code in package build process 6 | *-Ex.R 7 | 8 | # RStudio files 9 | .Rproj.user/ 10 | 11 | # produced vignettes 12 | vignettes/*.html 13 | vignettes/*.pdf 14 | 15 | # no backup files 16 | *~ -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | cache: packages 3 | 4 | r: 5 | - release 6 | - devel 7 | 8 | sudo: false 9 | 10 | addons: 11 | apt: 12 | packages: 13 | - qpdf 14 | 15 | r_packages: 16 | - mgcv 17 | - testthat 18 | - ggplot2 19 | - cowplot 20 | - vdiffr 21 | - scam 22 | - MASS 23 | 24 | r_github_packages: 25 | - r-lib/covr 26 | 27 | after_success: 28 | - Rscript -e 'covr::codecov()' 29 | 30 | r_build_args: " --compact-vignettes=gs+qpdf" 31 | 32 | notifications: 33 | email: 34 | on_success: change 35 | on_failure: always 36 | 37 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: schoenberg 2 | Version: 0.0-6 3 | Date: 2018-04-08 4 | Title: Ggplot-based graphics and other useful functions for GAMs fitted using mgcv 5 | Authors@R: c(person(given = "Gavin L.", family = "Simpson", 6 | email = "ucfagls@gmail.com", 7 | role = c("aut","cre"))) 8 | Maintainer: Gavin L. Simpson 9 | Imports: 10 | mgcv, 11 | ggplot2, 12 | cowplot, 13 | grid, 14 | MASS, 15 | stats 16 | Suggests: 17 | testthat, 18 | vdiffr, 19 | scam 20 | Description: Ggplot-based graphics and utility functions for working with GAMs fitted using the mgcv package. 21 | License: MIT + file LICENSE 22 | LazyData: true 23 | URL: https://github.com/gavinsimpson/schoenberg 24 | BugReports: https://github.com/gavinsimpson/schoenberg/issues 25 | Roxygen: list(markdown = TRUE) 26 | RoxygenNote: 6.0.1 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2013-2018 2 | COPYRIGHT HOLDER: Gavin L. Simpson 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | ===================== 3 | 4 | Copyright (c) `2013-2017` `Gavin L. Simpson` 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy of 7 | this software and associated documentation files (the "Software"), to deal in 8 | the Software without restriction, including without limitation the rights to 9 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 10 | the Software, and to permit persons to whom the Software is furnished to do so, 11 | subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 18 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 19 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 20 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 21 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Get the version info for later 2 | PKGVERS := $(shell sed -n "s/Version: *\([^ ]*\)/\1/p" DESCRIPTION) 3 | 4 | all: docs check clean 5 | 6 | docs: 7 | R -q -e 'library("roxygen2"); roxygenise(".")' 8 | 9 | build: docs 10 | cd ..;\ 11 | R CMD build schoenberg 12 | 13 | check: build 14 | cd ..;\ 15 | R CMD check schoenberg_$(PKGVERS).tar.gz 16 | 17 | check-cran: build 18 | cd ..;\ 19 | R CMD check --as-cran schoenberg_$(PKGVERS).tar.gz 20 | 21 | install: build 22 | cd ..;\ 23 | R CMD INSTALL schoenberg_$(PKGVERS).tar.gz 24 | 25 | move: check 26 | cp ../schoenberg.Rcheck/schoenberg-Ex.Rout ./tests/Examples/schoenberg-Ex.Rout.save 27 | 28 | clean: 29 | cd ..;\ 30 | rm -r schoenberg.Rcheck/ 31 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(coef,scam) 4 | S3method(confint,fderiv) 5 | S3method(confint,gam) 6 | S3method(confint,gamm) 7 | S3method(datagen,gam) 8 | S3method(datagen,gamm) 9 | S3method(datagen,mgcv.smooth) 10 | S3method(draw,evaluated_1d_smooth) 11 | S3method(draw,evaluated_2d_smooth) 12 | S3method(draw,evaluated_re_smooth) 13 | S3method(draw,gam) 14 | S3method(evaluate_smooth,gam) 15 | S3method(evaluate_smooth,gamm) 16 | S3method(fderiv,gam) 17 | S3method(fderiv,gamm) 18 | S3method(simulate,gam) 19 | S3method(simulate,gamm) 20 | S3method(simulate,scam) 21 | S3method(smooth_dim,gam) 22 | S3method(smooth_dim,gamm) 23 | S3method(smooth_dim,mgcv.smooth) 24 | S3method(vcov,scam) 25 | export(by_level) 26 | export(by_variable) 27 | export(datagen) 28 | export(draw) 29 | export(evaluate_smooth) 30 | export(fderiv) 31 | export(fix_offset) 32 | export(is_by_smooth) 33 | export(is_continuous_by_smooth) 34 | export(is_factor_by_smooth) 35 | export(is_offset) 36 | export(smooth_dim) 37 | importFrom(MASS,mvrnorm) 38 | importFrom(cowplot,plot_grid) 39 | importFrom(ggplot2,aes_string) 40 | importFrom(ggplot2,geom_abline) 41 | importFrom(ggplot2,geom_contour) 42 | importFrom(ggplot2,geom_line) 43 | importFrom(ggplot2,geom_point) 44 | importFrom(ggplot2,geom_raster) 45 | importFrom(ggplot2,geom_ribbon) 46 | importFrom(ggplot2,ggplot) 47 | importFrom(ggplot2,guide_colourbar) 48 | importFrom(ggplot2,guides) 49 | importFrom(ggplot2,labs) 50 | importFrom(ggplot2,lims) 51 | importFrom(ggplot2,scale_fill_distiller) 52 | importFrom(ggplot2,theme) 53 | importFrom(grid,unit) 54 | importFrom(mgcv,PredictMat) 55 | importFrom(mgcv,exclude.too.far) 56 | importFrom(stats,coef) 57 | importFrom(stats,confint) 58 | importFrom(stats,family) 59 | importFrom(stats,model.frame) 60 | importFrom(stats,predict) 61 | importFrom(stats,qnorm) 62 | importFrom(stats,quantile) 63 | importFrom(stats,runif) 64 | importFrom(stats,setNames) 65 | importFrom(stats,simulate) 66 | importFrom(stats,terms) 67 | importFrom(stats,vcov) 68 | -------------------------------------------------------------------------------- /R/by-variable-utilities.R: -------------------------------------------------------------------------------- 1 | ##' Tests for by variable smooths 2 | ##' 3 | ##' Functions to check if a smooth is a by-variable one and to test of the type 4 | ##' of by-variable smooth is a factor-smooth or a continous-smooth interaction. 5 | ##' 6 | ##' @param smooth an object of class `"mgcv.smooth"` 7 | ##' 8 | ##' @return A logical vector. 9 | ##' 10 | ##' @author Gavin L. Simpson 11 | ##' 12 | ##' @export 13 | ##' @rdname is_by_smooth 14 | `is_by_smooth` <- function(smooth) { 15 | check_is_mgcv_smooth(smooth) 16 | is_factor_by_smooth(smooth) | is_continuous_by_smooth(smooth) 17 | } 18 | 19 | ##' @export 20 | ##' @rdname is_by_smooth 21 | `is_factor_by_smooth` <- function(smooth) { 22 | check_is_mgcv_smooth(smooth) 23 | by.level <- smooth[["by.level"]] 24 | !is.null(by.level) 25 | } 26 | 27 | ##' @export 28 | ##' @rdname is_by_smooth 29 | `is_continuous_by_smooth` <- function(smooth) { 30 | check_is_mgcv_smooth(smooth) 31 | by.level <- by_level(smooth) 32 | by.var <- by_variable(smooth) 33 | !(is.null(by.level) & by.var == "NA") 34 | } 35 | 36 | ##' @export 37 | ##' @rdname is_by_smooth 38 | `by_variable` <- function(smooth) { 39 | check_is_mgcv_smooth(smooth) 40 | as.character(smooth[["by"]]) 41 | } 42 | 43 | ##' @export 44 | ##' @rdname is_by_smooth 45 | `by_level` <- function(smooth) { 46 | check_is_mgcv_smooth(smooth) 47 | smooth[["by.level"]] 48 | } 49 | -------------------------------------------------------------------------------- /R/confint-methods.R: -------------------------------------------------------------------------------- 1 | ##' Point-wise and simultaneous confidence intervals for derivatives of smooths 2 | ##' 3 | ##' Calculates point-wise confidence or simultaneous intervals for the first derivatives of smooth terms in a fitted GAM. 4 | ##' 5 | ##' @param object an object of class `"fderiv"` containing the estimated derivatives. 6 | ##' @param parm which parameters (smooth terms) are to be given intervals as a vector of terms. If missing, all parameters are considered. 7 | ##' @param level numeric, `0 < level < 1`; the confidence level of the point-wise or simultaneous interval. The default is `0.95` for a 95\% interval. 8 | ##' @param type character; the type of interval to compute. One of `"confidence"` for point-wise intervals, or `"simultaneous"` for simultaneous intervals. 9 | ##' @param nsim integer; the number of simulations used in computing the simultaneous intervals. 10 | ##' @param ... additional arguments for methods 11 | ##' 12 | ##' @return a data frame with components: 13 | ##' 1. `term`; factor indicating to which term each row relates, 14 | ##' 2. `lower`; lower limit of the confidence or simultaneous interval, 15 | ##' 3. `est`; estimated derivative 16 | ##' 4. `upper`; upper limit of the confidence or simultaneous interval. 17 | ##' 18 | ##' @author Gavin L. Simpson 19 | ##' 20 | ##' @export 21 | ##' 22 | ##' @examples 23 | ##' library("mgcv") 24 | ##' set.seed(2) 25 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 26 | ##' mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 27 | ##' 28 | ##' ## first derivatives of all smooths... 29 | ##' fd <- fderiv(mod) 30 | ##' 31 | ##' ## point-wise interval 32 | ##' ci <- confint(fd, type = "confidence") 33 | ##' head(ci) 34 | ##' 35 | ##' ## simultaneous interval for smooth term of x1 36 | ##' set.seed(42) 37 | ##' x1.sint <- confint(fd, parm = "x1", type = "simultaneous", nsim = 1000) 38 | ##' head(x1.sint) 39 | `confint.fderiv` <- function(object, parm, level = 0.95, 40 | type = c("confidence", "simultaneous"), nsim = 10000, ...) { 41 | ## Process arguments 42 | ## parm is one of the terms in object 43 | parm <- if(missing(parm)) { 44 | object$terms 45 | } else { 46 | parm <- add_s(parm) 47 | terms <- object$terms 48 | want <- parm %in% terms 49 | if (any(!want)) { 50 | msg <- paste("Terms:", paste(parm[!want], collapse = ", "), 51 | "not found in `object`") 52 | stop(msg) 53 | } 54 | parm[want] 55 | } 56 | ## parm <- add_s(parm) 57 | 58 | ## level should be length 1, numeric and 0 < level < 1 59 | if ((ll <- length(level)) > 1L) { 60 | warning(paste("`level` should be length 1, but supplied length: ", 61 | ll, ". Using the first only.")) 62 | level <- rep(level, length.out = 1L) 63 | } 64 | if (!is.numeric(level)) { 65 | stop(paste("`level` should be numeric, but supplied:", level)) 66 | } 67 | if (! (0 < level) && (level < 1)) { 68 | stop(paste("`level` should lie in interval [0,1], but supplied:", level)) 69 | } 70 | 71 | ## which type of interval is required 72 | type <- match.arg(type) 73 | 74 | ## generate intervals 75 | interval <- if (type == "confidence") { 76 | confidence(object, terms = parm, level = level) 77 | } else { 78 | simultaneous(object, terms = parm, level = level, nsim = nsim) 79 | } 80 | 81 | class(interval) <- c("confint.fderiv", "data.frame") 82 | 83 | ## return 84 | interval 85 | } 86 | 87 | ##' @importFrom stats quantile vcov 88 | ##' @importFrom MASS mvrnorm 89 | `simultaneous` <- function(x, terms, level, nsim) { 90 | ## wrapper the computes each interval 91 | `simInt` <- function(x, Vb, bu, level, nsim) { 92 | Xi <- x[["Xi"]] # derivative Lp, zeroed except for this term 93 | se <- x[["se.deriv"]] # std err of deriv for current term 94 | d <- x[["deriv"]] # deriv for current term 95 | simDev <- Xi %*% t(bu) # simulate deviations from expected 96 | absDev <- abs(sweep(simDev, 1, se, FUN = "/")) # absolute deviations 97 | masd <- apply(absDev, 2L, max) # & maxabs deviation per sim 98 | ## simultaneous interval critical value 99 | crit <- quantile(masd, prob = level, type = 8) 100 | ## return as data frame 101 | data.frame(lower = d - (crit * se), est = d, upper = d + (crit * se)) 102 | } 103 | 104 | ## bayesian covar matrix, possibly accounting for estimating smooth pars 105 | Vb <- vcov(x[["model"]], unconditional = x$unconditional) 106 | ## simulate un-biased deviations given bayesian covar matrix 107 | buDiff <- MASS::mvrnorm(n = nsim, mu = rep(0, nrow(Vb)), Sigma = Vb) 108 | ## apply wrapper to compute simultaneous interval critical value and 109 | ## corresponding simultaneous interval for each term 110 | res <- lapply(x[["derivatives"]][terms], FUN = simInt, 111 | Vb = Vb, bu = buDiff, level = level, nsim = nsim) 112 | ## how many values per term - currently all equal 113 | lens <- vapply(res, FUN = NROW, FUN.VALUE = integer(1)) 114 | res <- do.call("rbind", res) # row-bind each component of res 115 | res <- cbind(term = rep(terms, times = lens), res) # add on term ID 116 | rownames(res) <- NULL # tidy up 117 | res # return 118 | } 119 | 120 | ##' @importFrom stats qnorm 121 | `confidence` <- function(x, terms, level) { 122 | ## wrapper the computes each interval 123 | `confInt` <- function(x, level) { 124 | se <- x[["se.deriv"]] # std err of deriv for current term 125 | d <- x[["deriv"]] # deriv for current term 126 | ## confidence interval critical value 127 | crit <- qnorm(1 - ((1 - level) / 2)) 128 | ## return as data frame 129 | data.frame(lower = d - (crit * se), est = d, upper = d + (crit * se)) 130 | } 131 | 132 | ## apply wrapper to compute confidence interval critical value and 133 | ## corresponding confidence interval for each term 134 | res <- lapply(x[["derivatives"]][terms], FUN = confInt, level = level) 135 | ## how many values per term - currently all equal 136 | lens <- vapply(res, FUN = NROW, FUN.VALUE = integer(1)) 137 | res <- do.call("rbind", res) # row-bind each component of res 138 | res <- cbind(term = rep(terms, times = lens), res) # add on term ID 139 | rownames(res) <- NULL # tidy up 140 | res # return 141 | } 142 | 143 | ##' Point-wise and simultaneous confidence intervals for smooths 144 | ##' 145 | ##' Calculates point-wise confidence or simultaneous intervals for the smooth terms of a fitted GAM. 146 | ##' 147 | ##' @param object an object of class `"gam"` or `"gamm"`. 148 | ##' @param parm which parameters (smooth terms) are to be given intervals as a vector of terms. If missing, all parameters are considered, although this is not currently implemented. 149 | ##' @param level numeric, `0 < level < 1`; the confidence level of the point-wise or simultaneous interval. The default is `0.95` for a 95\% interval. 150 | ##' @param newdata data frame; containing new values of the covariates used in the model fit. The selected smooth(s) wil be evaluated at the supplied values. 151 | ##' @param n numeric; the number of points to evaluate smooths at. 152 | ##' @param type character; the type of interval to compute. One of `"confidence"` for point-wise intervals, or `"simultaneous"` for simultaneous intervals. 153 | ##' @param nsim integer; the number of simulations used in computing the simultaneous intervals. 154 | ##' @param shift logical; should the constant term be add to the smooth? 155 | ##' @param transform logical; should the smooth be evaluated on a transformed scale? For generalised models, this involves applying the inverse of the link function used to fit the model. Alternatively, the name of, or an actual, function can be supplied to transform the smooth and it's confidence interval. 156 | ##' @param unconditional logical; if `TRUE` (and `freq == FALSE`) then the Bayesian smoothing parameter uncertainty corrected covariance matrix is returned, if available. 157 | ##' @param ... additional arguments for methods 158 | ##' 159 | ##' @return a data frame with components: 160 | ##' 1. `term`; factor indicating to which term each row relates, 161 | ##' 2. `x`; the vector of values at which the smooth was evaluated, 162 | ##' 3. `lower`; lower limit of the confidence or simultaneous interval, 163 | ##' 4. `est`; estimated value of the smooth 164 | ##' 5. `upper`; upper limit of the confidence or simultaneous interval, 165 | ##' 6. `crit`; critical value for the `100 * level`% confidence interval. 166 | ##' 167 | ##' @author Gavin L. Simpson 168 | ##' 169 | ##' @importFrom stats family qnorm 170 | ##' @importFrom mgcv PredictMat 171 | ##' @importFrom stats quantile vcov setNames 172 | ##' @importFrom MASS mvrnorm 173 | ##' 174 | ##' @export 175 | ##' 176 | ##' @examples 177 | ##' library("mgcv") 178 | ##' set.seed(2) 179 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 180 | ##' mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 181 | ##' ##' 182 | ##' ## point-wise interval 183 | ##' ci <- confint(mod, parm = "x1", type = "confidence") 184 | ##' head(ci) 185 | ##' ##' 186 | ##' ## simultaneous interval for smooth term of x1 187 | ##' set.seed(42) 188 | ##' si <- confint(mod, parm = "x1", type = "simultaneous", nsim = 100) 189 | ##' head(si) 190 | `confint.gam` <- function(object, parm, level = 0.95, newdata = NULL, n = 200, 191 | type = c("confidence", "simultaneous"), nsim = 10000, 192 | shift = FALSE, transform = FALSE, unconditional = FALSE, 193 | ...) { 194 | parm <- add_s(parm) 195 | ## parm <- select_smooth(object, parm) # select_terms(object, parm) 196 | S <- smooths(object) # vector of smooth labels - "s(x)" 197 | 198 | ## which --- ie index --- smooths match parm 199 | take <- which_smooth(object, parm) 200 | S <- S[take] 201 | 202 | ## can only do confints for 1d smooths currently --- get smooth dimensions & prune list `S` 203 | d <- smooth_dim(object)[take] 204 | S <- S[d <= 1L] 205 | 206 | ## look to see if smooth is a by variable 207 | by_levs <- NULL 208 | is_by <- vapply(object[["smooth"]][take], is_by_smooth, logical(1L)) 209 | if (any(is_by)) { 210 | S <- vapply(strsplit(S, ":"), `[[`, character(1L), 1L) 211 | by_levs <- vapply(object[["smooth"]][take], by_level, character(1L)) 212 | by_var <- vapply(object[["smooth"]][take], by_variable, character(1L)) 213 | } 214 | ## unique smooths (counts all levels of a by factor as a single smooth) 215 | uS <- unique(S) 216 | 217 | ## how many data points if newdata supplied 218 | if (!is.null(newdata)) { 219 | n <- NROW(newdata) 220 | } 221 | 222 | ilink <- if (is.logical(transform)) { # transform is logical 223 | if (isTRUE(transform)) { # transform == TRUE 224 | family(object)$linkinv 225 | } else { # transform == FALSE 226 | function(eta) { eta } 227 | } 228 | } else if (!is.null(transform)) { # transform is a fun 229 | match.fun(transform) 230 | } 231 | 232 | ## which type of confidence interval 233 | type <- match.arg(type) 234 | if (isTRUE(type == "simultaneous")) { 235 | ## need VCOV for simultaneous intervals 236 | V <- get_vcov(object, unconditional = unconditional) 237 | 238 | ## simulate un-biased deviations given bayesian covar matrix 239 | buDiff <- MASS::mvrnorm(n = nsim, mu = rep(0, nrow(V)), Sigma = V) 240 | } 241 | ## list to hold results 242 | out <- vector("list", length = length(uS)) # list for results 243 | 244 | if (isTRUE(type == "confidence")) { 245 | for (i in seq_along(out)) { 246 | out[[i]] <- evaluate_smooth(object, uS[i], n = n, newdata = newdata) 247 | out[[i]][["crit"]] <- qnorm((1 - level) / 2, lower.tail = FALSE) 248 | } 249 | } else { 250 | ## function to do simultaneous intervals for a smooth 251 | ## this should be outlined as an actual function... 252 | ## @param smooth list; the individual smooth to work on 253 | ## @param level numeric; the confidence level 254 | ## @param newdata dataframe; values to compute confidence interval at 255 | sim_interval <- function(smooth, level, newdata) { 256 | start <- smooth[["first.para"]] 257 | end <- smooth[["last.para"]] 258 | para.seq <- start:end 259 | Cg <- PredictMat(smooth, newdata) 260 | simDev <- Cg %*% t(buDiff[, para.seq]) 261 | absDev <- abs(sweep(simDev, 1L, newdata[["se"]], FUN = "/")) 262 | masd <- apply(absDev, 2L, max) 263 | quantile(masd, probs = level, type = 8) 264 | } 265 | ## need VCOV for simultaneous intervals 266 | V <- get_vcov(object, unconditional = unconditional) 267 | ## simulate un-biased deviations given bayesian covar matrix 268 | buDiff <- MASS::mvrnorm(n = nsim, mu = rep(0, nrow(V)), Sigma = V) 269 | ## loop over smooths 270 | for (i in seq_along(out)) { 271 | ## evaluate smooth 272 | out[[i]] <- evaluate_smooth(object, uS[i], n = n, newdata = newdata) 273 | 274 | ## if this is a by var smooth, we need to do this for each level of by var 275 | if (is.null(by_levs)) { # not by variable smooth 276 | smooth <- get_smooth(object, parm) # get the specific smooth 277 | crit <- sim_interval(smooth, level = level, newdata = out[[i]]) 278 | out[[i]][["crit"]] <- crit # add on the critical value for this smooth 279 | } else { # is a by variable smooth 280 | out[[i]][["crit"]] <- 0 # fill in a variable crit 281 | smooth <- get_smooth(object, parm) 282 | for (l in seq_along(by_levs)) { 283 | ind <- out[[i]][[5L]] == by_levs[l] # which rows in evaulated smooth contain this levels data? 284 | crit <- sim_interval(smooth[[l]], level = level, newdata = out[[i]][ind, ]) 285 | out[[i]][["crit"]][ind] <- crit # add on the critical value for this smooth 286 | } 287 | } 288 | } 289 | } 290 | 291 | const <- coef(object) 292 | nms <- names(const) 293 | test <- grep("Intercept", nms) 294 | const <- ifelse(length(test) == 0L, 0, const[test]) 295 | 296 | ## simplify to a data frame for return 297 | out <- do.call("rbind", out) 298 | 299 | ## using se and crit, compute the lower and upper intervals 300 | out <- cbind(out, 301 | lower = out[["est"]] - (out[["crit"]] * out[["se"]]), 302 | upper = out[["est"]] + (out[["crit"]] * out[["se"]])) 303 | 304 | ## transform 305 | out[, "est"] <- ilink(out[, "est"] + const) 306 | out[, "lower"] <- ilink(out[, "lower"] + const) 307 | out[, "upper"] <- ilink(out[, "upper"] + const) 308 | 309 | ## prepare for return 310 | class(out) <- c("confint.gam", "data.frame") 311 | out # return 312 | } 313 | 314 | ##' @rdname confint.gam 315 | ##' 316 | ##' @importFrom stats confint 317 | ##' 318 | ##' @export 319 | `confint.gamm` <- function(object, ...) { 320 | confint(object[["gam"]], ...) 321 | } 322 | -------------------------------------------------------------------------------- /R/datagen-methods.R: -------------------------------------------------------------------------------- 1 | ##' Generate data over the range of variables used in smooths 2 | ##' 3 | ##' For each smooth in a GAM, generate new data over the range of the variables in volved in a smooth. 4 | ##' 5 | ##' @param x an object for which new data is required. Currently objects of classes `"gam"`, and `"gamm"` are supported, as are smooths from **mgcv** inheriting from class `"mgcv.smooth"`. 6 | ##' @param n numeric; the number of data values to generate per term in each smooth. 7 | ##' @param data data frame; for `"mgcv.smooth"` objects, the data used to fit the GAM need to be supplied. 8 | ##' @param ... arguments passed to methods 9 | ##' @return A data frame of new values spread over the range of the observed values. 10 | ##' 11 | ##' @author Gavin L. Simpson 12 | ##' 13 | ##' @export 14 | ##' @rdname datagen 15 | ##' 16 | ##' @examples 17 | ##' library("mgcv") 18 | ##' 19 | ##' ## 1d example 20 | ##' set.seed(2) 21 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 22 | ##' m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 23 | ##' df <- datagen(m1) 24 | ##' head(df) 25 | ##' 26 | ##' ## 2d example 27 | ##' dat <- gamSim(2, n = 400, dist = "normal", scale = 2) 28 | ##' m2 <- gam(y ~ s(x, z), data = dat$data, method = "REML") 29 | ##' df <- datagen(m2) 30 | ##' head(df) 31 | ##' ## alternative showing using the mgcv.smooth method for a single smooth 32 | ##' df2 <- datagen(m2[["smooth"]][[1L]], data = dat$data) 33 | ##' head(df2) 34 | `datagen` <- function(x, ...) { 35 | UseMethod("datagen") 36 | } 37 | 38 | ##' @export 39 | ##' @rdname datagen 40 | `datagen.mgcv.smooth` <- function(x, n = 100, data, ...) { 41 | d <- smooth_dim(x) # how many dimensions in smooth 42 | term <- smooth_terms(x) # what term are we dealing with 43 | 44 | ## some smooths can't be plotted, esp n-d ones where n > 2 45 | if (!x$plot.me || d > 2L) { 46 | out <- data.frame() # FIXME: or should we throw error/message 47 | } 48 | 49 | if (d == 1L) { # 1-d smooths 50 | xvals <- data[[term]] 51 | newvals <- seq(min(xvals), max(xvals), length.out = n) 52 | out <- data.frame(term = rep(smooth_label(x), n), x = newvals) 53 | } else { # 2-d smooths 54 | xvals <- data[[term[1]]] 55 | zvals <- data[[term[2]]] 56 | newx <- seq(min(xvals), max(xvals), length.out = n) 57 | newz <- seq(min(zvals), max(zvals), length.out = n) 58 | out <- expand.grid(x1 = newx, x2 = newz) 59 | out <- cbind(smooth = rep(smooth_label(x), n^2), out) 60 | } 61 | 62 | ## return 63 | out 64 | } 65 | 66 | ##' @export 67 | ##' @rdname datagen 68 | `datagen.gam` <- function(x, n = 200, ...) { 69 | out <- lapply(x[["smooth"]], datagen, n = n, data = x[["model"]]) 70 | do.call("rbind", out) # FIXME: this can't possibly be right for multiple smooths 71 | } 72 | 73 | ##' @export 74 | ##' @rdname datagen 75 | `datagen.gamm` <- function(x, ...) { 76 | datagen(x[["gam"]]) 77 | } 78 | -------------------------------------------------------------------------------- /R/datasets.R: -------------------------------------------------------------------------------- 1 | ##' Lead-210 age-depth measurements for Small Water 2 | ##' 3 | ##' A dataset containing lead-210 based age depth measurements for the SMALL1 4 | ##' core from Small Water. 5 | ##' 6 | ##' The variables are as follows: 7 | ##' 8 | ##' * `Depth` 9 | ##' * `Drymass` 10 | ##' * `Date` 11 | ##' * `Age` 12 | ##' * `Error` 13 | ##' * `SedAccRate` 14 | ##' * `SedPerCentChange` 15 | ##' 16 | ##' @format A data frame with 12 rows and 7 variables. 17 | ##' @keywords data 18 | ##' @name smallAges 19 | ##' @docType data 20 | NULL 21 | -------------------------------------------------------------------------------- /R/draw-methods.R: -------------------------------------------------------------------------------- 1 | ##' Generic plotting via `ggplot2` 2 | ##' 3 | ##' Generic function for plotting of R objects that uses the `ggplot2` package. 4 | ##' 5 | ##' @title Generic plotting via `ggplot2` 6 | ##' @param object and R object to plot. 7 | ##' @param ... arguments passed to other methods. 8 | ##' 9 | ##' @return A [ggplot2::ggplot()] object. 10 | ##' 11 | ##' @author Gavin L. Simpson 12 | ##' 13 | ##' @export 14 | `draw` <- function(object, ...) { 15 | UseMethod("draw") 16 | } 17 | 18 | ##' Plot estimated smooths 19 | ##' 20 | ##' Plots estimated univariate and bivariate smooths using ggplot2. 21 | ##' 22 | ##' @param object an object, the result of a call to [evaluate_smooth()]. 23 | ##' @param xlab character or expression; the label for the x axis. If not 24 | ##' supplied, a suitable label will be generated from `object`. 25 | ##' @param ylab character or expression; the label for the y axis. If not 26 | ##' supplied, a suitable label will be generated from `object`. 27 | ##' @param title character or expression; the title for the plot. See 28 | ##' [ggplot2::labs()]. 29 | ##' @param subtitle character or expression; the subtitle for the plot. See 30 | ##' [ggplot2::labs()]. 31 | ##' @param caption character or expression; the plot caption. See 32 | ##' [ggplot2::labs()]. 33 | ##' @param ... arguments passed to other methods. 34 | ##' 35 | ##' @return A [ggplot2::ggplot()] object. 36 | ##' 37 | ##' @author Gavin L. Simpson 38 | ##' 39 | ##' @importFrom ggplot2 ggplot aes_string labs geom_line geom_ribbon 40 | ##' @importFrom grid unit 41 | ##' 42 | ##' @export 43 | ##' @name draw.evaluated_smooth 44 | ##' @aliases draw.evaluated_1d_smooth draw.evaluated_2d_smooth 45 | ##' 46 | ##' @examples 47 | ##' library("mgcv") 48 | ##' 49 | ##' set.seed(2) 50 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 51 | ##' m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 52 | ##' 53 | ##' sm <- evaluate_smooth(m1, "s(x2)") 54 | ##' draw(sm) 55 | ##' 56 | ##' set.seed(2) 57 | ##' dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 58 | ##' m2 <- gam(y ~ s(x, z, k = 40), data = dat$data, method = "REML") 59 | ##' 60 | ##' sm <- evaluate_smooth(m2, "s(x,z)", n = 100) 61 | ##' draw(sm) 62 | ##' 63 | ##' ## now the standard error the smooth instead 64 | ##' draw(sm, show = "se") 65 | `draw.evaluated_1d_smooth` <- function(object, 66 | xlab, ylab, 67 | title = NULL, subtitle = NULL, 68 | caption = NULL, 69 | ...) { 70 | smooth_var <- names(object)[2L] 71 | 72 | ## Add confidence interval 73 | object[["upper"]] <- object[["est"]] + (2 * object[["se"]]) 74 | object[["lower"]] <- object[["est"]] - (2 * object[["se"]]) 75 | 76 | plt <- ggplot(object, aes_string(x = smooth_var, y = "est")) + 77 | geom_ribbon(mapping = aes_string(ymin = "lower", 78 | ymax = "upper"), 79 | alpha = 0.2) + 80 | geom_line() 81 | 82 | ## default axis labels if none supplied 83 | if (missing(xlab)) { 84 | xlab <- smooth_var 85 | } 86 | if (missing(ylab)) { 87 | ylab <- levels(object[["smooth"]]) 88 | } 89 | 90 | ## add labelling to plot 91 | plt <- plt + labs(x = xlab, y = ylab, title = title, subtitle = subtitle, 92 | caption = caption) 93 | 94 | plt 95 | } 96 | 97 | ##' @param show character; plot the estimated smooth (`"estimate"`) or its 98 | ##' standard error (`"se"`). 99 | ##' @param contour logical; should contours be draw on the plot using 100 | ##' [ggplot2::geom_contour()]. 101 | ##' 102 | ##' @importFrom ggplot2 ggplot aes_string geom_raster geom_contour labs guides guide_colourbar scale_fill_distiller theme 103 | ##' @importFrom grid unit 104 | ##' 105 | ##' @export 106 | ##' @rdname draw.evaluated_smooth 107 | `draw.evaluated_2d_smooth` <- function(object, show = c("estimate","se"), 108 | contour = TRUE, 109 | xlab, ylab, 110 | title = NULL, subtitle = NULL, 111 | caption = NULL, 112 | ...) { 113 | smooth_vars <- names(object)[2:3] 114 | show <- match.arg(show) 115 | if (isTRUE(identical(show, "estimate"))) { 116 | guide_title <- levels(object[["smooth"]]) 117 | plot_var <- "est" 118 | guide_limits <- c(-1, 1) * max(abs(object[[plot_var]])) 119 | } else { 120 | guide_title <- bquote(SE * (.(levels(object[["smooth"]])))) 121 | plot_var <- "se" 122 | guide_limits <- range(object[["se"]]) 123 | } 124 | 125 | plt <- ggplot(object, aes_string(x = smooth_vars[1], y = smooth_vars[2])) + 126 | geom_raster(mapping = aes_string(fill = plot_var)) 127 | 128 | if (isTRUE(contour)) { 129 | plt <- plt + geom_contour(mapping = aes_string(z = plot_var)) 130 | } 131 | 132 | ## default axis labels if none supplied 133 | if (missing(xlab)) { 134 | xlab <- smooth_vars[1L] 135 | } 136 | if (missing(ylab)) { 137 | ylab <- smooth_vars[2L] 138 | } 139 | 140 | ## add labelling to plot 141 | plt <- plt + labs(x = xlab, y = ylab, title = title, subtitle = subtitle, 142 | caption = caption) 143 | 144 | ## Set the palette 145 | plt <- plt + scale_fill_distiller(palette = "RdBu", type = "div", 146 | limits = guide_limits) 147 | 148 | ## add guide 149 | plt <- plt + guides(fill = guide_colourbar(title = guide_title, 150 | direction = "horizontal", 151 | barwidth = grid::unit(0.5, "npc"))) 152 | 153 | ## position legend at the 154 | plt <- plt + theme(legend.position = "top") 155 | 156 | plt 157 | } 158 | 159 | ##' Plot estimated smooths from a fitted GAM 160 | ##' 161 | ##' Plots estimated smooths from a fitted GAM model in a similar way to 162 | ##' `mgcv::plot.gam()` but instead of using base graphics, [ggplot2::ggplot()] 163 | ##' is used instead. 164 | ##' 165 | ##' @param object a fitted GAM, the result of a call to [mgcv::gam()]. 166 | ##' @param select character; 167 | ##' @param scales character; should all univariate smooths be plotted with the 168 | ##' same y-axis scale? The default, `scales = "fixed"`, ensures this is done. 169 | ##' If `scales = "free"` each univariate smooth has its own y-axis scale. 170 | ##' @param align characer; see argument `align` in `cowplot::plot_grid()`. 171 | ##' Defaults to `"hv"` so that plots are nicely aligned. 172 | ##' @param ... arguments passed to `cowplot::plot_grid()`. Any arguments to 173 | ##' `plot_grid()` may be supplied, except for: `plotlist` and `align`. 174 | ##' 175 | ##' @inheritParams evaluate_smooth 176 | ##' 177 | ##' @return A [ggplot2::ggplot()] object. 178 | ##' 179 | ##' @author Gavin L. Simpson 180 | ##' 181 | ##' @importFrom ggplot2 lims 182 | ##' @importFrom cowplot plot_grid 183 | ##' @export 184 | ##' 185 | ##' @examples 186 | ##' library("mgcv") 187 | ##' 188 | ##' set.seed(2) 189 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 190 | ##' m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 191 | ##' 192 | ##' draw(m1) 193 | ##' 194 | ##' set.seed(2) 195 | ##' dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 196 | ##' m2 <- gam(y ~ s(x, z, k = 30), data = dat$data, method = "REML") 197 | ##' 198 | ##' draw(m2) 199 | ##' 200 | ##' dat <- gamSim(4) 201 | ##' m3 <- gam(y ~ fac + s(x2, by = fac) + s(x0), data = dat) 202 | ##' 203 | ##' draw(m3, scales = "fixed") 204 | `draw.gam` <- function(object, 205 | select, # ignored for now; but used for subsetting which smooths 206 | scales = c("free", "fixed"), 207 | align = "hv", 208 | n = 100, unconditional = FALSE, inc.mean = FALSE, 209 | dist = 0.1, ...) { 210 | scales <- match.arg(scales) 211 | S <- smooths(object) # vector of smooth labels - "s(x)" 212 | 213 | ## can only plot 1 or 2d smooths - get smooth dimensions & prune list `s` 214 | d <- smooth_dim(object) 215 | S <- S[d <= 2L] 216 | d <- d[d <= 2L] 217 | 218 | ## FIXME: Exclude "re" smooths from "fixed" scales? 219 | is_re <- vapply(object[["smooth"]], is_re_smooth, logical(1L)) 220 | 221 | is_by <- vapply(object[["smooth"]], is_by_smooth, logical(1L)) 222 | if (any(is_by)) { 223 | S <- vapply(strsplit(S, ":"), `[[`, character(1L), 1L) 224 | } 225 | 226 | l <- g <- vector("list", length = length(S)) 227 | 228 | for (i in unique(S)) { 229 | eS <- evaluate_smooth(object, smooth = i, n = n, 230 | unconditional = unconditional, 231 | inc.mean = inc.mean, dist = dist) 232 | l[S == i] <- split(eS, eS[["smooth"]]) 233 | } 234 | 235 | for (i in seq_along(l)) { 236 | g[[i]] <- draw(droplevels(l[[i]])) 237 | } 238 | 239 | if (isTRUE(identical(scales, "fixed"))) { 240 | wrapper <- function(x) { 241 | range(x[["est"]] + (2 * x[["se"]]), 242 | x[["est"]] - (2 * x[["se"]])) 243 | } 244 | ylims <- range(unlist(lapply(l, wrapper))) 245 | 246 | for (i in seq_along(S)[d == 1L]) { # only the univariate smooths; FIXME: "re" smooths too? 247 | g[[i]] <- g[[i]] + lims(y = ylims) 248 | } 249 | } 250 | 251 | plot_grid(plotlist = g, align = align, ...) 252 | } 253 | 254 | ##' @param qq_line logical; draw a reference line through the lower and upper 255 | ##' theoretical quartiles. 256 | ##' 257 | ##' @importFrom ggplot2 geom_abline geom_point labs 258 | ##' @importFrom stats quantile qnorm 259 | ##' 260 | ##' @export 261 | ##' @rdname draw.evaluated_smooth 262 | `draw.evaluated_re_smooth` <- function(object, qq_line = TRUE, xlab, ylab, 263 | title = NULL, subtitle = NULL, 264 | caption = NULL, ...) { 265 | smooth_var <- names(object)[2L] 266 | 267 | ## base plot with computed QQs 268 | plt <- ggplot(object, aes_string(sample = "est")) + 269 | geom_point(stat = "qq") 270 | 271 | ## add a QQ reference line 272 | if (isTRUE(qq_line)) { 273 | sampq <- quantile(object[["est"]], c(0.25, 0.75)) 274 | gaussq <- qnorm(c(0.25, 0.75)) 275 | slope <- diff(sampq) / diff(gaussq) 276 | intercept <- sampq[1L] - slope * gaussq[1L] 277 | 278 | plt <- plt + geom_abline(slope = slope, intercept = intercept) 279 | } 280 | 281 | ## default axis labels if none supplied 282 | if (missing(xlab)) { 283 | xlab <- "Gaussian quantiles" 284 | } 285 | if (missing(ylab)) { 286 | ylab <- paste("Effects:", smooth_var) 287 | } 288 | 289 | ## add labelling to plot 290 | plt <- plt + labs(x = xlab, y = ylab, title = title, subtitle = subtitle, 291 | caption = caption) 292 | 293 | plt 294 | } 295 | -------------------------------------------------------------------------------- /R/evaluate_smooth.R: -------------------------------------------------------------------------------- 1 | ##' Evaluate a smooth 2 | ##' 3 | ##' Evaluate a smooth at a grid of evenly spaced value over the range of the covariate associated with the smooth. Alternatively, a set of points at which the smooth should be evaluated can be supplied. 4 | ##' 5 | ##' @param object an object of class `"gam"` or `"gamm"`. 6 | ##' @param smooth character; a single smooth to evaluate. 7 | ##' @param n numeric; the number of points over the range of the covariate at which to evaluate the smooth. 8 | ##' @param newdata a vector or data frame of points at which to evaluate the smooth. 9 | ##' @param unconditional logical; should confidence intervals include the uncertainty due to smoothness selection? If `TRUE`, the corrected Bayesian covariance matrix will be used. 10 | ##' @param inc.mean logical; should the uncertainty in the model constant term be 11 | ##' included in the standard error of the evaluate values of the smooth? 12 | ##' Currently not implemented. 13 | ##' @param dist numeric; if greater than 0, this is used to determine when 14 | ##' a location is too far from data to be plotted when plotting 2-D smooths. 15 | ##' The data are scaled into the unit square before deciding what to exclude, 16 | ##' and `dist` is a distance within the unit square. See 17 | ##' [mgcv::exclude.too.far()] for further details. 18 | ##' @param ... arguments passed to other methods. 19 | ##' 20 | ##' @return A data frame, which is of class `"evaluated_1d_smooth"` or `evaluated_2d_smooth`, which inherit from classes `"evaluated_smooth"` and `"data.frame"`. 21 | ##' 22 | ##' @importFrom mgcv PredictMat exclude.too.far 23 | ##' @importFrom stats setNames 24 | ##' 25 | ##' @export 26 | ##' 27 | ##' @examples 28 | ##' library("mgcv") 29 | ##' set.seed(2) 30 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 31 | ##' m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 32 | ##' 33 | ##' head(evaluate_smooth(m1, "s(x1)")) 34 | ##' 35 | ##' ## 2d example 36 | ##' set.seed(2) 37 | ##' dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 38 | ##' m2 <- gam(y ~ s(x, z, k = 30), data = dat$data, method = "REML") 39 | ##' 40 | ##' head(evaluate_smooth(m2, "s(x,z)", n = 100)) 41 | `evaluate_smooth` <- function(object, ...) { 42 | UseMethod("evaluate_smooth") 43 | } 44 | 45 | ##' @export 46 | ##' @rdname evaluate_smooth 47 | `evaluate_smooth.gam` <- function(object, smooth, n = 100, newdata = NULL, 48 | unconditional = FALSE, inc.mean = FALSE, 49 | dist = 0.1, ...) { 50 | ## simplify GAMM objects 51 | if (is.gamm(object)) { 52 | object <- object[["gam"]] 53 | } 54 | ## to keep this simple, only evaluate a single smooth at a time 55 | if (length(smooth) > 1L) { 56 | message("Supplied more than 1 'smooth'; using only the first") 57 | smooth <- smooth[1L] 58 | } 59 | smooth_ids <- which_smooth(object, smooth) # which smooths match 'smooth' 60 | smooth_labels <- select_smooth(object, smooth) 61 | 62 | ## Need to handle by smooths here 63 | ## use get_smooth() on each smooth 64 | ## SMOOTHS <- object[["smooth"]][smooth_ids] # take matched smooths 65 | SMOOTHS <- get_smooths_by_id(smooth_ids, object) # extract the mgcv.smooth object 66 | 67 | ## choose how to evaluate the smooth 68 | if (inherits(SMOOTHS[[1]], "random.effect")) { # FIXME: bs = "re" can also have `by` 69 | evaluated <- evaluate_re_smooth(SMOOTHS, model = object, 70 | newdata = newdata, 71 | unconditional = unconditional) 72 | } else if (smooth_dim(SMOOTHS[[1]]) == 1L) { # if 2d smooth, call separate fun 73 | evaluated <- evaluate_1d_smooth(SMOOTHS, n = n, model = object, 74 | newdata = newdata, inc.mean = inc.mean, 75 | unconditional = unconditional) 76 | } else if (smooth_dim(SMOOTHS[[1]]) == 2L) { 77 | evaluated <- evaluate_2d_smooth(SMOOTHS, n = n, model = object, 78 | newdata = newdata, inc.mean = inc.mean, 79 | unconditional = unconditional, 80 | dist = dist) 81 | } else { 82 | stop("Only univariate and bivariate smooths are currently supported.") 83 | } 84 | 85 | evaluated 86 | } 87 | 88 | ##' @export 89 | ##' @rdname evaluate_smooth 90 | `evaluate_smooth.gamm` <- function(object, ...) { 91 | evaluate_smooth(object[["gam"]]) 92 | } 93 | 94 | ## Random effect smooth 95 | `evaluate_re_smooth` <- function(object, model = NULL, newdata = NULL, 96 | unconditional = FALSE) { 97 | ## If more than one smooth, these should be by variables smooths 98 | is.by <- vapply(object, FUN = is_by_smooth, FUN.VALUE = logical(1L)) 99 | if (length(object) > 1L) { 100 | if (!all(is.by)) { 101 | msg <- paste("Hmm, something went wrong identifying the requested smooth. Found:\n", 102 | paste(vapply(object, FUN = smooth_label, 103 | FUN.VALUE = character(1L)), 104 | collapse = ', '), 105 | "\nNot all of these are 'by' variable smooths. Contact Maintainer.") 106 | stop(msg) 107 | } 108 | } 109 | 110 | ## get by variable info 111 | by_var <- unique(vapply(object, FUN = by_variable, FUN.VALUE = character(1))) 112 | 113 | if (!is.null(newdata)) { 114 | stop("Not yet implemented: user-supplied data in 're' smooth") 115 | } 116 | 117 | ## get variable for this smooth 118 | smooth_var <- unique(vapply(object, FUN = smooth_variable, FUN.VALUE = character(1))) 119 | smooth_labels <- vapply(object, FUN = smooth_label, FUN.VALUE = character(1)) 120 | levs <- levels(model[["model"]][[smooth_var]]) 121 | labels <- paste0(smooth_var, levs) 122 | 123 | ## if we have a by variable 124 | is.factor.by <- vapply(object, FUN = is_factor_by_smooth, FUN.VALUE = logical(1L)) 125 | 126 | evaluated <- vector("list", length(object)) 127 | for (i in seq_along(evaluated)) { 128 | start <- object[[i]][["first.para"]] 129 | end <- object[[i]][["last.para"]] 130 | para_seq <- seq(from = start, to = end, by = 1L) 131 | coefs <- coef(model)[para_seq] 132 | se <- diag(vcov(model, unconditional = unconditional))[para_seq] 133 | evaluated[[i]] <- data.frame(smooth = rep(smooth_labels[i], length(coefs)), 134 | ..var = levs, 135 | est = coefs, 136 | se = se, 137 | row.names = NULL) 138 | } 139 | 140 | evaluated <- do.call("rbind", evaluated) 141 | 142 | if (any(is.factor.by)) { 143 | evaluated <- cbind(evaluated, 144 | by_var = rep(levels(model[["model"]][[by_var]]), 145 | each = length(levs))) 146 | names(evaluated)[NCOL(evaluated)] <- by_var 147 | } 148 | 149 | names(evaluated)[2] <- smooth_var 150 | class(evaluated) <- c("evaluated_re_smooth", "evaluated_smooth", "data.frame") 151 | 152 | evaluated 153 | } 154 | 155 | `evaluate_1d_smooth` <- function(object, n = NULL, model = NULL, newdata = NULL, 156 | unconditional = FALSE, inc.mean = FALSE) { 157 | ## If more than one smooth, these should be by variables smooths 158 | is.by <- vapply(object, FUN = is_by_smooth, FUN.VALUE = logical(1L)) 159 | if (length(object) > 1L) { 160 | if (!all(is.by)) { 161 | msg <- paste("Hmm, something went wrong identifying the requested smooth. Found:\n", 162 | paste(vapply(object, FUN = smooth_label, 163 | FUN.VALUE = character(1L)), 164 | collapse = ', '), 165 | "\nNot all of these are 'by' variable smooths. Contact Maintainer.") 166 | stop(msg) 167 | } 168 | } 169 | 170 | ## get by variable info 171 | by_var <- unique(vapply(object, FUN = by_variable, FUN.VALUE = character(1))) 172 | 173 | ## get variable for this smooth 174 | smooth_var <- unique(vapply(object, FUN = smooth_variable, FUN.VALUE = character(1))) 175 | 176 | newx <- if (is.null(newdata)) { 177 | setNames(datagen(object[[1]], n = n, 178 | data = model[["model"]])[, "x", drop = FALSE], 179 | smooth_var) 180 | } else if (is.data.frame(newdata)) { # data frame; select out smooth 181 | if (!smooth_var %in% names(newdata)) { 182 | stop(paste("Variable", smooth_var, "not found in 'newdata'.")) 183 | } 184 | newdata[, smooth_var, drop = FALSE] 185 | } else if (is.numeric(newdata)) { # vector; coerce to data frame 186 | setNames(data.frame(newdata), smooth_var) 187 | } else { # object we can't handle; bail out 188 | stop("'newdata', if supplied, must be a numeric vector or a data frame.") 189 | } 190 | 191 | ## if we have a by variable, repeat newx for each level of that variable 192 | is.factor.by <- vapply(object, FUN = is_factor_by_smooth, FUN.VALUE = logical(1L)) 193 | is.continuous.by <- vapply(object, FUN = is_continuous_by_smooth, FUN.VALUE = logical(1L)) 194 | if (any(is.by)) { 195 | if (any(is.factor.by)) { # (is.factor(model[["model"]][[by_var]])) { 196 | levs <- levels(model[["model"]][[by_var]]) 197 | newx <- cbind(newx, .by_var = rep(levs, each = n)) 198 | } else { # continuous by 199 | newx <- cbind(newx, .by_var = mean(model[["model"]][[by_var]])) 200 | } 201 | names(newx)[NCOL(newx)] <- by_var 202 | } 203 | 204 | evaluated <- vector("list", length(object)) 205 | for (i in seq_along(evaluated)) { 206 | ind <- seq_len(NROW(newx)) 207 | if (any(is.factor.by)) { 208 | ind <- newx[, by_var] == levs[i] 209 | } 210 | evaluated[[i]] <- spline_values(object[[i]], 211 | newdata = newx[ind, , drop = FALSE], 212 | unconditional = unconditional, 213 | model = model, inc.mean = inc.mean, 214 | term = smooth_var) 215 | } 216 | 217 | evaluated <- do.call("rbind", evaluated) 218 | 219 | if (any(is.factor.by)) { 220 | evaluated <- cbind(evaluated, 221 | by_var = rep(levels(model[["model"]][[by_var]]), each = n)) 222 | names(evaluated)[NCOL(evaluated)] <- by_var 223 | } 224 | 225 | names(evaluated)[2] <- smooth_var 226 | class(evaluated) <- c("evaluated_1d_smooth", "evaluated_smooth", "data.frame") 227 | 228 | evaluated 229 | } 230 | 231 | `evaluate_2d_smooth` <- function(object, n = NULL, model = NULL, newdata = NULL, 232 | unconditional = FALSE, inc.mean = FALSE, dist = 0.1) { 233 | ## If more than one smooth, these should be by variables smooths 234 | is.by <- vapply(object, FUN = is_by_smooth, FUN.VALUE = logical(1L)) 235 | if (length(object) > 1L) { 236 | if (!all(is.by)) { 237 | msg <- paste("Hmm, something went wrong identifying the requested smooth. Found:\n", 238 | paste(vapply(object, FUN = smooth_label, 239 | FUN.VALUE = character(2L)), 240 | collapse = ', '), 241 | "\nNot all of these are 'by' variable smooths. Contact Maintainer.") 242 | stop(msg) 243 | } 244 | } 245 | 246 | ## get by variable info 247 | by_var <- unique(vapply(object, FUN = by_variable, FUN.VALUE = character(1))) 248 | 249 | ## get variables for this smooth 250 | smooth_var <- unique(vapply(object, FUN = smooth_variable, FUN.VALUE = character(2L))) 251 | 252 | newx <- if (is.null(newdata)) { 253 | setNames(datagen(object[[1]], n = n, 254 | data = model[["model"]])[, c("x1", "x2"), drop = FALSE], 255 | smooth_var) 256 | } else if (is.data.frame(newdata)) { # data frame; select out smooth 257 | if (!smooth_var %in% names(newdata)) { 258 | stop(paste("Variable", smooth_var, "not found in 'newdata'.")) 259 | } 260 | newdata[, smooth_var, drop = FALSE] 261 | } else if (is.numeric(newdata)) { # vector; coerce to data frame 262 | setNames(data.frame(newdata), smooth_var) 263 | } else { # object we can't handle; bail out 264 | stop("'newdata', if supplied, must be a numeric vector or a data frame.") 265 | } 266 | 267 | ## if we have a by variable, repeat newx for each level of that variable 268 | is.factor.by <- vapply(object, FUN = is_factor_by_smooth, FUN.VALUE = logical(1L)) 269 | is.continuous.by <- vapply(object, FUN = is_continuous_by_smooth, FUN.VALUE = logical(1L)) 270 | if (any(is.by)) { 271 | if (any(is.factor.by)) { # (is.factor(model[["model"]][[by_var]])) { 272 | levs <- levels(model[["model"]][[by_var]]) 273 | newx <- cbind(newx, .by_var = rep(levs, each = n)) 274 | } else { # continuous by 275 | newx <- cbind(newx, .by_var = mean(model[["model"]][[by_var]])) 276 | } 277 | names(newx)[NCOL(newx)] <- by_var 278 | } 279 | 280 | evaluated <- vector("list", length(object)) 281 | for (i in seq_along(evaluated)) { 282 | ind <- seq_len(NROW(newx)) 283 | if (any(is.factor.by)) { 284 | ind <- newx[, by_var] == levs[i] 285 | } 286 | evaluated[[i]] <- spline_values(object[[i]], 287 | newdata = newx[ind, , drop = FALSE], 288 | unconditional = unconditional, 289 | model = model, inc.mean = inc.mean, 290 | term = smooth_var) 291 | } 292 | 293 | evaluated <- do.call("rbind", evaluated) 294 | 295 | if (any(is.factor.by)) { 296 | evaluated <- cbind(evaluated, 297 | by_var = rep(levels(model[["model"]][[by_var]]), each = n)) 298 | names(evaluated)[NCOL(evaluated)] <- by_var 299 | } 300 | 301 | ## exclude values too far from data 302 | if (dist > 0) { 303 | ind <- mgcv::exclude.too.far(newx[, smooth_var[1L]], 304 | newx[, smooth_var[2L]], 305 | model[["model"]][, smooth_var[1L]], 306 | model[["model"]][, smooth_var[2L]], 307 | dist = dist) 308 | evaluated[ind, c("est", "se")] <- NA 309 | } 310 | 311 | names(evaluated)[2:3] <- smooth_var 312 | class(evaluated) <- c("evaluated_2d_smooth", "evaluated_smooth", "data.frame") 313 | 314 | ## return 315 | evaluated 316 | } 317 | 318 | ## loop over smooths and predict 319 | `spline_values` <- function(smooth, newdata, model, unconditional, 320 | inc.mean = FALSE, term) { 321 | X <- PredictMat(smooth, newdata) # prediction matrix 322 | start <- smooth[["first.para"]] 323 | end <- smooth[["last.para"]] 324 | para.seq <- start:end 325 | coefs <- coef(model)[para.seq] 326 | fit <- X %*% coefs 327 | 328 | label <- smooth_label(smooth) 329 | V <- get_vcov(model, unconditional = unconditional, 330 | term = label) 331 | if (isTRUE(inc.mean)) { 332 | stop("'inc.mean == TRUE' situation not currently supported") 333 | } else { 334 | rs <- rowSums((X %*% V) * X) 335 | se.fit <- sqrt(pmax(0, rs)) 336 | } 337 | d <- smooth_dim(smooth) 338 | ## Return 339 | out <- if (d == 1L) { 340 | data.frame(smooth = rep(label, nrow(X)), x = newdata[, 1L], 341 | est = fit, se = se.fit) 342 | } else { 343 | data.frame(smooth = rep(label, nrow(X)), 344 | x1 = newdata[, 1L], x2 = newdata[, 2L], 345 | est = fit, se = se.fit) 346 | } 347 | out 348 | } 349 | -------------------------------------------------------------------------------- /R/fderiv.R: -------------------------------------------------------------------------------- 1 | ##' First derivatives of fitted GAM functions 2 | ##' 3 | ##' The first derivative of the smooth functions of a GAM model calculated using finite differences. 4 | ##' 5 | ##' @param model A fitted GAM. Currently only models fitted by [mgcv::gam()] and [mgcv::gamm()] are supported. 6 | ##' @param ... Arguments that are passed to other methods. 7 | ##' 8 | ##' @return An object of class `"fderiv"` is returned. 9 | ##' 10 | ##' @author Gavin L. Simpson 11 | ##' 12 | ##' @export 13 | `fderiv` <- function(model, ...) { 14 | UseMethod("fderiv") 15 | } 16 | 17 | ##' @rdname fderiv 18 | ##' 19 | ##' @param newdata a data frame containing the values of the model covariates at which to evaluate the first derivatives of the smooths. 20 | ##' @param term character; vector of one or more terms for which derivatives are required. If missing, derivatives for all smooth terms will be returned. 21 | ##' @param n integer; if `newdata` is missing the original data can be reconstructed from `model` and then `n` controls the number of values over the range of each covariate with which to populate `newdata`. 22 | ##' @param eps numeric; the value of the finite difference used to approximate the first derivative. 23 | ##' @param unconditional logical; if `TRUE`, the smoothing parameter uncertainty corrected covariance matrix is used, *if available*, otherwise the uncorrected Bayesian posterior covariance matrix is used. 24 | ##' @param offset numeric; value of offset to use in generating predictions. 25 | ##' 26 | ##' @importFrom stats coef model.frame predict terms vcov 27 | ##' 28 | ##' @export 29 | ##' 30 | ##' @examples 31 | ##' library("mgcv") 32 | ##' set.seed(2) 33 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 34 | ##' mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 35 | ##' 36 | ##' ## first derivatives of all smooths... 37 | ##' fd <- fderiv(mod) 38 | ##' 39 | ##' ## ...and a selected smooth 40 | ##' fd2 <- fderiv(mod, term = "x1") 41 | ##' 42 | ##' ## Models with factors 43 | ##' set.seed(2) 44 | ##' dat <- gamSim(4, n = 400, dist = "normal", scale = 2) 45 | ##' mod <- gam(y ~ s(x0) + s(x1) + fac, data = dat, method = "REML") 46 | ##' 47 | ##' ## first derivatives of all smooths... 48 | ##' fd <- fderiv(mod) 49 | ##' 50 | ##' ## ...and a selected smooth 51 | ##' fd2 <- fderiv(mod, term = "x1") 52 | `fderiv.gam` <- function(model, newdata, term, n = 200, eps = 1e-7, 53 | unconditional = FALSE, offset = NULL, ...) { 54 | 55 | ## where to predict/evaluate derivatives at 56 | if (missing(newdata)) { 57 | ## model.frame used to fit model 58 | mf <- model.frame(model) 59 | 60 | ## remove response 61 | respvar <- attr(model$terms, "response") 62 | if (!identical(respvar, 0)) { 63 | mf <- mf[, -respvar, drop = FALSE] 64 | } 65 | 66 | ## remove offset() var; model.frame returns both `offset(foo(var))` and `var`, 67 | ## so we can just remove the former, but we also want to set the offset 68 | ## variable `var` to something constant. FIXME 69 | if (is.null(offset)) { 70 | offset <- 1L 71 | } 72 | mf <- fix_offset(model, mf, offset_value = offset) 73 | 74 | ff <- vapply(mf, is.factor, logical(1L)) 75 | 76 | m.terms <- names(mf) 77 | 78 | if (any(ff)) { 79 | ## need to supply something for each factor 80 | rep_first_factor_value <- function(f, n) { 81 | stopifnot(is.factor(f)) 82 | levs <- levels(f) 83 | factor(rep(f[1], length.out = n), levels = levs) 84 | } 85 | f.mf <- lapply(mf[, ff, drop = FALSE], rep_first_factor_value, n = n) 86 | f.mf <- do.call("cbind.data.frame", f.mf) 87 | 88 | ## remove factors 89 | mf <- mf[, !ff, drop = FALSE] 90 | } 91 | 92 | ## generate newdata at `n` locations 93 | newdata <- lapply(mf, 94 | function(x) seq(min(x), max(x), length = n)) 95 | newdata <- do.call("data.frame", list(newdata, check.names = FALSE)) 96 | 97 | if (any(ff)) { 98 | newdata <- cbind(newdata, f.mf) 99 | } 100 | colnames(newdata) <- c(m.terms[!ff], m.terms[ff]) 101 | 102 | ## re-arrange 103 | newdata <- newdata[, m.terms, drop = FALSE] 104 | 105 | ## copy into newdata2 106 | newdata2 <- newdata 107 | 108 | if (any(ff)) { 109 | newdata2[, !ff] <- newdata2[, !ff, drop = FALSE] + eps 110 | } else { 111 | newdata2 <- newdata2 + eps 112 | } 113 | } else { 114 | ff <- vapply(newdata, is.factor, logical(1L)) 115 | ## copy into newdata2 116 | newdata2 <- newdata 117 | ## handle factors when shifting by eps 118 | if (any(ff)) { 119 | newdata2[, !ff] <- newdata2[, !ff, drop = FALSE] + eps 120 | } else { 121 | newdata2 <- newdata2 + eps 122 | } 123 | } 124 | 125 | ## compute Xp for evaluation points 126 | X0 <- predict(model, as.data.frame(newdata), type = "lpmatrix") 127 | X1 <- predict(model, as.data.frame(newdata2), type = "lpmatrix") 128 | Xp <- (X1 - X0) / eps 129 | Xp.r <- NROW(Xp) 130 | Xp.c <- NCOL(Xp) 131 | 132 | ## match the term with the the terms in the model 133 | if(!missing(term)) { 134 | S <- select_terms(model, term) 135 | S <- add_s(S) 136 | } else { 137 | S <- smooths(model) # model smooths 138 | } 139 | 140 | nt <- length(S) # how many smooths do we need derivatives for 141 | 142 | ## list to hold the derivatives 143 | lD <- vector(mode = "list", length = nt) 144 | names(lD) <- S 145 | 146 | ## Bayesian covar 147 | Vb <- vcov(model, unconditional = unconditional) 148 | 149 | ## loop over smooth terms, selecting the columns of Xp for the 150 | ## ith smooth 151 | for(i in seq_len(nt)) { 152 | Xi <- Xp * 0 # create new matrix with dim(Xp) but filled with 0 153 | want <- grep(S[i], colnames(X1), fixed = TRUE) # which columns in Lp are for current term 154 | Xi[, want] <- Xp[, want] # fill in 0-matrix with Lp data 155 | df <- Xi %*% coef(model) # predict derive given model coefs 156 | df.sd <- rowSums(Xi %*% Vb * Xi)^.5 # standard error of predictions 157 | lD[[i]] <- list(deriv = df, se.deriv = df.sd, Xi = Xi) 158 | } 159 | out <- structure(list(derivatives = lD, terms = S, model = model, 160 | eps = eps, eval = newdata, unconditional = unconditional), 161 | class = "fderiv") 162 | out 163 | } 164 | 165 | ##' @rdname fderiv 166 | ##' @export 167 | `fderiv.gamm` <- function(model, ...) { 168 | model <- model$gam 169 | fderiv.gam(model, ...) 170 | } 171 | -------------------------------------------------------------------------------- /R/other-scam-methods.R: -------------------------------------------------------------------------------- 1 | ##' @export 2 | `vcov.scam` <- function (object, freq = FALSE, dispersion = NULL, 3 | parametrized = TRUE, ...) { 4 | if (freq) { 5 | vc <- if (parametrized) { 6 | object$Ve.t 7 | } else { 8 | object$Ve 9 | } 10 | } else { 11 | vc <- if (parametrized) { 12 | object$Vp.t 13 | } else { 14 | object$Vp 15 | } 16 | } 17 | if (!is.null(dispersion)) { 18 | vc <- dispersion * vc/object$sig2 19 | } 20 | name <- names(object$edf) 21 | dimnames(vc) <- list(name, name) 22 | vc 23 | } 24 | 25 | ##' Extract coefficients from a fitted `scam` model. 26 | ##' 27 | ##' @param object a model object fitted by `scam()` 28 | ##' @param parametrized logical; extract parametrized coefficients, which respect the linear inequality constraints of the model. 29 | ##' @param ... other arguments. 30 | ##' 31 | ##' @export 32 | `coef.scam` <- function(object, parametrized = TRUE, ...) { 33 | coefs <- if (parametrized) { 34 | object$coefficients.t 35 | } else { 36 | object$coefficients 37 | } 38 | coefs 39 | } 40 | -------------------------------------------------------------------------------- /R/simulate-methods.R: -------------------------------------------------------------------------------- 1 | ##' Simulate from the posterior distribution of a GAM 2 | ##' 3 | ##' Simulations from the posterior distribution of a fitted GAM model involve making random draws from a multivariate normal with mean vector equal to the estimated model coefficients and covariance matrix equal to the covariance matrix of the coefficients. 4 | ##' 5 | ##' @param object a fitted GAM, typically the result of a call to `gam()` or `gamm()`. 6 | ##' @param nsim numeric; the number of posterior simulations to return. 7 | ##' @param seed numeric; a random seed for the simulations. 8 | ##' @param newdata data frame; new observations at which the posterior draws from the model should be evaluated. If not supplied, the data used to fit the model will be used for `newdata`, if available in `object`. 9 | ##' @param freq logical; `TRUE` to return the frequentist covariance matrix of the parameter estimators, `FALSE` to return the Bayesian posterior covariance matrix of the parameters. 10 | ##' @param unconditional logical; if `TRUE` (and `freq == FALSE`) then the Bayesian smoothing parameter uncertainty corrected covariance matrix is returned, if available. 11 | ##' @param ... arguments passed to methods 12 | ##' 13 | ##' @return (Currently) A matrix with `nsim` columns. 14 | ##' 15 | ##' @author Gavin L. Simpson 16 | ##' 17 | ##' @importFrom stats simulate runif 18 | ##' @importFrom MASS mvrnorm 19 | ##' 20 | ##' @export 21 | ##' 22 | ##' @rdname simulate 23 | ##' 24 | ##' @examples 25 | ##' library("mgcv") 26 | ##' set.seed(2) 27 | ##' dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 28 | ##' m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 29 | ##' 30 | ##' sims <- simulate(m1, nsim = 5, seed = 42) 31 | ##' head(sims) 32 | `simulate.gam` <- function(object, nsim = 1, seed = NULL, newdata = NULL, 33 | freq = FALSE, unconditional = FALSE, ...) { 34 | if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) { 35 | runif(1) 36 | } 37 | if (is.null(seed)) { 38 | RNGstate <- get(".Random.seed", envir = .GlobalEnv) 39 | } else { 40 | R.seed <- get(".Random.seed", envir = .GlobalEnv) 41 | set.seed(seed) 42 | RNGstate <- structure(seed, kind = as.list(RNGkind())) 43 | on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv)) 44 | } 45 | 46 | if (missing(newdata) || is.null(newdata)) { 47 | newdata <- object$model 48 | } 49 | 50 | V <- vcov(object, freq = freq, unconditional = unconditional) 51 | Rbeta <- mvrnorm(n = nsim, mu = coef(object), Sigma = V) 52 | Xp <- predict(object, newdata = newdata, type = "lpmatrix") 53 | sims <- Xp %*% t(Rbeta) 54 | attr(sims, "seed") <- RNGstate 55 | sims 56 | } 57 | 58 | ##' @rdname simulate 59 | ##' 60 | ##' @export 61 | `simulate.gamm` <- function(object, nsim = 1, seed = NULL, newdata = NULL, 62 | freq = FALSE, unconditional = FALSE, ...) { 63 | simulate(object$gam, nsim = nsim, seed = seed, newdata = newdata, 64 | freq = freq, unconditional = unconditional, ...) 65 | } 66 | 67 | ##' @rdname simulate 68 | ##' 69 | ##' @export 70 | ##' 71 | ##' @param parametrized logical; use parametrized coefficients and covariance matrix, which respect the linear inequality constraints of the model. 72 | `simulate.scam` <- function(object, nsim = 1, seed = NULL, newdata = NULL, 73 | freq = FALSE, parametrized = TRUE, ...) { 74 | if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) { 75 | runif(1) 76 | } 77 | if (is.null(seed)) { 78 | RNGstate <- get(".Random.seed", envir = .GlobalEnv) 79 | } else { 80 | R.seed <- get(".Random.seed", envir = .GlobalEnv) 81 | set.seed(seed) 82 | RNGstate <- structure(seed, kind = as.list(RNGkind())) 83 | on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv)) 84 | } 85 | 86 | if (missing(newdata) || is.null(newdata)) { 87 | newdata <- object$model 88 | } 89 | 90 | V <- vcov(object, freq = freq, parametrized = parametrized) 91 | B <- coef(object, parametrized = TRUE) # object$coefficients.t 92 | Rbeta <- MASS::mvrnorm(n = nsim, mu = B, Sigma = V) 93 | Xp <- predict(object, newdata = newdata, type = "lpmatrix") 94 | sims <- Xp %*% t(Rbeta) 95 | attr(sims, "seed") <- RNGstate 96 | sims 97 | } 98 | -------------------------------------------------------------------------------- /R/utililties.R: -------------------------------------------------------------------------------- 1 | ## smooth_terms should be removed 2 | `smooth_terms` <- function(obj, ...) { 3 | UseMethod("smooth_terms") 4 | } 5 | 6 | `smooth_terms.gam` <- function(object, ...) { 7 | lapply(object[["smooth"]], `[[`, "term") 8 | } 9 | 10 | `smooth_terms.gamm` <- function(object, ...) { 11 | smooth_terms(object[["gam"]], ...) 12 | } 13 | 14 | `smooth_terms.mgcv.smooth` <- function(object, ...) { 15 | object[["term"]] 16 | } 17 | 18 | ##' Dimension of a smooth 19 | ##' 20 | ##' Extracts the dimension of an estimated smooth. 21 | ##' 22 | ##' This is a generic function with methods for objects of class 23 | ##' \code{"gam"}, \code{"gamm"}, and \code{"mgcv.smooth"}. 24 | ## 25 | ##' @param object an R object. See Details for list of supported objects. 26 | ##' 27 | ##' @return A numeric vector of dimensions for each smooth. 28 | ##' 29 | ##' @author Gavin L. Simpson 30 | ##' 31 | ##' @rdname smooth_dim 32 | ##' @export 33 | `smooth_dim` <- function(object) { 34 | UseMethod("smooth_dim") 35 | } 36 | 37 | ##' @rdname smooth_dim 38 | ##' @export 39 | `smooth_dim.gam` <- function(object) { 40 | vapply(object[["smooth"]], FUN = `[[`, FUN.VALUE = integer(1), "dim") 41 | } 42 | 43 | ##' @rdname smooth_dim 44 | ##' @export 45 | `smooth_dim.gamm` <- function(object) { 46 | smooth_dim(object[["gam"]]) 47 | } 48 | 49 | ##' @rdname smooth_dim 50 | ##' @export 51 | `smooth_dim.mgcv.smooth` <- function(object) { 52 | object[["dim"]] 53 | } 54 | 55 | `select_terms` <- function(object, terms) { 56 | TERMS <- unlist(smooth_terms(object)) 57 | terms <- if (missing(terms)) { 58 | TERMS 59 | } else { 60 | want <- terms %in% TERMS 61 | if (any(!want)) { 62 | msg <- paste("Terms:", 63 | paste(terms[!want], collapse = ", "), 64 | "not found in `object`") 65 | message(msg) 66 | } 67 | terms[want] 68 | } 69 | terms 70 | } 71 | 72 | `select_smooth` <- function(object, smooth) { 73 | SMOOTHS <- smooths(object) 74 | if (missing(smooth)) { 75 | stop("'smooth' must be supplied; eg. `smooth = 's(x2)'`") 76 | } 77 | if (length(smooth) > 1L) { 78 | message(paste("Multiple smooths supplied. Using only first:", smooth[1])) 79 | smooth <- smooth[1] 80 | } 81 | want <- grep(smooth, SMOOTHS, fixed = TRUE) 82 | SMOOTHS[want] 83 | } 84 | 85 | `smooths` <- function(object) { 86 | vapply(object[["smooth"]], FUN = `[[`, FUN.VALUE = character(1), "label") 87 | } 88 | 89 | `smooth_variable` <- function(smooth) { 90 | check_is_mgcv_smooth(smooth) 91 | smooth[["term"]] 92 | } 93 | 94 | `smooth_label` <- function(smooth) { 95 | check_is_mgcv_smooth(smooth) 96 | smooth[["label"]] 97 | } 98 | 99 | `is_mgcv_smooth` <- function(smooth) { 100 | inherits(smooth, "mgcv.smooth") 101 | } 102 | 103 | `check_is_mgcv_smooth` <- function(smooth) { 104 | out <- is_mgcv_smooth(smooth) 105 | if (identical(out, FALSE)) { 106 | stop("Object passed to 'smooth' is not a 'mgcv.smooth'.") 107 | } 108 | invisible(out) 109 | } 110 | 111 | `is.gamm` <- function(object) { 112 | inherits(object, "gamm") 113 | } 114 | 115 | `is.gam` <- function(object) { 116 | inherits(object, "gam") 117 | } 118 | 119 | `get_smooth` <- function(object, term) { 120 | if (is.gamm(object)) { 121 | object <- object[["gam"]] 122 | } 123 | smooth <- object[["smooth"]][which_smooth(object, term)] 124 | if (identical(length(smooth), 1L)) { 125 | smooth <- smooth[[1L]] 126 | } 127 | smooth 128 | } 129 | 130 | `get_smooths_by_id` <- function(id, object) { 131 | if (is.gamm(object)) { 132 | object <- object[["gam"]] 133 | } 134 | object[["smooth"]][id] 135 | } 136 | 137 | `get_by_smooth` <- function(object, term, level) { 138 | if (is.gamm(object)) { 139 | object <- object[["gam"]] 140 | } 141 | 142 | ## which smooth match the term? 143 | take <- which_smooth(object, term) 144 | S <- object[["smooth"]][take] 145 | 146 | ## if there are multiple, then suggests a factor by smooth 147 | is_by <- vapply(S, is_factor_by_smooth, logical(1L)) 148 | 149 | ## if any are factor by variable smooths, get the levels 150 | if (any(is_by)) { 151 | if (missing(by_level)) { 152 | stop("No value provided for argument 'level':\n Getting a factor by-variable smooth requires a 'level' be supplied.") 153 | } 154 | level <- as.character(level) # explicit coerce to character for later comparison 155 | levs <- vapply(S, level, character(1L)) 156 | take <- match(level, levs) 157 | if (is.na(take)) { 158 | msg <- paste0("Invalid 'level' for smooth '", term, "'. Possible levels are:\n") 159 | msg <- paste(msg, paste(strwrap(paste0(shQuote(levs), collapse = ", "), 160 | prefix = " ", initial = ""), 161 | collapse = "\n")) 162 | stop(msg) 163 | } 164 | 165 | S <- S[[take]] 166 | } 167 | 168 | ## return a single smooth object 169 | S 170 | } 171 | 172 | `which_smooth` <- function(object, term) { 173 | if (is.gamm(object)) { 174 | object <- object[["gam"]] 175 | } 176 | smooths <- smooths(object) 177 | grep(term, smooths, fixed = TRUE) 178 | } 179 | 180 | `get_vcov` <- function(object, unconditional = FALSE, frequentist = FALSE, 181 | term = NULL, by_level = NULL) { 182 | V <- if (frequentist) { 183 | object$Ve 184 | } else if (unconditional) { 185 | if (is.null(object$Vc)) { 186 | warning("Covariance corrected for smoothness uncertainty not available.\nUsing uncorrected covariance.") 187 | object$Vp # Bayesian vcov of parameters 188 | } else { 189 | object$Vc # Corrected Bayesian vcov of parameters 190 | } 191 | } else { 192 | object$Vp # Bayesian vcov of parameters 193 | } 194 | 195 | ## extract selected term if requested 196 | if (!is.null(term)) { 197 | ## to keep this simple, only evaluate a single term 198 | if (length(term) > 1L) { 199 | message("Supplied more than 1 'term'; using only the first") 200 | term <- term[1L] 201 | } 202 | term <- select_smooth(object, term) 203 | smooth <- get_smooth(object, term) 204 | start <- smooth$first.para 205 | end <- smooth$last.para 206 | para.seq <- start:end 207 | V <- V[para.seq, para.seq, drop = FALSE] 208 | } 209 | V 210 | } 211 | 212 | `has_s` <- function(terms) { 213 | grepl("^s\\(.+\\)$", terms) 214 | } 215 | 216 | `add_s` <- function(terms) { 217 | take <- ! has_s(terms) 218 | terms[take] <- paste("s(", terms[take], ")", sep = "") 219 | terms 220 | } 221 | 222 | `is_re_smooth` <- function(smooth) { 223 | check_is_mgcv_smooth(smooth) 224 | inherits(smooth, "random.effect") 225 | } 226 | 227 | ##' Fix the names of a data frame containing an offset variable. 228 | ##' 229 | ##' Identifies which variable, if any, is the model offset, and fixed the name 230 | ##' such that `"offset(foo(var))" is converted `"var"`, and possibly sets that 231 | ##' data to `offset_value`. 232 | ## 233 | ##' @param model a fitted GAM. 234 | ##' 235 | ##' @param newdata data frame; new values at which to predict at. 236 | ##' 237 | ##' @param offset_value numeric, optional; if provided, then the offset variable in `newdata` is set to this constant value before returning `newdata` 238 | ##' 239 | ##' @return The original `newdata` is returned with fixed names and possibly modified offset variable. 240 | ##' 241 | ##' @author Gavin L. Simpson 242 | ##' 243 | ##' @export 244 | ##' 245 | ##' @examples 246 | ##' ##\testonly{set.seed(2)} 247 | ##' library("mgcv") 248 | ##' set.seed(2) 249 | ##' df <- gamSim(1, n = 400, dist = "normal") 250 | ##' m <- gam(y ~ s(x0) + s(x1) + offset(x0), data = df, method = "REML") 251 | ##' names(model.frame(m)) 252 | ##' names(fix_offset(m, model.frame(m), offset_value = 1L)) 253 | `fix_offset` <- function(model, newdata, offset_value = NULL) { 254 | m.terms <- names(newdata) 255 | p.terms <- attr(terms(model[["pred.formula"]]), "term.labels") 256 | 257 | ## remove repsonse from m.terms if it is in there 258 | tt <- terms(model) 259 | resp <- names(attr(tt, "dataClasses"))[attr(tt, "response")] 260 | Y <- m.terms == resp 261 | if (any(Y)) { 262 | m.terms <- m.terms[!Y] 263 | } 264 | 265 | ## is there an offset? 266 | off <- is_offset(m.terms) 267 | if (any(off)) { 268 | ## which cleaned terms not in model terms 269 | ind <- m.terms %in% p.terms 270 | ## for the cleaned terms not in model terms, match with the offset 271 | off_var <- grepl(p.terms[!ind], m.terms[off]) 272 | if (any(off_var)) { 273 | names(newdata)[off] <- p.terms[!ind][off_var] 274 | } 275 | } 276 | 277 | ## change offset? 278 | if (!is.null(offset_value)) { 279 | newdata[, off] <- offset_value 280 | } 281 | 282 | newdata # return 283 | } 284 | 285 | ##' Is a model term an offset? 286 | ##' 287 | ##' Given a character vector of model terms, checks to see which, if any, is the model offset. 288 | ##' 289 | ##' @param terms character vector of model terms. 290 | ##' 291 | ##' @return A logical vector of the same length as `terms`. 292 | ##' 293 | ##' @author Gavin L. Simpson 294 | ##' 295 | ##' @export 296 | ##' 297 | ##' @examples 298 | ##' library("mgcv") 299 | ##' df <- gamSim(1, n = 400, dist = "normal") 300 | ##' m <- gam(y ~ s(x0) + s(x1) + offset(x0), data = df, method = "REML") 301 | ##' nm <- names(model.frame(m)) 302 | ##' nm 303 | ##' is_offset(nm) 304 | `is_offset` <- function(terms) { 305 | grepl("offset\\(", terms) 306 | } 307 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # schoenberg 2 | 3 | The *schoenberg* package for R provides ggplot-based graphics and useful functions for GAMs fitted using the mgcv package. 4 | 5 | [![Project Status: Abandoned – Initial development has started, but there has not yet been a stable, usable release; the project has been abandoned and the author(s) do not intend on continuing development.](http://www.repostatus.org/badges/latest/abandoned.svg)](http://www.repostatus.org/#abandoned) 6 | 7 | I've abondonded this project, moving development to the [gratia](https://github.com/gavinsimpson/gratia) package because the name "schoenberg" has recently been taken by another package on CRAN. I'm leaving this repo up though as I know some people were using it in scripts, I was using it in a preprint of a GAM paper that is under review, and I have blog posts using it. 8 | 9 | ## Build status 10 | 11 | [![Build Status](https://travis-ci.org/gavinsimpson/schoenberg.svg?branch=master)](https://travis-ci.org/gavinsimpson/schoenberg) [![Build status](https://ci.appveyor.com/api/projects/status/w7pj8773t5b8fxkb/branch/master?svg=true)](https://ci.appveyor.com/project/gavinsimpson/schoenberg/branch/master) [![codecov](https://codecov.io/gh/gavinsimpson/schoenberg/branch/master/graph/badge.svg)](https://codecov.io/gh/gavinsimpson/schoenberg) 12 | 13 | ## Features 14 | 15 | The main features of *schoenberg* are currently 16 | 17 | * A *ggplot2*-based replacement for `mgcv:::plot.gam()`: `draw(gam_model)`. 18 | 19 | Note specialist smoothers (`bs %in% c("re","fs","mrf","so")`) are not supported, but univariate, *factor* and *continuous* `by`-variable smooths, and bivariate tensor product smooths are supported, 20 | 21 | * Estimatation of derivatives of fitted smoothers: `fderiv(gam_model)`, 22 | 23 | * Estimation of point-wise across-the-function confidence intervals and simultaneous intervals for smooths: `confint(gam_model)`. 24 | 25 | ## Installing *schoenberg* 26 | 27 | *schoenberg* is under active development and has not yet had its first release to CRAN. The easiest way to install the package is via the `install_github()` function from package *devtools*. Make sure you have *devtools* installed, then run 28 | 29 | ```r 30 | devtools::install_github("gavinsimpson/schoenberg") 31 | ``` 32 | 33 | to install the package. 34 | 35 | ## History 36 | 37 | *schoenberg* grew out of an earlier package, *tsgam*, which was originally intended to be used with GAMs fitted to time series. As I was developing *tsgam* however it became clear that the package could be used more generally and that the name "tsgam" was no longer appropriate. To avoid breaking blog posts I had written using *tsgam* I decided to copy the git repo and all the history to a new repo for the package under the name *schoenberg*. 38 | 39 | ## Why *schoenberg*? 40 | 41 | In naming his [*greta*](https://github.com/greta-dev/greta) package, Nick Golding observed the recent phenomena of naming statistical modelling software, such as Stan or Edward, after individuals that played a prominent role in the development of the field. This lead Nick to name his Tensor Flow-based package *greta* after [*Grete Hermann*](https://greta-dev.github.io/greta/why_greta.html). 42 | 43 | In the same spirit, *schoenberg* is named in recognition of the contributions of Grace Wahba, who did pioneering work on the penalised spline models that are at the foundation of the way GAMs are estimated in *mgcv*. I wanted to name the package *grace*, to more explicitly recognise Grace's contributions, but unfortunately there was already a package named *Grace* on CRAN. So I looked elsewhere for inspiration. 44 | 45 | [Grace Wahba](https://en.wikipedia.org/wiki/Grace_Wahba) is the IJ Schoenberg-Hilldale Professor of Statistics at the University of Wisconsin-Madison, where she has worked since 1967. The chair is named after [Isaac J Schoenberg](https://en.wikipedia.org/wiki/Isaac_Jacob_Schoenberg), a former University Madison-Wisconsin Professor of Mathematics, who in a 1946 paper provided the first mathematical reference to "splines". 46 | 47 | The name *schoenberg* links and recognises two pioneers in the field of splines. 48 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | environment: 4 | R_CHECK_ARGS: --no-build-vignettes --no-manual 5 | 6 | # Download script file from GitHub 7 | init: 8 | ps: | 9 | $ErrorActionPreference = "Stop" 10 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 11 | Import-Module '..\appveyor-tool.ps1' 12 | 13 | install: 14 | ps: Bootstrap 15 | 16 | # Adapt as necessary starting from here 17 | 18 | build_script: 19 | - travis-tool.sh install_deps 20 | 21 | test_script: 22 | - travis-tool.sh run_tests 23 | 24 | on_failure: 25 | - travis-tool.sh dump_logs 26 | 27 | artifacts: 28 | - path: '*.Rcheck\**\*.log' 29 | name: Logs 30 | 31 | - path: '*.Rcheck\**\*.out' 32 | name: Logs 33 | 34 | - path: '*.Rcheck\**\*.fail' 35 | name: Logs 36 | 37 | - path: '*.Rcheck\**\*.Rout' 38 | name: Logs 39 | 40 | - path: '\*_*.tar.gz' 41 | name: Bits 42 | 43 | - path: '\*_*.zip' 44 | name: Bits 45 | -------------------------------------------------------------------------------- /data/smallAges.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gavinsimpson/schoenberg/3d375c506bbe38fd1bea39506ebeaf00e7e966f2/data/smallAges.rda -------------------------------------------------------------------------------- /man/coef.scam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/other-scam-methods.R 3 | \name{coef.scam} 4 | \alias{coef.scam} 5 | \title{Extract coefficients from a fitted \code{scam} model.} 6 | \usage{ 7 | \method{coef}{scam}(object, parametrized = TRUE, ...) 8 | } 9 | \arguments{ 10 | \item{object}{a model object fitted by \code{scam()}} 11 | 12 | \item{parametrized}{logical; extract parametrized coefficients, which respect the linear inequality constraints of the model.} 13 | 14 | \item{...}{other arguments.} 15 | } 16 | \description{ 17 | Extract coefficients from a fitted \code{scam} model. 18 | } 19 | -------------------------------------------------------------------------------- /man/confint.fderiv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/confint-methods.R 3 | \name{confint.fderiv} 4 | \alias{confint.fderiv} 5 | \title{Point-wise and simultaneous confidence intervals for derivatives of smooths} 6 | \usage{ 7 | \method{confint}{fderiv}(object, parm, level = 0.95, type = c("confidence", 8 | "simultaneous"), nsim = 10000, ...) 9 | } 10 | \arguments{ 11 | \item{object}{an object of class \code{"fderiv"} containing the estimated derivatives.} 12 | 13 | \item{parm}{which parameters (smooth terms) are to be given intervals as a vector of terms. If missing, all parameters are considered.} 14 | 15 | \item{level}{numeric, \code{0 < level < 1}; the confidence level of the point-wise or simultaneous interval. The default is \code{0.95} for a 95\% interval.} 16 | 17 | \item{type}{character; the type of interval to compute. One of \code{"confidence"} for point-wise intervals, or \code{"simultaneous"} for simultaneous intervals.} 18 | 19 | \item{nsim}{integer; the number of simulations used in computing the simultaneous intervals.} 20 | 21 | \item{...}{additional arguments for methods} 22 | } 23 | \value{ 24 | a data frame with components: 25 | \enumerate{ 26 | \item \code{term}; factor indicating to which term each row relates, 27 | \item \code{lower}; lower limit of the confidence or simultaneous interval, 28 | \item \code{est}; estimated derivative 29 | \item \code{upper}; upper limit of the confidence or simultaneous interval. 30 | } 31 | } 32 | \description{ 33 | Calculates point-wise confidence or simultaneous intervals for the first derivatives of smooth terms in a fitted GAM. 34 | } 35 | \examples{ 36 | library("mgcv") 37 | set.seed(2) 38 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 39 | mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 40 | 41 | ## first derivatives of all smooths... 42 | fd <- fderiv(mod) 43 | 44 | ## point-wise interval 45 | ci <- confint(fd, type = "confidence") 46 | head(ci) 47 | 48 | ## simultaneous interval for smooth term of x1 49 | set.seed(42) 50 | x1.sint <- confint(fd, parm = "x1", type = "simultaneous", nsim = 1000) 51 | head(x1.sint) 52 | } 53 | \author{ 54 | Gavin L. Simpson 55 | } 56 | -------------------------------------------------------------------------------- /man/confint.gam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/confint-methods.R 3 | \name{confint.gam} 4 | \alias{confint.gam} 5 | \alias{confint.gamm} 6 | \title{Point-wise and simultaneous confidence intervals for smooths} 7 | \usage{ 8 | \method{confint}{gam}(object, parm, level = 0.95, newdata = NULL, n = 200, 9 | type = c("confidence", "simultaneous"), nsim = 10000, shift = FALSE, 10 | transform = FALSE, unconditional = FALSE, ...) 11 | 12 | \method{confint}{gamm}(object, ...) 13 | } 14 | \arguments{ 15 | \item{object}{an object of class \code{"gam"} or \code{"gamm"}.} 16 | 17 | \item{parm}{which parameters (smooth terms) are to be given intervals as a vector of terms. If missing, all parameters are considered, although this is not currently implemented.} 18 | 19 | \item{level}{numeric, \code{0 < level < 1}; the confidence level of the point-wise or simultaneous interval. The default is \code{0.95} for a 95\% interval.} 20 | 21 | \item{newdata}{data frame; containing new values of the covariates used in the model fit. The selected smooth(s) wil be evaluated at the supplied values.} 22 | 23 | \item{n}{numeric; the number of points to evaluate smooths at.} 24 | 25 | \item{type}{character; the type of interval to compute. One of \code{"confidence"} for point-wise intervals, or \code{"simultaneous"} for simultaneous intervals.} 26 | 27 | \item{nsim}{integer; the number of simulations used in computing the simultaneous intervals.} 28 | 29 | \item{shift}{logical; should the constant term be add to the smooth?} 30 | 31 | \item{transform}{logical; should the smooth be evaluated on a transformed scale? For generalised models, this involves applying the inverse of the link function used to fit the model. Alternatively, the name of, or an actual, function can be supplied to transform the smooth and it's confidence interval.} 32 | 33 | \item{unconditional}{logical; if \code{TRUE} (and \code{freq == FALSE}) then the Bayesian smoothing parameter uncertainty corrected covariance matrix is returned, if available.} 34 | 35 | \item{...}{additional arguments for methods} 36 | } 37 | \value{ 38 | a data frame with components: 39 | \enumerate{ 40 | \item \code{term}; factor indicating to which term each row relates, 41 | \item \code{x}; the vector of values at which the smooth was evaluated, 42 | \item \code{lower}; lower limit of the confidence or simultaneous interval, 43 | \item \code{est}; estimated value of the smooth 44 | \item \code{upper}; upper limit of the confidence or simultaneous interval, 45 | \item \code{crit}; critical value for the \code{100 * level}% confidence interval. 46 | } 47 | } 48 | \description{ 49 | Calculates point-wise confidence or simultaneous intervals for the smooth terms of a fitted GAM. 50 | } 51 | \examples{ 52 | library("mgcv") 53 | set.seed(2) 54 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 55 | mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 56 | ##' 57 | ## point-wise interval 58 | ci <- confint(mod, parm = "x1", type = "confidence") 59 | head(ci) 60 | ##' 61 | ## simultaneous interval for smooth term of x1 62 | set.seed(42) 63 | si <- confint(mod, parm = "x1", type = "simultaneous", nsim = 100) 64 | head(si) 65 | } 66 | \author{ 67 | Gavin L. Simpson 68 | } 69 | -------------------------------------------------------------------------------- /man/datagen.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/datagen-methods.R 3 | \name{datagen} 4 | \alias{datagen} 5 | \alias{datagen.mgcv.smooth} 6 | \alias{datagen.gam} 7 | \alias{datagen.gamm} 8 | \title{Generate data over the range of variables used in smooths} 9 | \usage{ 10 | datagen(x, ...) 11 | 12 | \method{datagen}{mgcv.smooth}(x, n = 100, data, ...) 13 | 14 | \method{datagen}{gam}(x, n = 200, ...) 15 | 16 | \method{datagen}{gamm}(x, ...) 17 | } 18 | \arguments{ 19 | \item{x}{an object for which new data is required. Currently objects of classes \code{"gam"}, and \code{"gamm"} are supported, as are smooths from \strong{mgcv} inheriting from class \code{"mgcv.smooth"}.} 20 | 21 | \item{...}{arguments passed to methods} 22 | 23 | \item{n}{numeric; the number of data values to generate per term in each smooth.} 24 | 25 | \item{data}{data frame; for \code{"mgcv.smooth"} objects, the data used to fit the GAM need to be supplied.} 26 | } 27 | \value{ 28 | A data frame of new values spread over the range of the observed values. 29 | } 30 | \description{ 31 | For each smooth in a GAM, generate new data over the range of the variables in volved in a smooth. 32 | } 33 | \examples{ 34 | library("mgcv") 35 | 36 | ## 1d example 37 | set.seed(2) 38 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 39 | m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 40 | df <- datagen(m1) 41 | head(df) 42 | 43 | ## 2d example 44 | dat <- gamSim(2, n = 400, dist = "normal", scale = 2) 45 | m2 <- gam(y ~ s(x, z), data = dat$data, method = "REML") 46 | df <- datagen(m2) 47 | head(df) 48 | ## alternative showing using the mgcv.smooth method for a single smooth 49 | df2 <- datagen(m2[["smooth"]][[1L]], data = dat$data) 50 | head(df2) 51 | } 52 | \author{ 53 | Gavin L. Simpson 54 | } 55 | -------------------------------------------------------------------------------- /man/draw.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/draw-methods.R 3 | \name{draw} 4 | \alias{draw} 5 | \title{Generic plotting via \code{ggplot2}} 6 | \usage{ 7 | draw(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{and R object to plot.} 11 | 12 | \item{...}{arguments passed to other methods.} 13 | } 14 | \value{ 15 | A \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} object. 16 | } 17 | \description{ 18 | Generic plotting via \code{ggplot2} 19 | } 20 | \details{ 21 | Generic function for plotting of R objects that uses the \code{ggplot2} package. 22 | } 23 | \author{ 24 | Gavin L. Simpson 25 | } 26 | -------------------------------------------------------------------------------- /man/draw.evaluated_smooth.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/draw-methods.R 3 | \name{draw.evaluated_smooth} 4 | \alias{draw.evaluated_smooth} 5 | \alias{draw.evaluated_1d_smooth} 6 | \alias{draw.evaluated_2d_smooth} 7 | \alias{draw.evaluated_2d_smooth} 8 | \alias{draw.evaluated_re_smooth} 9 | \title{Plot estimated smooths} 10 | \usage{ 11 | \method{draw}{evaluated_1d_smooth}(object, xlab, ylab, title = NULL, 12 | subtitle = NULL, caption = NULL, ...) 13 | 14 | \method{draw}{evaluated_2d_smooth}(object, show = c("estimate", "se"), 15 | contour = TRUE, xlab, ylab, title = NULL, subtitle = NULL, 16 | caption = NULL, ...) 17 | 18 | \method{draw}{evaluated_re_smooth}(object, qq_line = TRUE, xlab, ylab, 19 | title = NULL, subtitle = NULL, caption = NULL, ...) 20 | } 21 | \arguments{ 22 | \item{object}{an object, the result of a call to \code{\link[=evaluate_smooth]{evaluate_smooth()}}.} 23 | 24 | \item{xlab}{character or expression; the label for the x axis. If not 25 | supplied, a suitable label will be generated from \code{object}.} 26 | 27 | \item{ylab}{character or expression; the label for the y axis. If not 28 | supplied, a suitable label will be generated from \code{object}.} 29 | 30 | \item{title}{character or expression; the title for the plot. See 31 | \code{\link[ggplot2:labs]{ggplot2::labs()}}.} 32 | 33 | \item{subtitle}{character or expression; the subtitle for the plot. See 34 | \code{\link[ggplot2:labs]{ggplot2::labs()}}.} 35 | 36 | \item{caption}{character or expression; the plot caption. See 37 | \code{\link[ggplot2:labs]{ggplot2::labs()}}.} 38 | 39 | \item{...}{arguments passed to other methods.} 40 | 41 | \item{show}{character; plot the estimated smooth (\code{"estimate"}) or its 42 | standard error (\code{"se"}).} 43 | 44 | \item{contour}{logical; should contours be draw on the plot using 45 | \code{\link[ggplot2:geom_contour]{ggplot2::geom_contour()}}.} 46 | 47 | \item{qq_line}{logical; draw a reference line through the lower and upper 48 | theoretical quartiles.} 49 | } 50 | \value{ 51 | A \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} object. 52 | } 53 | \description{ 54 | Plots estimated univariate and bivariate smooths using ggplot2. 55 | } 56 | \examples{ 57 | library("mgcv") 58 | 59 | set.seed(2) 60 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 61 | m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 62 | 63 | sm <- evaluate_smooth(m1, "s(x2)") 64 | draw(sm) 65 | 66 | set.seed(2) 67 | dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 68 | m2 <- gam(y ~ s(x, z, k = 40), data = dat$data, method = "REML") 69 | 70 | sm <- evaluate_smooth(m2, "s(x,z)", n = 100) 71 | draw(sm) 72 | 73 | ## now the standard error the smooth instead 74 | draw(sm, show = "se") 75 | } 76 | \author{ 77 | Gavin L. Simpson 78 | } 79 | -------------------------------------------------------------------------------- /man/draw.gam.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/draw-methods.R 3 | \name{draw.gam} 4 | \alias{draw.gam} 5 | \title{Plot estimated smooths from a fitted GAM} 6 | \usage{ 7 | \method{draw}{gam}(object, select, scales = c("free", "fixed"), 8 | align = "hv", n = 100, unconditional = FALSE, inc.mean = FALSE, 9 | dist = 0.1, ...) 10 | } 11 | \arguments{ 12 | \item{object}{a fitted GAM, the result of a call to \code{\link[mgcv:gam]{mgcv::gam()}}.} 13 | 14 | \item{select}{character;} 15 | 16 | \item{scales}{character; should all univariate smooths be plotted with the 17 | same y-axis scale? The default, \code{scales = "fixed"}, ensures this is done. 18 | If \code{scales = "free"} each univariate smooth has its own y-axis scale.} 19 | 20 | \item{align}{characer; see argument \code{align} in \code{cowplot::plot_grid()}. 21 | Defaults to \code{"hv"} so that plots are nicely aligned.} 22 | 23 | \item{n}{numeric; the number of points over the range of the covariate at which to evaluate the smooth.} 24 | 25 | \item{unconditional}{logical; should confidence intervals include the uncertainty due to smoothness selection? If \code{TRUE}, the corrected Bayesian covariance matrix will be used.} 26 | 27 | \item{inc.mean}{logical; should the uncertainty in the model constant term be 28 | included in the standard error of the evaluate values of the smooth? 29 | Currently not implemented.} 30 | 31 | \item{dist}{numeric; if greater than 0, this is used to determine when 32 | a location is too far from data to be plotted when plotting 2-D smooths. 33 | The data are scaled into the unit square before deciding what to exclude, 34 | and \code{dist} is a distance within the unit square. See 35 | \code{\link[mgcv:exclude.too.far]{mgcv::exclude.too.far()}} for further details.} 36 | 37 | \item{...}{arguments passed to \code{cowplot::plot_grid()}. Any arguments to 38 | \code{plot_grid()} may be supplied, except for: \code{plotlist} and \code{align}.} 39 | } 40 | \value{ 41 | A \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} object. 42 | } 43 | \description{ 44 | Plots estimated smooths from a fitted GAM model in a similar way to 45 | \code{mgcv::plot.gam()} but instead of using base graphics, \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} 46 | is used instead. 47 | } 48 | \examples{ 49 | library("mgcv") 50 | 51 | set.seed(2) 52 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 53 | m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 54 | 55 | draw(m1) 56 | 57 | set.seed(2) 58 | dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 59 | m2 <- gam(y ~ s(x, z, k = 30), data = dat$data, method = "REML") 60 | 61 | draw(m2) 62 | 63 | dat <- gamSim(4) 64 | m3 <- gam(y ~ fac + s(x2, by = fac) + s(x0), data = dat) 65 | 66 | draw(m3, scales = "fixed") 67 | } 68 | \author{ 69 | Gavin L. Simpson 70 | } 71 | -------------------------------------------------------------------------------- /man/evaluate_smooth.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/evaluate_smooth.R 3 | \name{evaluate_smooth} 4 | \alias{evaluate_smooth} 5 | \alias{evaluate_smooth.gam} 6 | \alias{evaluate_smooth.gamm} 7 | \title{Evaluate a smooth} 8 | \usage{ 9 | evaluate_smooth(object, ...) 10 | 11 | \method{evaluate_smooth}{gam}(object, smooth, n = 100, newdata = NULL, 12 | unconditional = FALSE, inc.mean = FALSE, dist = 0.1, ...) 13 | 14 | \method{evaluate_smooth}{gamm}(object, ...) 15 | } 16 | \arguments{ 17 | \item{object}{an object of class \code{"gam"} or \code{"gamm"}.} 18 | 19 | \item{...}{arguments passed to other methods.} 20 | 21 | \item{smooth}{character; a single smooth to evaluate.} 22 | 23 | \item{n}{numeric; the number of points over the range of the covariate at which to evaluate the smooth.} 24 | 25 | \item{newdata}{a vector or data frame of points at which to evaluate the smooth.} 26 | 27 | \item{unconditional}{logical; should confidence intervals include the uncertainty due to smoothness selection? If \code{TRUE}, the corrected Bayesian covariance matrix will be used.} 28 | 29 | \item{inc.mean}{logical; should the uncertainty in the model constant term be 30 | included in the standard error of the evaluate values of the smooth? 31 | Currently not implemented.} 32 | 33 | \item{dist}{numeric; if greater than 0, this is used to determine when 34 | a location is too far from data to be plotted when plotting 2-D smooths. 35 | The data are scaled into the unit square before deciding what to exclude, 36 | and \code{dist} is a distance within the unit square. See 37 | \code{\link[mgcv:exclude.too.far]{mgcv::exclude.too.far()}} for further details.} 38 | } 39 | \value{ 40 | A data frame, which is of class \code{"evaluated_1d_smooth"} or \code{evaluated_2d_smooth}, which inherit from classes \code{"evaluated_smooth"} and \code{"data.frame"}. 41 | } 42 | \description{ 43 | Evaluate a smooth at a grid of evenly spaced value over the range of the covariate associated with the smooth. Alternatively, a set of points at which the smooth should be evaluated can be supplied. 44 | } 45 | \examples{ 46 | library("mgcv") 47 | set.seed(2) 48 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 49 | m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 50 | 51 | head(evaluate_smooth(m1, "s(x1)")) 52 | 53 | ## 2d example 54 | set.seed(2) 55 | dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 56 | m2 <- gam(y ~ s(x, z, k = 30), data = dat$data, method = "REML") 57 | 58 | head(evaluate_smooth(m2, "s(x,z)", n = 100)) 59 | } 60 | -------------------------------------------------------------------------------- /man/fderiv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fderiv.R 3 | \name{fderiv} 4 | \alias{fderiv} 5 | \alias{fderiv.gam} 6 | \alias{fderiv.gamm} 7 | \title{First derivatives of fitted GAM functions} 8 | \usage{ 9 | fderiv(model, ...) 10 | 11 | \method{fderiv}{gam}(model, newdata, term, n = 200, eps = 1e-07, 12 | unconditional = FALSE, offset = NULL, ...) 13 | 14 | \method{fderiv}{gamm}(model, ...) 15 | } 16 | \arguments{ 17 | \item{model}{A fitted GAM. Currently only models fitted by \code{\link[mgcv:gam]{mgcv::gam()}} and \code{\link[mgcv:gamm]{mgcv::gamm()}} are supported.} 18 | 19 | \item{...}{Arguments that are passed to other methods.} 20 | 21 | \item{newdata}{a data frame containing the values of the model covariates at which to evaluate the first derivatives of the smooths.} 22 | 23 | \item{term}{character; vector of one or more terms for which derivatives are required. If missing, derivatives for all smooth terms will be returned.} 24 | 25 | \item{n}{integer; if \code{newdata} is missing the original data can be reconstructed from \code{model} and then \code{n} controls the number of values over the range of each covariate with which to populate \code{newdata}.} 26 | 27 | \item{eps}{numeric; the value of the finite difference used to approximate the first derivative.} 28 | 29 | \item{unconditional}{logical; if \code{TRUE}, the smoothing parameter uncertainty corrected covariance matrix is used, \emph{if available}, otherwise the uncorrected Bayesian posterior covariance matrix is used.} 30 | 31 | \item{offset}{numeric; value of offset to use in generating predictions.} 32 | } 33 | \value{ 34 | An object of class \code{"fderiv"} is returned. 35 | } 36 | \description{ 37 | The first derivative of the smooth functions of a GAM model calculated using finite differences. 38 | } 39 | \examples{ 40 | library("mgcv") 41 | set.seed(2) 42 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 43 | mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 44 | 45 | ## first derivatives of all smooths... 46 | fd <- fderiv(mod) 47 | 48 | ## ...and a selected smooth 49 | fd2 <- fderiv(mod, term = "x1") 50 | 51 | ## Models with factors 52 | set.seed(2) 53 | dat <- gamSim(4, n = 400, dist = "normal", scale = 2) 54 | mod <- gam(y ~ s(x0) + s(x1) + fac, data = dat, method = "REML") 55 | 56 | ## first derivatives of all smooths... 57 | fd <- fderiv(mod) 58 | 59 | ## ...and a selected smooth 60 | fd2 <- fderiv(mod, term = "x1") 61 | } 62 | \author{ 63 | Gavin L. Simpson 64 | } 65 | -------------------------------------------------------------------------------- /man/fix_offset.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utililties.R 3 | \name{fix_offset} 4 | \alias{fix_offset} 5 | \title{Fix the names of a data frame containing an offset variable.} 6 | \usage{ 7 | fix_offset(model, newdata, offset_value = NULL) 8 | } 9 | \arguments{ 10 | \item{model}{a fitted GAM.} 11 | 12 | \item{newdata}{data frame; new values at which to predict at.} 13 | 14 | \item{offset_value}{numeric, optional; if provided, then the offset variable in \code{newdata} is set to this constant value before returning \code{newdata}} 15 | } 16 | \value{ 17 | The original \code{newdata} is returned with fixed names and possibly modified offset variable. 18 | } 19 | \description{ 20 | Identifies which variable, if any, is the model offset, and fixed the name 21 | such that \code{"offset(foo(var))" is converted}"var"\code{, and possibly sets that data to}offset_value`. 22 | } 23 | \examples{ 24 | ##\\testonly{set.seed(2)} 25 | library("mgcv") 26 | set.seed(2) 27 | df <- gamSim(1, n = 400, dist = "normal") 28 | m <- gam(y ~ s(x0) + s(x1) + offset(x0), data = df, method = "REML") 29 | names(model.frame(m)) 30 | names(fix_offset(m, model.frame(m), offset_value = 1L)) 31 | } 32 | \author{ 33 | Gavin L. Simpson 34 | } 35 | -------------------------------------------------------------------------------- /man/is_by_smooth.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/by-variable-utilities.R 3 | \name{is_by_smooth} 4 | \alias{is_by_smooth} 5 | \alias{is_factor_by_smooth} 6 | \alias{is_continuous_by_smooth} 7 | \alias{by_variable} 8 | \alias{by_level} 9 | \title{Tests for by variable smooths} 10 | \usage{ 11 | is_by_smooth(smooth) 12 | 13 | is_factor_by_smooth(smooth) 14 | 15 | is_continuous_by_smooth(smooth) 16 | 17 | by_variable(smooth) 18 | 19 | by_level(smooth) 20 | } 21 | \arguments{ 22 | \item{smooth}{an object of class \code{"mgcv.smooth"}} 23 | } 24 | \value{ 25 | A logical vector. 26 | } 27 | \description{ 28 | Functions to check if a smooth is a by-variable one and to test of the type 29 | of by-variable smooth is a factor-smooth or a continous-smooth interaction. 30 | } 31 | \author{ 32 | Gavin L. Simpson 33 | } 34 | -------------------------------------------------------------------------------- /man/is_offset.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utililties.R 3 | \name{is_offset} 4 | \alias{is_offset} 5 | \title{Is a model term an offset?} 6 | \usage{ 7 | is_offset(terms) 8 | } 9 | \arguments{ 10 | \item{terms}{character vector of model terms.} 11 | } 12 | \value{ 13 | A logical vector of the same length as \code{terms}. 14 | } 15 | \description{ 16 | Given a character vector of model terms, checks to see which, if any, is the model offset. 17 | } 18 | \examples{ 19 | library("mgcv") 20 | df <- gamSim(1, n = 400, dist = "normal") 21 | m <- gam(y ~ s(x0) + s(x1) + offset(x0), data = df, method = "REML") 22 | nm <- names(model.frame(m)) 23 | nm 24 | is_offset(nm) 25 | } 26 | \author{ 27 | Gavin L. Simpson 28 | } 29 | -------------------------------------------------------------------------------- /man/simulate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulate-methods.R 3 | \name{simulate.gam} 4 | \alias{simulate.gam} 5 | \alias{simulate.gamm} 6 | \alias{simulate.scam} 7 | \title{Simulate from the posterior distribution of a GAM} 8 | \usage{ 9 | \method{simulate}{gam}(object, nsim = 1, seed = NULL, newdata = NULL, 10 | freq = FALSE, unconditional = FALSE, ...) 11 | 12 | \method{simulate}{gamm}(object, nsim = 1, seed = NULL, newdata = NULL, 13 | freq = FALSE, unconditional = FALSE, ...) 14 | 15 | \method{simulate}{scam}(object, nsim = 1, seed = NULL, newdata = NULL, 16 | freq = FALSE, parametrized = TRUE, ...) 17 | } 18 | \arguments{ 19 | \item{object}{a fitted GAM, typically the result of a call to \code{gam()} or \code{gamm()}.} 20 | 21 | \item{nsim}{numeric; the number of posterior simulations to return.} 22 | 23 | \item{seed}{numeric; a random seed for the simulations.} 24 | 25 | \item{newdata}{data frame; new observations at which the posterior draws from the model should be evaluated. If not supplied, the data used to fit the model will be used for \code{newdata}, if available in \code{object}.} 26 | 27 | \item{freq}{logical; \code{TRUE} to return the frequentist covariance matrix of the parameter estimators, \code{FALSE} to return the Bayesian posterior covariance matrix of the parameters.} 28 | 29 | \item{unconditional}{logical; if \code{TRUE} (and \code{freq == FALSE}) then the Bayesian smoothing parameter uncertainty corrected covariance matrix is returned, if available.} 30 | 31 | \item{...}{arguments passed to methods} 32 | 33 | \item{parametrized}{logical; use parametrized coefficients and covariance matrix, which respect the linear inequality constraints of the model.} 34 | } 35 | \value{ 36 | (Currently) A matrix with \code{nsim} columns. 37 | } 38 | \description{ 39 | Simulations from the posterior distribution of a fitted GAM model involve making random draws from a multivariate normal with mean vector equal to the estimated model coefficients and covariance matrix equal to the covariance matrix of the coefficients. 40 | } 41 | \examples{ 42 | library("mgcv") 43 | set.seed(2) 44 | dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 45 | m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 46 | 47 | sims <- simulate(m1, nsim = 5, seed = 42) 48 | head(sims) 49 | } 50 | \author{ 51 | Gavin L. Simpson 52 | } 53 | -------------------------------------------------------------------------------- /man/smallAges.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/datasets.R 3 | \docType{data} 4 | \name{smallAges} 5 | \alias{smallAges} 6 | \title{Lead-210 age-depth measurements for Small Water} 7 | \format{A data frame with 12 rows and 7 variables.} 8 | \description{ 9 | A dataset containing lead-210 based age depth measurements for the SMALL1 10 | core from Small Water. 11 | } 12 | \details{ 13 | The variables are as follows: 14 | \itemize{ 15 | \item \code{Depth} 16 | \item \code{Drymass} 17 | \item \code{Date} 18 | \item \code{Age} 19 | \item \code{Error} 20 | \item \code{SedAccRate} 21 | \item \code{SedPerCentChange} 22 | } 23 | } 24 | \keyword{data} 25 | -------------------------------------------------------------------------------- /man/smooth_dim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utililties.R 3 | \name{smooth_dim} 4 | \alias{smooth_dim} 5 | \alias{smooth_dim.gam} 6 | \alias{smooth_dim.gamm} 7 | \alias{smooth_dim.mgcv.smooth} 8 | \title{Dimension of a smooth} 9 | \usage{ 10 | smooth_dim(object) 11 | 12 | \method{smooth_dim}{gam}(object) 13 | 14 | \method{smooth_dim}{gamm}(object) 15 | 16 | \method{smooth_dim}{mgcv.smooth}(object) 17 | } 18 | \arguments{ 19 | \item{object}{an R object. See Details for list of supported objects.} 20 | } 21 | \value{ 22 | A numeric vector of dimensions for each smooth. 23 | } 24 | \description{ 25 | Extracts the dimension of an estimated smooth. 26 | } 27 | \details{ 28 | This is a generic function with methods for objects of class 29 | \code{"gam"}, \code{"gamm"}, and \code{"mgcv.smooth"}. 30 | } 31 | \author{ 32 | Gavin L. Simpson 33 | } 34 | -------------------------------------------------------------------------------- /tests/Examples/schoenberg-Ex.Rout.save: -------------------------------------------------------------------------------- 1 | 2 | R version 3.4.4 Patched (2018-03-17 r74422) -- "Someone to Lean On" 3 | Copyright (C) 2018 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | Natural language support but running in an English locale 11 | 12 | R is a collaborative project with many contributors. 13 | Type 'contributors()' for more information and 14 | 'citation()' on how to cite R or R packages in publications. 15 | 16 | Type 'demo()' for some demos, 'help()' for on-line help, or 17 | 'help.start()' for an HTML browser interface to help. 18 | Type 'q()' to quit R. 19 | 20 | > pkgname <- "schoenberg" 21 | > source(file.path(R.home("share"), "R", "examples-header.R")) 22 | > options(warn = 1) 23 | > library('schoenberg') 24 | > 25 | > base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') 26 | > cleanEx() 27 | > nameEx("confint.fderiv") 28 | > ### * confint.fderiv 29 | > 30 | > flush(stderr()); flush(stdout()) 31 | > 32 | > ### Name: confint.fderiv 33 | > ### Title: Point-wise and simultaneous confidence intervals for derivatives 34 | > ### of smooths 35 | > ### Aliases: confint.fderiv 36 | > 37 | > ### ** Examples 38 | > 39 | > library("mgcv") 40 | Loading required package: nlme 41 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 42 | > set.seed(2) 43 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 44 | Gu & Wahba 4 term additive model 45 | > mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 46 | > 47 | > ## first derivatives of all smooths... 48 | > fd <- fderiv(mod) 49 | > 50 | > ## point-wise interval 51 | > ci <- confint(fd, type = "confidence") 52 | > head(ci) 53 | term lower est upper 54 | 1 s(x0) -0.8496033 4.112256 9.074116 55 | 2 s(x0) -0.8489453 4.112287 9.073519 56 | 3 s(x0) -0.8448851 4.112468 9.069821 57 | 4 s(x0) -0.8329611 4.112988 9.058936 58 | 5 s(x0) -0.8108549 4.113933 9.038721 59 | 6 s(x0) -0.7769722 4.115360 9.007693 60 | > 61 | > ## simultaneous interval for smooth term of x1 62 | > set.seed(42) 63 | > x1.sint <- confint(fd, parm = "x1", type = "simultaneous", nsim = 1000) 64 | > head(x1.sint) 65 | term lower est upper 66 | 1 s(x1) -5.249863 1.423165 8.096193 67 | 2 s(x1) -5.248720 1.423211 8.095142 68 | 3 s(x1) -5.243447 1.423425 8.090297 69 | 4 s(x1) -5.232857 1.423860 8.080577 70 | 5 s(x1) -5.215491 1.424591 8.064672 71 | 6 s(x1) -5.189990 1.425697 8.041385 72 | > 73 | > 74 | > 75 | > cleanEx() 76 | 77 | detaching ‘package:mgcv’, ‘package:nlme’ 78 | 79 | > nameEx("confint.gam") 80 | > ### * confint.gam 81 | > 82 | > flush(stderr()); flush(stdout()) 83 | > 84 | > ### Name: confint.gam 85 | > ### Title: Point-wise and simultaneous confidence intervals for smooths 86 | > ### Aliases: confint.gam confint.gamm 87 | > 88 | > ### ** Examples 89 | > 90 | > library("mgcv") 91 | Loading required package: nlme 92 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 93 | > set.seed(2) 94 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 95 | Gu & Wahba 4 term additive model 96 | > mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 97 | > ##' 98 | > ## point-wise interval 99 | > ci <- confint(mod, parm = "x1", type = "confidence") 100 | > head(ci) 101 | smooth x1 est se crit lower upper 102 | 1 s(x1) 0.0006632213 5.888546 0.3134611 1.959964 5.274174 6.502919 103 | 2 s(x1) 0.0056813456 5.895688 0.3045623 1.959964 5.298757 6.492619 104 | 3 s(x1) 0.0106994698 5.902830 0.2958458 1.959964 5.322983 6.482677 105 | 4 s(x1) 0.0157175940 5.909974 0.2873297 1.959964 5.346818 6.473130 106 | 5 s(x1) 0.0207357183 5.917121 0.2790332 1.959964 5.370226 6.464016 107 | 6 s(x1) 0.0257538425 5.924272 0.2709761 1.959964 5.393169 6.455376 108 | > ##' 109 | > ## simultaneous interval for smooth term of x1 110 | > set.seed(42) 111 | > si <- confint(mod, parm = "x1", type = "simultaneous", nsim = 100) 112 | > head(si) 113 | smooth x1 est se crit lower upper 114 | 1 s(x1) 0.0006632213 5.888546 0.3134611 2.772397 5.019507 6.757585 115 | 2 s(x1) 0.0056813456 5.895688 0.3045623 2.772397 5.051320 6.740056 116 | 3 s(x1) 0.0106994698 5.902830 0.2958458 2.772397 5.082628 6.723032 117 | 4 s(x1) 0.0157175940 5.909974 0.2873297 2.772397 5.113382 6.706566 118 | 5 s(x1) 0.0207357183 5.917121 0.2790332 2.772397 5.143530 6.690712 119 | 6 s(x1) 0.0257538425 5.924272 0.2709761 2.772397 5.173019 6.675526 120 | > 121 | > 122 | > 123 | > cleanEx() 124 | 125 | detaching ‘package:mgcv’, ‘package:nlme’ 126 | 127 | > nameEx("datagen") 128 | > ### * datagen 129 | > 130 | > flush(stderr()); flush(stdout()) 131 | > 132 | > ### Name: datagen 133 | > ### Title: Generate data over the range of variables used in smooths 134 | > ### Aliases: datagen datagen.mgcv.smooth datagen.gam datagen.gamm 135 | > 136 | > ### ** Examples 137 | > 138 | > library("mgcv") 139 | Loading required package: nlme 140 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 141 | > 142 | > ## 1d example 143 | > set.seed(2) 144 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 145 | Gu & Wahba 4 term additive model 146 | > m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 147 | > df <- datagen(m1) 148 | > head(df) 149 | term x 150 | 1 s(x0) 0.007109038 151 | 2 s(x0) 0.012087246 152 | 3 s(x0) 0.017065454 153 | 4 s(x0) 0.022043662 154 | 5 s(x0) 0.027021870 155 | 6 s(x0) 0.032000078 156 | > 157 | > ## 2d example 158 | > dat <- gamSim(2, n = 400, dist = "normal", scale = 2) 159 | Bivariate smoothing example 160 | > m2 <- gam(y ~ s(x, z), data = dat$data, method = "REML") 161 | > df <- datagen(m2) 162 | > head(df) 163 | smooth x1 x2 164 | 1 s(x,z) 0.001867117 0.002381104 165 | 2 s(x,z) 0.006878970 0.002381104 166 | 3 s(x,z) 0.011890823 0.002381104 167 | 4 s(x,z) 0.016902676 0.002381104 168 | 5 s(x,z) 0.021914529 0.002381104 169 | 6 s(x,z) 0.026926382 0.002381104 170 | > ## alternative showing using the mgcv.smooth method for a single smooth 171 | > df2 <- datagen(m2[["smooth"]][[1L]], data = dat$data) 172 | > head(df2) 173 | smooth x1 x2 174 | 1 s(x,z) 0.001867117 0.002381104 175 | 2 s(x,z) 0.011941448 0.002381104 176 | 3 s(x,z) 0.022015779 0.002381104 177 | 4 s(x,z) 0.032090110 0.002381104 178 | 5 s(x,z) 0.042164441 0.002381104 179 | 6 s(x,z) 0.052238771 0.002381104 180 | > 181 | > 182 | > 183 | > cleanEx() 184 | 185 | detaching ‘package:mgcv’, ‘package:nlme’ 186 | 187 | > nameEx("draw.evaluated_smooth") 188 | > ### * draw.evaluated_smooth 189 | > 190 | > flush(stderr()); flush(stdout()) 191 | > 192 | > ### Name: draw.evaluated_smooth 193 | > ### Title: Plot estimated smooths 194 | > ### Aliases: draw.evaluated_smooth draw.evaluated_1d_smooth 195 | > ### draw.evaluated_2d_smooth draw.evaluated_2d_smooth 196 | > ### draw.evaluated_re_smooth 197 | > 198 | > ### ** Examples 199 | > 200 | > library("mgcv") 201 | Loading required package: nlme 202 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 203 | > 204 | > set.seed(2) 205 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 206 | Gu & Wahba 4 term additive model 207 | > m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 208 | > 209 | > sm <- evaluate_smooth(m1, "s(x2)") 210 | > draw(sm) 211 | > 212 | > set.seed(2) 213 | > dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 214 | Bivariate smoothing example 215 | > m2 <- gam(y ~ s(x, z, k = 40), data = dat$data, method = "REML") 216 | > 217 | > sm <- evaluate_smooth(m2, "s(x,z)", n = 100) 218 | > draw(sm) 219 | > 220 | > ## now the standard error the smooth instead 221 | > draw(sm, show = "se") 222 | > 223 | > 224 | > 225 | > cleanEx() 226 | 227 | detaching ‘package:mgcv’, ‘package:nlme’ 228 | 229 | > nameEx("draw.gam") 230 | > ### * draw.gam 231 | > 232 | > flush(stderr()); flush(stdout()) 233 | > 234 | > ### Name: draw.gam 235 | > ### Title: Plot estimated smooths from a fitted GAM 236 | > ### Aliases: draw.gam 237 | > 238 | > ### ** Examples 239 | > 240 | > library("mgcv") 241 | Loading required package: nlme 242 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 243 | > 244 | > set.seed(2) 245 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 246 | Gu & Wahba 4 term additive model 247 | > m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 248 | > 249 | > draw(m1) 250 | > 251 | > set.seed(2) 252 | > dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 253 | Bivariate smoothing example 254 | > m2 <- gam(y ~ s(x, z, k = 30), data = dat$data, method = "REML") 255 | > 256 | > draw(m2) 257 | > 258 | > dat <- gamSim(4) 259 | Factor `by' variable example 260 | > m3 <- gam(y ~ fac + s(x2, by = fac) + s(x0), data = dat) 261 | > 262 | > draw(m3, scales = "fixed") 263 | > 264 | > 265 | > 266 | > cleanEx() 267 | 268 | detaching ‘package:mgcv’, ‘package:nlme’ 269 | 270 | > nameEx("evaluate_smooth") 271 | > ### * evaluate_smooth 272 | > 273 | > flush(stderr()); flush(stdout()) 274 | > 275 | > ### Name: evaluate_smooth 276 | > ### Title: Evaluate a smooth 277 | > ### Aliases: evaluate_smooth evaluate_smooth.gam evaluate_smooth.gamm 278 | > 279 | > ### ** Examples 280 | > 281 | > library("mgcv") 282 | Loading required package: nlme 283 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 284 | > set.seed(2) 285 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 286 | Gu & Wahba 4 term additive model 287 | > m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 288 | > 289 | > head(evaluate_smooth(m1, "s(x1)")) 290 | smooth x1 est se 291 | 1 s(x1) 0.0006632213 -1.944733 0.3134611 292 | 2 s(x1) 0.0107501579 -1.930377 0.2957587 293 | 3 s(x1) 0.0208370945 -1.916014 0.2788680 294 | 4 s(x1) 0.0309240311 -1.901632 0.2629466 295 | 5 s(x1) 0.0410109677 -1.887206 0.2481575 296 | 6 s(x1) 0.0510979043 -1.872698 0.2346391 297 | > 298 | > ## 2d example 299 | > set.seed(2) 300 | > dat <- gamSim(2, n = 4000, dist = "normal", scale = 1) 301 | Bivariate smoothing example 302 | > m2 <- gam(y ~ s(x, z, k = 30), data = dat$data, method = "REML") 303 | > 304 | > head(evaluate_smooth(m2, "s(x,z)", n = 100)) 305 | smooth x z est se 306 | 1 s(x,z) 2.298248e-05 4.321919e-05 0.1226246 0.1149179 307 | 2 s(x,z) 1.012240e-02 4.321919e-05 0.1218180 0.1124405 308 | 3 s(x,z) 2.022182e-02 4.321919e-05 0.1208805 0.1099417 309 | 4 s(x,z) 3.032124e-02 4.321919e-05 0.1198083 0.1074268 310 | 5 s(x,z) 4.042066e-02 4.321919e-05 0.1185977 0.1049027 311 | 6 s(x,z) 5.052008e-02 4.321919e-05 0.1172456 0.1023753 312 | > 313 | > 314 | > 315 | > cleanEx() 316 | 317 | detaching ‘package:mgcv’, ‘package:nlme’ 318 | 319 | > nameEx("fderiv") 320 | > ### * fderiv 321 | > 322 | > flush(stderr()); flush(stdout()) 323 | > 324 | > ### Name: fderiv 325 | > ### Title: First derivatives of fitted GAM functions 326 | > ### Aliases: fderiv fderiv.gam fderiv.gamm 327 | > 328 | > ### ** Examples 329 | > 330 | > library("mgcv") 331 | Loading required package: nlme 332 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 333 | > set.seed(2) 334 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 335 | Gu & Wahba 4 term additive model 336 | > mod <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 337 | > 338 | > ## first derivatives of all smooths... 339 | > fd <- fderiv(mod) 340 | > 341 | > ## ...and a selected smooth 342 | > fd2 <- fderiv(mod, term = "x1") 343 | > 344 | > ## Models with factors 345 | > set.seed(2) 346 | > dat <- gamSim(4, n = 400, dist = "normal", scale = 2) 347 | Factor `by' variable example 348 | > mod <- gam(y ~ s(x0) + s(x1) + fac, data = dat, method = "REML") 349 | > 350 | > ## first derivatives of all smooths... 351 | > fd <- fderiv(mod) 352 | > 353 | > ## ...and a selected smooth 354 | > fd2 <- fderiv(mod, term = "x1") 355 | > 356 | > 357 | > 358 | > cleanEx() 359 | 360 | detaching ‘package:mgcv’, ‘package:nlme’ 361 | 362 | > nameEx("fix_offset") 363 | > ### * fix_offset 364 | > 365 | > flush(stderr()); flush(stdout()) 366 | > 367 | > ### Name: fix_offset 368 | > ### Title: Fix the names of a data frame containing an offset variable. 369 | > ### Aliases: fix_offset 370 | > 371 | > ### ** Examples 372 | > 373 | > ##\testonly{set.seed(2)} 374 | > library("mgcv") 375 | Loading required package: nlme 376 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 377 | > set.seed(2) 378 | > df <- gamSim(1, n = 400, dist = "normal") 379 | Gu & Wahba 4 term additive model 380 | > m <- gam(y ~ s(x0) + s(x1) + offset(x0), data = df, method = "REML") 381 | > names(model.frame(m)) 382 | [1] "y" "offset(x0)" "x0" "x1" 383 | > names(fix_offset(m, model.frame(m), offset_value = 1L)) 384 | [1] "x0" "offset(x0)" "x0" "x0" 385 | > 386 | > 387 | > 388 | > cleanEx() 389 | 390 | detaching ‘package:mgcv’, ‘package:nlme’ 391 | 392 | > nameEx("is_offset") 393 | > ### * is_offset 394 | > 395 | > flush(stderr()); flush(stdout()) 396 | > 397 | > ### Name: is_offset 398 | > ### Title: Is a model term an offset? 399 | > ### Aliases: is_offset 400 | > 401 | > ### ** Examples 402 | > 403 | > library("mgcv") 404 | Loading required package: nlme 405 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 406 | > df <- gamSim(1, n = 400, dist = "normal") 407 | Gu & Wahba 4 term additive model 408 | > m <- gam(y ~ s(x0) + s(x1) + offset(x0), data = df, method = "REML") 409 | > nm <- names(model.frame(m)) 410 | > nm 411 | [1] "y" "offset(x0)" "x0" "x1" 412 | > is_offset(nm) 413 | [1] FALSE TRUE FALSE FALSE 414 | > 415 | > 416 | > 417 | > cleanEx() 418 | 419 | detaching ‘package:mgcv’, ‘package:nlme’ 420 | 421 | > nameEx("simulate") 422 | > ### * simulate 423 | > 424 | > flush(stderr()); flush(stdout()) 425 | > 426 | > ### Name: simulate.gam 427 | > ### Title: Simulate from the posterior distribution of a GAM 428 | > ### Aliases: simulate.gam simulate.gamm simulate.scam 429 | > 430 | > ### ** Examples 431 | > 432 | > library("mgcv") 433 | Loading required package: nlme 434 | This is mgcv 1.8-23. For overview type 'help("mgcv-package")'. 435 | > set.seed(2) 436 | > dat <- gamSim(1, n = 400, dist = "normal", scale = 2) 437 | Gu & Wahba 4 term additive model 438 | > m1 <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat, method = "REML") 439 | > 440 | > sims <- simulate(m1, nsim = 5, seed = 42) 441 | > head(sims) 442 | [,1] [,2] [,3] [,4] [,5] 443 | 1 8.470111 8.502529 9.243253 8.583744 8.888660 444 | 2 7.135076 7.166169 7.436497 7.447073 8.036909 445 | 3 3.632465 2.544824 3.083198 2.639840 2.612815 446 | 4 10.686483 10.415981 11.873220 10.799256 10.865970 447 | 5 14.077964 14.273323 14.646527 14.000525 13.707774 448 | 6 6.300381 6.205313 6.094017 5.697613 5.943234 449 | > 450 | > 451 | > 452 | > ### *