diff --git a/NAMESPACE b/NAMESPACE index d475b5b6d..1c2e48784 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -46,6 +46,11 @@ S3method(inv_link,gam) S3method(inv_link,gamm) S3method(inv_link,glm) S3method(inv_link,list) +S3method(is_factor_term,bam) +S3method(is_factor_term,gam) +S3method(is_factor_term,gamm) +S3method(is_factor_term,list) +S3method(is_factor_term,terms) S3method(link,bam) S3method(link,family) S3method(link,gam) @@ -72,6 +77,9 @@ S3method(smooth_dim,gamm) S3method(smooth_dim,mgcv.smooth) S3method(smooth_samples,default) S3method(smooth_samples,gam) +S3method(term_variables,bam) +S3method(term_variables,gam) +S3method(term_variables,terms) S3method(vcov,scam) S3method(which_smooths,bam) S3method(which_smooths,default) @@ -99,6 +107,7 @@ export(inv_link) export(is_by_smooth) export(is_continuous_by_smooth) export(is_factor_by_smooth) +export(is_factor_term) export(is_mgcv_smooth) export(is_mrf_smooth) export(is_offset) diff --git a/R/datasets.R b/R/datasets.R index 63ff70384..9023ba24d 100644 --- a/R/datasets.R +++ b/R/datasets.R @@ -77,3 +77,22 @@ NULL ##' @keywords data ##' @docType data NULL + +##' Data from the General Social Survey (GSS) from the National Opinion Research +##' Center of the University of Chicago +##' +##' A subset of the data from the [`carData::GSSvocab`] dataset from the +##' `carData` package, containing observations from 2016 only. +##' +##' @format A data frame with 1858 rows and 3 variables: +##' * `vocab`: numeric; the number of words out of 10 correct on a vocabulary +##' test. +##' * `nativeBorn`: factor; Was the respondent born in the US? A factor with +##' levels `no` and `yes`. +##' * `ageGroup`: factor; grouped age of the respondent with levels `18-29` +##' `30-39`, `40-49`, `50-59`, and `60+`.##' +##' +##' @keywords data +##' @name gss_vocab +##' @docType data +NULL diff --git a/R/evaluate_smooth.R b/R/evaluate_smooth.R index 354cdc073..01b482bf6 100644 --- a/R/evaluate_smooth.R +++ b/R/evaluate_smooth.R @@ -569,33 +569,55 @@ } mf <- model.frame(object) # data used to fit model - is_fac <- is.factor(mf[[term]]) # is term a factor? + + ## is_fac <- is.factor(mf[[term]]) # is term a factor? + is_fac <- is_factor_term(tt, term) ## match the specific term, with term names mgcv actually uses ## for example in a model with multiple linear predictors, terms in ## nth linear predictor (for n > 1) get appended .{n-1} ind <- match(term, vars) - - ## take the actual mgcv version of the names for the `terms` argument - evaluated <- as.data.frame(predict(object, newdata = mf, type = 'terms', - terms = mgcv_names[ind], se = TRUE, - unconditional = unconditional)) - evaluated <- setNames(evaluated, c("partial", "se")) - evaluated <- as_tibble(evaluated) - + if (is_fac) { - levs <- levels(mf[, term]) - newd <- setNames(data.frame(fac = factor(levs, levels = levs)), "value") - spl <- lapply(split(evaluated, mf[, term]), `[`, i = 1, j = ) - evaluated <- bind_rows(spl) + ## check order of term; if > 1 interaction and not handled + ord <- attr(tt, "order")[match(term, attr(tt, "term.labels"))] + if (ord > 1) { + stop("Interaction terms are not currently supported.") + } + ## facs <- attr(tt, 'factors')[, term] + newd <- unique(mf[, term, drop = FALSE]) + ## ##fac_vars <- rownames(facs) + ## fac_vars <- names(facs)[as.logical(facs)] + ## facs <- attr(tt, 'factors')[, term] + ## newd <- unique(mf[, names(facs)[as.logical(facs)], drop = FALSE]) + ## ##fac_vars <- rownames(facs) + ## fac_vars <- names(facs)[as.logical(facs)] + ## ##newd <- unique(mf[, fac_vars, drop = FALSE]) + other_vars <- setdiff(names(mf), term) + other_data <- as_tibble(lapply(mf[other_vars], value_closest_to_median)) + pred_data <- exec(expand_grid, !!!list(newd, other_data)) + evaluated <- as.data.frame(predict(object, newdata = pred_data, + type = 'terms', + terms = term, se = TRUE, + unconditional = unconditional, + newdata.guaranteed = FALSE)) + evaluated <- setNames(evaluated, c("partial", "se")) + evaluated <- as_tibble(evaluated) nr <- NROW(evaluated) + newd <- setNames(newd, "value") evaluated <- bind_cols(term = rep(term, nr), - type = rep(ifelse(is_fac, "factor", "numeric"), nr), + type = rep("factor", nr), newd, evaluated) } else { + ## take the actual mgcv version of the names for the `terms` argument + evaluated <- as.data.frame(predict(object, newdata = mf, type = 'terms', + terms = mgcv_names[ind], se = TRUE, + unconditional = unconditional)) + evaluated <- setNames(evaluated, c("partial", "se")) + evaluated <- as_tibble(evaluated) nr <- NROW(evaluated) evaluated <- bind_cols(term = rep(term, nr), - type = rep(ifelse(is_fac, "factor", "numeric"), nr), + type = rep("numeric", nr), value = mf[[term]], evaluated) } diff --git a/R/utililties.R b/R/utililties.R index 9780b0e21..8c68d8665 100644 --- a/R/utililties.R +++ b/R/utililties.R @@ -805,3 +805,117 @@ out <- TRUE out } + +##' Is a model term a factor (categorical)? +##' +##' Given the name (a term label) of a term in a model, identify if the term is a +##' factor term or numeric. This is useful when considering interactions, where +##' terms like `fac1:fac2` or `num1:fac1` may be requested by the user. Only for +##' terms of the type `fac1:fac2` will this function return `TRUE`. +##' +##' @param object an R object on which method dispatch is performed +##' @param term character; the name of a model term, in the sense of +##' `attr(terms(object), "term.labels")`. Currently not checked to see if the +##' term exists in the model. +##' @param ... arguments passed to other methods. +##' +##' @return A logical: `TRUE` if and only if all variables involved in the term +##' are factors, otherwise `FALSE`. +##' +##' @export +`is_factor_term` <- function(object, term, ...) { + UseMethod("is_factor_term", object) +} + +##' @rdname is_factor_term +##' @export +`is_factor_term.terms` <- function(object, term, ...) { + if (missing(term)) { + stop("Argument 'term' must be provided.") + } + facs <- attr(object, "factors") + out <- if (term %in% colnames(facs)) { + facs <- facs[, term, drop = FALSE] + take <- rownames(facs)[as.logical(facs)] + data_types <- attr(object, 'dataClasses')[take] + all(data_types == "factor") + } else { + NULL + } + out +} + +##' @rdname is_factor_term +##' @export +`is_factor_term.gam` <- function(object, term, ...) { + object <- terms(object) + is_factor_term(object, term, ...) +} + +##' @rdname is_factor_term +##' @export +`is_factor_term.bam` <- function(object, term, ...) { + object <- terms(object) + is_factor_term(object, term, ...) +} + +##' @rdname is_factor_term +##' @export +`is_factor_term.gamm` <- function(object, term, ...) { + object <- terms(object$gam) + is_factor_term(object, term, ...) +} + +##' @rdname is_factor_term +##' @export +`is_factor_term.list` <- function(object, term, ...) { + if (!is_gamm4(object)) { + if (all(vapply(object, inherits, logical(1), "terms"))) { + out <- any(unlist(lapply(object, is_factor_term, term))) + } else { + stop("Don't know how to handle generic list objects.") + } + } else { + object <- terms(object$gam) + out <- is_factor_term(object, term, ...) + } + out +} + +##' Names of variables involved in a specified model term +##' +##' Given the name (a term label) of a term in a model, returns the names +##' of the variables involved in ther term. +##' +##' @param object an R object on which method dispatch is performed +##' @param term character; the name of a model term, in the sense of +##' `attr(terms(object), "term.labels")`. Currently not checked to see if the +##' term exists in the model. +##' @param ... arguments passed to other methods. +##' +##' @return A character vector of variable names. +##' +`term_variables` <- function(object, term, ...) { + UseMethod("terms_variables", object) +} + +##' @rdname term_variables +##' @export +`term_variables.terms` <- function(object, term, ...) { + facs <- attr(object, "factors")[ , term] + names(facs)[as.logical(facs)] +} + +##' @rdname term_variables +##' @export +`term_variables.gam` <- function(object, term, ...) { + object <- terms(object) + term_variables(object, term, ...) +} + +##' @rdname term_variables +##' @export +`term_variables.bam` <- function(object, term, ...) { + object <- terms(object) + term_variables(object, term, ...) +} diff --git a/data/gss_vocab.rda b/data/gss_vocab.rda new file mode 100644 index 000000000..9de380be9 Binary files /dev/null and b/data/gss_vocab.rda differ diff --git a/man/add_fitted.Rd b/man/add_fitted.Rd index 75b0e2526..773ddc11b 100644 --- a/man/add_fitted.Rd +++ b/man/add_fitted.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/add-functions.R +% Please edit documentation in R/add-methods.R \name{add_fitted} \alias{add_fitted} \title{Add fitted values from a model to a data frame} diff --git a/man/add_fitted.gam.Rd b/man/add_fitted.gam.Rd index 697ed212c..490141034 100644 --- a/man/add_fitted.gam.Rd +++ b/man/add_fitted.gam.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/add-functions.R +% Please edit documentation in R/add-methods.R \name{add_fitted.gam} \alias{add_fitted.gam} \title{Add fitted values from a GAM to a data frame} diff --git a/man/add_residuals.Rd b/man/add_residuals.Rd index 74844aa23..82c371978 100644 --- a/man/add_residuals.Rd +++ b/man/add_residuals.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/add-functions.R +% Please edit documentation in R/add-methods.R \name{add_residuals} \alias{add_residuals} \title{Add residuals from a model to a data frame} diff --git a/man/add_residuals.gam.Rd b/man/add_residuals.gam.Rd index ac9a29e65..35ac21774 100644 --- a/man/add_residuals.gam.Rd +++ b/man/add_residuals.gam.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/add-functions.R +% Please edit documentation in R/add-methods.R \name{add_residuals.gam} \alias{add_residuals.gam} \title{Add residuals from a GAM to a data frame} diff --git a/man/gss_vocab.Rd b/man/gss_vocab.Rd new file mode 100644 index 000000000..9f40e2b50 --- /dev/null +++ b/man/gss_vocab.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasets.R +\docType{data} +\name{gss_vocab} +\alias{gss_vocab} +\title{Data from the General Social Survey (GSS) from the National Opinion Research +Center of the University of Chicago} +\format{ +A data frame with 1858 rows and 3 variables: +\itemize{ +\item \code{vocab}: numeric; the number of words out of 10 correct on a vocabulary +test. +\item \code{nativeBorn}: factor; Was the respondent born in the US? A factor with +levels \code{no} and \code{yes}. +\item \code{ageGroup}: factor; grouped age of the respondent with levels \code{18-29} +\code{30-39}, \code{40-49}, \code{50-59}, and \verb{60+}.##' +} +} +\description{ +A subset of the data from the \code{\link[carData:GSSvocab]{carData::GSSvocab}} dataset from the +\code{carData} package, containing observations from 2016 only. +} +\keyword{data} diff --git a/man/is_factor_term.Rd b/man/is_factor_term.Rd new file mode 100644 index 000000000..25db10f6d --- /dev/null +++ b/man/is_factor_term.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utililties.R +\name{is_factor_term} +\alias{is_factor_term} +\alias{is_factor_term.terms} +\alias{is_factor_term.gam} +\alias{is_factor_term.bam} +\alias{is_factor_term.gamm} +\alias{is_factor_term.list} +\title{Is a model term a factor (categorical)?} +\usage{ +is_factor_term(object, term, ...) + +\method{is_factor_term}{terms}(object, term, ...) + +\method{is_factor_term}{gam}(object, term, ...) + +\method{is_factor_term}{bam}(object, term, ...) + +\method{is_factor_term}{gamm}(object, term, ...) + +\method{is_factor_term}{list}(object, term, ...) +} +\arguments{ +\item{object}{an R object on which method dispatch is performed} + +\item{term}{character; the name of a model term, in the sense of +\code{attr(terms(object), "term.labels")}. Currently not checked to see if the +term exists in the model.} + +\item{...}{arguments passed to other methods.} +} +\value{ +A logical: \code{TRUE} if and only if all variables involved in the term +are factors, otherwise \code{FALSE}. +} +\description{ +Given the name (a term label) of a term in a model, identify if the term is a +factor term or numeric. This is useful when considering interactions, where +terms like \code{fac1:fac2} or \code{num1:fac1} may be requested by the user. Only for +terms of the type \code{fac1:fac2} will this function return \code{TRUE}. +} diff --git a/man/term_variables.Rd b/man/term_variables.Rd new file mode 100644 index 000000000..72712442e --- /dev/null +++ b/man/term_variables.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utililties.R +\name{term_variables} +\alias{term_variables} +\alias{term_variables.terms} +\alias{term_variables.gam} +\alias{term_variables.bam} +\title{Names of variables involved in a specified model term} +\usage{ +term_variables(object, term, ...) + +\method{term_variables}{terms}(object, term, ...) + +\method{term_variables}{gam}(object, term, ...) + +\method{term_variables}{bam}(object, term, ...) +} +\arguments{ +\item{object}{an R object on which method dispatch is performed} + +\item{term}{character; the name of a model term, in the sense of +\code{attr(terms(object), "term.labels")}. Currently not checked to see if the +term exists in the model.} + +\item{...}{arguments passed to other methods.} +} +\value{ +A character vector of variable names. +} +\description{ +Given the name (a term label) of a term in a model, returns the names +of the variables involved in ther term. +} diff --git a/tests/figs/draw-methods/draw-2d-smooth.svg b/tests/figs/draw-methods/draw-2d-smooth.svg index d3202eb0f..3a18e6888 100644 --- a/tests/figs/draw-methods/draw-2d-smooth.svg +++ b/tests/figs/draw-methods/draw-2d-smooth.svg @@ -47,7 +47,7 @@ - + diff --git a/tests/figs/draw-methods/draw-am-with-2d-smooth.svg b/tests/figs/draw-methods/draw-am-with-2d-smooth.svg index 456e92368..1add40fe6 100644 --- a/tests/figs/draw-methods/draw-am-with-2d-smooth.svg +++ b/tests/figs/draw-methods/draw-am-with-2d-smooth.svg @@ -47,7 +47,7 @@ - + diff --git a/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth-with-fixed-scales.svg b/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth-with-fixed-scales.svg index 2e37bfb83..8ac43d94e 100644 --- a/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth-with-fixed-scales.svg +++ b/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth-with-fixed-scales.svg @@ -1886,12 +1886,12 @@ - - - - + + + + diff --git a/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth.svg b/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth.svg index 545956e11..d847478ba 100644 --- a/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth.svg +++ b/tests/figs/draw-methods/draw-am-with-factor-by-variable-smooth.svg @@ -1900,12 +1900,12 @@ - - - - + + + + diff --git a/tests/figs/draw-methods/draw-evaulated-2d-smooth-standard-errors.svg b/tests/figs/draw-methods/draw-evaulated-2d-smooth-standard-errors.svg index 3a1f56cfc..e04d2b1f8 100644 --- a/tests/figs/draw-methods/draw-evaulated-2d-smooth-standard-errors.svg +++ b/tests/figs/draw-methods/draw-evaulated-2d-smooth-standard-errors.svg @@ -38,22 +38,22 @@ - + - - - - + + + + - - + + - + diff --git a/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by-fixed-scales.svg b/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by-fixed-scales.svg index 4c8d11d0e..22a252084 100644 --- a/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by-fixed-scales.svg +++ b/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by-fixed-scales.svg @@ -1678,12 +1678,12 @@ - - - - + + + + diff --git a/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by.svg b/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by.svg index a45255bc1..6e02c4cb8 100644 --- a/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by.svg +++ b/tests/figs/draw-methods/draw-gam-model-with-ranef-smooth-factor-by.svg @@ -1675,12 +1675,12 @@ - - - - + + + + diff --git a/tests/figs/draw-methods/draw-gam-with-select-and-parametric-is-true.svg b/tests/figs/draw-methods/draw-gam-with-select-and-parametric-is-true.svg index 0ccb6aa4f..3fa65e3c4 100644 --- a/tests/figs/draw-methods/draw-gam-with-select-and-parametric-is-true.svg +++ b/tests/figs/draw-methods/draw-gam-with-select-and-parametric-is-true.svg @@ -1436,12 +1436,12 @@ - - - - + + + + diff --git a/tests/figs/draw-methods/draw-gam-without-select-and-parametric-is-true.svg b/tests/figs/draw-methods/draw-gam-without-select-and-parametric-is-true.svg index 545956e11..d847478ba 100644 --- a/tests/figs/draw-methods/draw-gam-without-select-and-parametric-is-true.svg +++ b/tests/figs/draw-methods/draw-gam-without-select-and-parametric-is-true.svg @@ -1900,12 +1900,12 @@ - - - - + + + + diff --git a/tests/figs/draw-methods/draw-issue-39-empty-plots.svg b/tests/figs/draw-methods/draw-issue-39-empty-plots.svg index 520484eaf..6802469d6 100644 --- a/tests/figs/draw-methods/draw-issue-39-empty-plots.svg +++ b/tests/figs/draw-methods/draw-issue-39-empty-plots.svg @@ -772,11 +772,11 @@ - + - + @@ -835,11 +835,11 @@ - + - + diff --git a/tests/figs/draw-methods/draw-std-error-of-2d-smooth.svg b/tests/figs/draw-methods/draw-std-error-of-2d-smooth.svg index 3a1f56cfc..e04d2b1f8 100644 --- a/tests/figs/draw-methods/draw-std-error-of-2d-smooth.svg +++ b/tests/figs/draw-methods/draw-std-error-of-2d-smooth.svg @@ -38,22 +38,22 @@ - + - - - - + + + + - - + + - + diff --git a/tests/figs/test-by-variables/draw-gam-user-select-and-parametric-true.svg b/tests/figs/test-by-variables/draw-gam-user-select-and-parametric-true.svg index 646d21228..976426c89 100644 --- a/tests/figs/test-by-variables/draw-gam-user-select-and-parametric-true.svg +++ b/tests/figs/test-by-variables/draw-gam-user-select-and-parametric-true.svg @@ -505,12 +505,12 @@ - - - - + + + + diff --git a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-1.svg b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-1.svg index b3d5f24bf..dcc16948f 100644 --- a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-1.svg +++ b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-1.svg @@ -36,27 +36,27 @@ - + - - - - - - + + + + + + + - - - - - - - - - + + + + + + + + diff --git a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-2.svg b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-2.svg index f248c8d65..52a9e89a0 100644 --- a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-2.svg +++ b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-2.svg @@ -40,32 +40,32 @@ - + - + - + + - - + + - - + - + - - - - - - + + + + + + diff --git a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-3.svg b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-3.svg index 71601e9ee..92c021275 100644 --- a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-3.svg +++ b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-3.svg @@ -24,49 +24,49 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -78,32 +78,32 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --5 -0 -5 -Effect - - - - - - + + +-5 +0 +5 +Effect + + + + + + te(week,latitude) @@ -117,61 +117,61 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -183,32 +183,32 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --4 -0 -4 -Effect - - - - - - + + +-4 +0 +4 +Effect + + + + + + By: species; sp1 te(week,latitude) @@ -223,48 +223,48 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -276,38 +276,38 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --4 --2 -0 -2 -4 -Effect - - - - - - - - - - + + +-4 +-2 +0 +2 +4 +Effect + + + + + + + + + + By: species; sp2 te(week,latitude) @@ -322,39 +322,42 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -366,38 +369,32 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --0.00050 --0.00025 -0.00000 -0.00025 -0.00050 -Effect - - - - - - - - - - + + +-2e-04 +0e+00 +2e-04 +Effect + + + + + + By: species; sp3 te(week,latitude) @@ -412,39 +409,39 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -456,38 +453,38 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --0.10 --0.05 -0.00 -0.05 -0.10 -Effect - - - - - - - - - - + + +-0.10 +-0.05 +0.00 +0.05 +0.10 +Effect + + + + + + + + + + By: species; sp4 te(week,latitude) @@ -502,60 +499,60 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -567,32 +564,32 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --2 -0 -2 -Effect - - - - - - + + +-2 +0 +2 +Effect + + + + + + By: species; sp5 te(week,latitude) @@ -607,50 +604,50 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -662,32 +659,32 @@ - - - - - - -0 -10 -20 -30 -40 -50 -week + + + + + + +0 +10 +20 +30 +40 +50 +week latitude - - --5 -0 -5 -Effect - - - - - - + + +-5 +0 +5 +Effect + + + + + + By: species; sp6 te(week,latitude) @@ -702,37 +699,37 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -746,18 +743,18 @@ - - - - - - -sp1 -sp2 -sp3 -sp4 -sp5 -sp6 -species + + + + + + +sp1 +sp2 +sp3 +sp4 +sp5 +sp6 +species Partial effect of species diff --git a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-5.svg b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-5.svg index 5c34ddb03..2179458f4 100644 --- a/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-5.svg +++ b/tests/figs/test-hgam-paper-models/hgam-paper-bird-move-model-5.svg @@ -46,32 +46,32 @@ - + - - - - - - + + + + + + - + - - + + - - + + - + @@ -151,30 +151,30 @@ - + - - - - + + + + + - - - + + - - + - + + - - + + - - + + @@ -255,28 +255,28 @@ - - - - - - - - - - - + + + + + + + + + + - + + - + - - - - - - + + + + + + @@ -350,30 +350,30 @@ - + - + - + - + + - - - + - + + @@ -456,28 +456,28 @@ - - + + + - - + - + - - + + + - - + - - - - + + + + @@ -505,7 +505,7 @@ latitude --5 +-5 0 5 Effect @@ -551,28 +551,28 @@ - - - + + + - - - - - - - + + + + + + + - + - - - + + + - - - - + + + + @@ -661,7 +661,7 @@ - + diff --git a/tests/testthat/test-evaluate-parametric-terms.R b/tests/testthat/test-evaluate-parametric-terms.R new file mode 100644 index 000000000..f6e1367b0 --- /dev/null +++ b/tests/testthat/test-evaluate-parametric-terms.R @@ -0,0 +1,73 @@ +# Test evaluate_parametric_terms + +## load packages +library("testthat") +library("gratia") +library("mgcv") + +context("Tests of evaluate_parametric_terms():") +data(gss_vocab, package = "gratia") + +m <- gam(vocab ~ nativeBorn * ageGroup, data = gss_vocab, method = 'ML') + +test_that("evaluate_parametric_terms() works with factor terms", { + ## evaluate parametric terms directly + term <- "nativeBorn" + expect_silent(para <- evaluate_parametric_term(m, term = term)) + expect_s3_class(para, "evaluated_parametric_term") + expect_s3_class(para, "tbl_df") + expect_s3_class(para, "tbl") + expect_s3_class(para, "data.frame") + expect_named(para, + c("term", "type", "value", "partial", + "se", "upper", "lower")) + + expect_error(evaluate_parametric_term(m, term = "foo"), + "Term is not in the parametric part of model: ", + fixed = TRUE) + + expect_warning(evaluate_parametric_term(m, term = c('nativeBorn', 'ageGroup')), + "More than one `term` requested; using the first ", + fixed = TRUE) +}) + + +set.seed(0) +## fake some data... +f1 <- function(x) {exp(2 * x)} +f2 <- function(x) { + 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 +} +f3 <- function(x) {x*0} + +n <- 200 +sig2 <- 4 +x0 <- rep(1:4,50) +x1 <- runif(n, 0, 1) +x2 <- runif(n, 0, 1) +x3 <- runif(n, 0, 1) +e <- rnorm(n, 0, sqrt(sig2)) +y <- 2*x0 + f1(x1) + f2(x2) + f3(x3) + e +df <- data.frame(x0 = x0, x1 = x1, x2 = x2, x3 = x3, y = y, + fx0 = factor(x0)) + +## fit +mod <- gam(y ~ x0 + s(x1) + s(x2) + s(x3), data = df) + +test_that("evaluate_parametric_terms() works with parametric terms", { + ## evaluate parametric terms directly + expect_silent(para <- evaluate_parametric_term(mod, term = "x0")) + expect_s3_class(para, "evaluated_parametric_term") + expect_s3_class(para, "tbl_df") + expect_s3_class(para, "tbl") + expect_s3_class(para, "data.frame") + expect_named(para, c("term","type","value","partial","se","upper","lower")) + + expect_error(evaluate_parametric_term(mod, term = "foo"), + "Term is not in the parametric part of model: ", + fixed = TRUE) + + expect_warning(evaluate_parametric_term(mod, term = c('x0', 'x1')), + "More than one `term` requested; using the first ", + fixed = TRUE) +}) diff --git a/tests/testthat/test-evaluate-smooth-methods.R b/tests/testthat/test-evaluate-smooth-methods.R index c93510028..3513b9491 100644 --- a/tests/testthat/test-evaluate-smooth-methods.R +++ b/tests/testthat/test-evaluate-smooth-methods.R @@ -131,45 +131,6 @@ test_that("evaluate_2d_smooth works for a 2d factor by smooth", { expect_is(sm, "data.frame") }) -test_that("evaluate_parametric_terms() works with parametric terms", { - set.seed(0) - ## fake some data... - f1 <- function(x) {exp(2 * x)} - f2 <- function(x) { - 0.2*x^11*(10*(1-x))^6+10*(10*x)^3*(1-x)^10 - } - f3 <- function(x) {x*0} - - n <- 200 - sig2 <- 4 - x0 <- rep(1:4,50) - x1 <- runif(n, 0, 1) - x2 <- runif(n, 0, 1) - x3 <- runif(n, 0, 1) - e <- rnorm(n, 0, sqrt(sig2)) - y <- 2*x0 + f1(x1) + f2(x2) + f3(x3) + e - df <- data.frame(x0 = x0, x1 = x1, x2 = x2, x3 = x3, y = y) - - ## fit - mod <- gam(y ~ x0 + s(x1) + s(x2) + s(x3), data = df) - - ## evaluate parametric terms directly - expect_silent(para <- evaluate_parametric_term(mod, term = "x0")) - expect_s3_class(para, "evaluated_parametric_term") - expect_s3_class(para, "tbl_df") - expect_s3_class(para, "tbl") - expect_s3_class(para, "data.frame") - expect_named(para, c("term","type","value","partial","se","upper","lower")) - - expect_error(evaluate_parametric_term(mod, term = "foo"), - "Term is not in the parametric part of model: ", - fixed = TRUE) - - expect_warning(evaluate_parametric_term(mod, term = c('x0', 'x1')), - "More than one `term` requested; using the first ", - fixed = TRUE) -}) - test_that("evaluate_fs_smooth() ", { ## simulate example... from ?mgcv::factor.smooth.interaction set.seed(0)