+approx_with_monotonic_spline(data.frame(x = x, y = y), "y", "x", env, "up")x <- sort(rnorm(20, 5, 5)) y <- rnorm(20, 2, 2) env <- new.env() -approx_with_monotonic_spline(data.frame(x = x, y = y), "y", "x", env, TRUE)#> Error in approx_with_monotonic_spline(data.frame(x = x, y = y), "y", "x", env, TRUE): could not find function "approx_with_monotonic_spline"
#> Error in approx_with_monotonic_spline(data.frame(x = x, y = y), "y", "x", env, "up"): could not find function "approx_with_monotonic_spline"
Contents
diff --git a/docs/reference/approx_with_spline.html b/docs/reference/approx_with_spline.html index de77c9d..93e80fe 100644 --- a/docs/reference/approx_with_spline.html +++ b/docs/reference/approx_with_spline.html @@ -89,23 +89,23 @@Approximate spline on data
It aproximates data with spline function by fitting GAM model.
-approx_with_spline(bb_response_data, response_var, pred_var, +approx_with_spline(effect_data, response, predictor, env = parent.frame(), ...)Arguments
| bb_response_data | +effect_data | Blackbox response data, for example pdp curve. |
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| response_var | -Name of response value from bb_response_data. |
+ response | +Name of response value from effect_data. |
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
| pred_var | -Name of predictor value from bb_response_data. |
+ predictor | +Name of predictor value from effect_data. |
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
| env | diff --git a/docs/reference/build_xs_function-1.png b/docs/reference/build_xs_function-1.png new file mode 100644 index 0000000..d3a4aef Binary files /dev/null and b/docs/reference/build_xs_function-1.png differ diff --git a/docs/reference/build_xs_function-2.png b/docs/reference/build_xs_function-2.png new file mode 100644 index 0000000..05bbad1 Binary files /dev/null and b/docs/reference/build_xs_function-2.png differ diff --git a/docs/reference/build_xs_function.html b/docs/reference/build_xs_function.html new file mode 100644 index 0000000..e72dcab --- /dev/null +++ b/docs/reference/build_xs_function.html @@ -0,0 +1,158 @@ + + + + + + + + +
+ | fitted_gam | +Fitted gam model approximating data. |
+
|---|---|
| ... | +Other arguments passed to mgcv::predict.gam method. |
+
Value
+ +Function of one variable.
+ + +Examples
++set.seed(123) +x <- rnorm(20, 5, 5) +z <- rnorm(20, 0, 10) +y <- - sin(x) + z ^ 3 + rnorm(20, 0, 0.1) +data <- data.frame(x, y, z) +blackbox <- randomForest::randomForest(y ~ ., data) + +z_var_response <- pdp::partial(blackbox, "z")#> Error in get_training_data.default(object): The training data could not be extracted from object. Please supply the raw training data using the `train` argument in the call to `partial`.#> Error in approx_with_spline(z_var_response, "yhat", "z"): could not find function "approx_with_spline"#> Error in eval(expr, envir, enclos): object 'z_var_response' not foundz_var_spline <- build_xs_function(z_env, "z")#> Error in build_xs_function(z_env, "z"): could not find function "build_xs_function"#> Error in eval(expr, envir, enclos): object 'z_var_spline' not found#> Error in seq(z_range[1], z_range[2], length.out = 50): object 'z_range' not foundlines(z_var_response)#> Error in lines(z_var_response): object 'z_var_response' not found#> Error in lines(z_axis, z_var_spline(z_axis)): object 'z_axis' not found#> Error in get_training_data.default(object): The training data could not be extracted from object. Please supply the raw training data using the `train` argument in the call to `partial`.#> Error in approx_with_spline(x_var_response, "yhat", "x"): could not find function "approx_with_spline"#> Error in eval(expr, envir, enclos): object 'x_var_response' not foundx_var_spline <- build_xs_function(x_env, "x")#> Error in build_xs_function(x_env, "x"): could not find function "build_xs_function"#> Error in eval(expr, envir, enclos): object 'x_var_spline' not found#> Error in seq(x_range[1], x_range[2], length.out = 50): object 'x_range' not foundlines(x_var_response)#> Error in lines(x_var_response): object 'x_var_response' not found#> Error in lines(x_axis, x_var_spline(x_axis)): object 'x_axis' not found
Helper function for building GLM object with transformed variables.
Helper function for building GLM object with transformed variables.
-build_xspliner(formula, model, data, env = parent.frame(), - alter = list(numeric = "always", factor = "never"), - compare_stat = r_squared)+
build_xspliner(formula, model, data, xf_opts = xf_opts_default, + xs_opts = xs_opts_default, link = "identity", family = "gaussian", + env = parent.frame(), compare_stat = aic)
Arguments
Training data of |
||||||||
| env | -Environment in which optional variables passed into parameters are stored. |
+ xf_opts | +Formula parameters used for factor variable transformatoins inherited from factorMerger package. |
+ |||||
|---|---|---|---|---|---|---|---|---|
| xs_opts | +Predictive model response method and approximation parameters used for quantitative. |
+ |||||||
| link | +Link function that should be used in final model. The passed is used when cannot be extracted from +model. By default 'identity'. See stats::family for possibilities. |
+ |||||||
| family | +Family of response variable that should be used in final model. The passed is used when cannot +be extracted from model. By default 'gaussian'. See stats::family for possibilities. |
|||||||
| alter | -Specifies if each variable transformation should be compared with bare variable usage.
-List of the form: list(numeric = type, factor = type), type one of c('always', 'auto', 'never).
-'auto' option available only for qualitative variable. The better model is specified by |
+ env | +Environment in which optional variables passed into parameters are stored. |
|||||
| compare_stat | diff --git a/docs/reference/index.html b/docs/reference/index.html index 2d6ec77..75e730f 100644 --- a/docs/reference/index.html +++ b/docs/reference/index.html @@ -118,15 +118,15 @@Helper function for building GLM object with transformed variables. |
+ It extracts fitted spline function by xspline_approx_gam. |
||||||
| - + | -It extracts fitted spline function by xspline_approx_gam. |
+ Helper function for building GLM object with transformed variables. |
||||||
@@ -142,9 +142,15 @@ r_squared() + |
Statistics used for better linear model selection |
+ |||||||
| + + | +Default parameters for transition methods |
|||||||
diff --git a/docs/reference/stats.html b/docs/reference/stats.html
index 7cfd58c..e701b03 100644
--- a/docs/reference/stats.html
+++ b/docs/reference/stats.html
@@ -91,14 +91,20 @@ Statistics used for better linear model selectionIf "higher-better" is TRUE then model with higher statistic value is treated as better one. -r_squared(lm_model)+ aic(glm_model) + +hoslem(glm_model) Arguments
+
+
+
+
+
diff --git a/docs/reference/xspline.html b/docs/reference/xspline.html
index 04d05dd..80fe6f7 100644
--- a/docs/reference/xspline.html
+++ b/docs/reference/xspline.html
@@ -92,13 +92,13 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Default parameters for transition methods+While constructing formula interpreted by xspliner package, some parameters may be specified within xs(..) or xf(..) symbols.
+Below are default parameters. See details in xf_opts_default + +xs_opts_default+ + Format+ +An object of class
+
+Contents+
Builds predictive model based GLM.xspline(object, ...) # S3 method for default -xspline(model, response = NULL, data = NULL, - env = parent.frame(), factor_opts = factor_opts_default, - numeric_opts = numeric_opts_default, ...) +xspline(model, lhs = NULL, response = NULL, + predictors = NULL, data = NULL, form = "additive", + env = parent.frame(), ...) # S3 method for formula xspline(formula, model, data = NULL, - env = parent.frame(), ...) + consider = "specials", env = parent.frame(), ...) # S3 method for explainer xspline(explainer, env = parent.frame(), ...)@@ -118,31 +118,40 @@ Ar
| ||||||||
| lhs | +Left-hand side of model formula. Can be transformed response. |
+ |||||||
| response | Name of response variable of |
|||||||
| data | -Training data of |
+ predictors | +Predictor values that should be used in final model. |
|||||
| env | -Environment in which optional variables passed into parameters are stored. |
+ data | +Training data of |
|||||
| factor_opts | -Formula parameters used for factor variable transformatoins inherited from factorMerger package. |
+ form | +Can be 'additive' (default) or 'multiplicative'. Specifies formula form in final model. |
|||||
| numeric_opts | -Predictive model response method and approximation parameters used for numeric + | env | +Environment in which optional variables passed into parameters are stored. variables transformation. See vignette("xspliner") for details. |
|||||
| formula | xspliner-specific formula object. Check vignette("xspliner") for more details. |
|||||||
| consider | +One of |
+ |||||||
| explainer | Object of class 'explainer' (see DALEX package). |
diff --git a/examples/auto_choose_approx.R b/examples/auto_choose_approx.R
index adf386b..5e6c393 100644
--- a/examples/auto_choose_approx.R
+++ b/examples/auto_choose_approx.R
@@ -8,8 +8,8 @@ boston.rf <- randomForest(cmedv ~ lstat + ptratio + age, data = boston)
model_pdp <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "pdp", grid.resolution = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "pdp", grid.resolution = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "pdp", grid.resolution = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "pdp", grid.resolution = 40)) +
age,
model = boston.rf,
data = boston
@@ -19,12 +19,12 @@ model_pdp <- xspline(
# also choose automaticaly whether use bare or approximation
model_pdp_auto <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "pdp", grid.resolution = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "pdp", grid.resolution = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "pdp", grid.resolution = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "pdp", grid.resolution = 40)) +
age,
model = boston.rf,
data = boston,
- alter = list(numeric = 'auto', factor = 'never')
+ alter = list(quantitative = 'consider_lm', quantitative = 'never')
)
summary(model_pdp)
diff --git a/examples/compare_with_gam.R b/examples/compare_with_gam.R
index a454e94..d5547f9 100644
--- a/examples/compare_with_gam.R
+++ b/examples/compare_with_gam.R
@@ -1,5 +1,6 @@
library(randomForest)
library(pdp)
+library(xspliner)
data(boston)
set.seed(101)
@@ -9,8 +10,8 @@ boston.rf <- randomForest(cmedv ~ lstat + ptratio + age, data = boston)
# build xspliner model with specified response method and approximation options
model_pdp <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "pdp", grid.resolution = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "pdp", grid.resolution = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "pdp", grid.resolution = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "pdp", grid.resolution = 40)) +
age,
model = boston.rf,
data = boston
@@ -18,8 +19,8 @@ model_pdp <- xspline(
model_ale <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "ale", K = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "ale", K = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "ale", K = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "ale", K = 40)) +
age,
model = boston.rf,
data = boston
diff --git a/examples/formula_transformation.R b/examples/formula_transformation.R
index d14ed78..100364c 100644
--- a/examples/formula_transformation.R
+++ b/examples/formula_transformation.R
@@ -1,10 +1,10 @@
type <- "pdp"
formula <- log(y) ~
- xs(x, method_opts = list(type = type)) * log(z) + xf(t) + w ^ 2 + log(a) + sqrt(exp(b)) + xs(d)
+ xs(x, effect = list(type = type)) * log(z) + xf(t) + w ^ 2 + log(a) + sqrt(exp(b)) + xs(d)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10),
w = rexp(10), a = rnorm(10), b = rnorm(10), d = rnorm(10))
variable_names <- extract_formula_var_names(formula, data)
-formula_details <- get_formula_details(formula, variable_names)
-special_components_details <- get_special_components_info(formula_details)
-transform_formula_chr(formula_details, special_components_details)
+formula_metadata <- get_formula_metadata(formula, variable_names)
+special_components_details <- collect_specials_metadata(formula_metadata)
+transform_formula_chr(formula_metadata, special_components_details)
diff --git a/examples/inherit_parameters.R b/examples/inherit_parameters.R
index 28b1eda..1112e57 100644
--- a/examples/inherit_parameters.R
+++ b/examples/inherit_parameters.R
@@ -4,10 +4,10 @@ oko <- 10
# construct formula
formula <- log(y) ~
- xs(x, transform_opts = list(k = 6), method_opts = list(type = "pdp", object = oko)) * z + xf(t) + w ^ 2
+ xs(x, effect = list(k = 6), method_opts = list(type = "pdp", object = oko)) * z + xf(t) + w ^ 2
# check if library functions inherits variables from parent.frame()
formula_var_names <- extract_formula_var_names(formula, data)
-formula_details <- get_formula_details(formula, formula_var_names)
-additive_components_details <- get_special_components_info(formula_details)
-transform_formula_chr(formula_details, additive_components_details)
+formula_metadata <- get_formula_metadata(formula, formula_var_names)
+additive_components_details <- collect_specials_metadata(formula_metadata)
+transform_formula_chr(formula_metadata, additive_components_details)
diff --git a/examples/link_examples.R b/examples/link_examples.R
index c462d78..d59a6c6 100644
--- a/examples/link_examples.R
+++ b/examples/link_examples.R
@@ -45,8 +45,8 @@ plot(model, "crim")
# and bare formula
model <- xspline(
- log(ptratio) ~ xs(cmedv, method_opts = list(type = "pdp"), spline_opts = list(k = 10)) +
- xs(crim, method_opts = list(type = "pdp"), spline_opts = list(k = 10)),
+ log(ptratio) ~ xs(cmedv, effect = list(type = "pdp"), spline_opts = list(k = 10)) +
+ xs(crim, effect = list(type = "pdp"), spline_opts = list(k = 10)),
model = model_rf,
data = boston)
plot(model, "cmedv")
@@ -78,7 +78,7 @@ glm(chas ~ cmedv + crim, data = boston, family = binomial()) %>% summary
glm(chas ~ cmedv + crim, data = boston, family = binomial()) %>% summary
model_xs <- xspline(model_rf)
-environment(model_xs)$xs_env_list[["cmedv"]]
+environment(model_xs)$quantitative_transitions[["cmedv"]]
plot(model_xs, "cmedv")
plot(model_xs, "crim")
diff --git a/examples/monotonic_spline.R b/examples/monotonic_spline.R
index 36b56b8..2dfb345 100644
--- a/examples/monotonic_spline.R
+++ b/examples/monotonic_spline.R
@@ -10,11 +10,11 @@ boston.rf <- randomForest(cmedv ~ lstat + ptratio + age, data = boston)
model_pdp <- xspline(
cmedv ~
xs(lstat,
- transform_opts = list(k = 6, increasing = FALSE),
- method_opts = list(type = "pdp", grid.resolution = 60)) +
+ transition = list(k = 6, increasing = FALSE),
+ effect = list(type = "pdp", grid.resolution = 60)) +
xs(ptratio,
- transform_opts = list(k = 4, increasing = FALSE),
- method_opts = list(type = "pdp", grid.resolution = 40)) +
+ transition = list(k = 4, increasing = FALSE),
+ effect = list(type = "pdp", grid.resolution = 40)) +
age,
model = boston.rf,
data = boston
diff --git a/examples/params_test.R b/examples/params_test.R
new file mode 100644
index 0000000..e69de29
diff --git a/examples/simple_graphics.R b/examples/simple_graphics.R
index e4a5cb1..bab46a9 100644
--- a/examples/simple_graphics.R
+++ b/examples/simple_graphics.R
@@ -9,7 +9,7 @@ boston.rf <- randomForest(cmedv ~ rm + lstat + nox, data = boston)
# build xspliner model with specified response method and approximation options
model_pdp <- xspline(
cmedv ~ rm + lstat +
- xs(nox, method_opts = list(type = "pdp", grid.resolution = 100), transform_opts = list(k = 10, bs = "cr")),
+ xs(nox, effect = list(type = "pdp", grid.resolution = 100), transition = list(k = 10, bs = "cr")),
model = boston.rf
)
diff --git a/examples/xspline_objects_passing.R b/examples/xspline_objects_passing.R
index 08ec8f0..ad91ba3 100644
--- a/examples/xspline_objects_passing.R
+++ b/examples/xspline_objects_passing.R
@@ -11,8 +11,20 @@ boston.rf <- randomForest(cmedv ~ lstat + ptratio + age, data = boston)
model <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "pdp", grid.resolution = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "pdp", grid.resolution = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "pdp", grid.resolution = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "pdp", grid.resolution = 40)) +
+ age,
+ model = boston.rf,
+ data = boston
+)
+summary(model)
+
+# when xs has no parameters default one are taken
+
+model <- xspline(
+ cmedv ~
+ xs(lstat) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "pdp", grid.resolution = 40)) +
age,
model = boston.rf,
data = boston
@@ -25,7 +37,17 @@ model <- xspline(
cmedv ~ lstat + age,
model = boston.rf,
data = boston,
- exact = FALSE
+ consider = "all"
+)
+summary(model)
+
+# we can consider whereter to use linear or xs transformation automatically
+model <- xspline(
+ cmedv ~ lstat + ptratio + age,
+ model = boston.rf,
+ data = boston,
+ consider = "all",
+ xs_opts = list(transition = list(alter = "auto"))
)
summary(model)
@@ -40,8 +62,18 @@ summary(model)
model <- xspline(
cmedv ~ .,
model = boston.rf,
- numeric_opts = list(method_opts = list(type = "pdp", grid.resolution = 40), transform_opts = list(k = 4)),
- alter = list(numeric = 'auto')
+ xs_opts = list(
+ effect = list(type = "pdp", grid.resolution = 40),
+ transition = list(k = 4, alter = "auto"))
+)
+summary(model)
+
+model <- xspline(
+ cmedv ~ .,
+ model = boston.rf,
+ xs_opts = list(
+ effect = list(type = "pdp"),
+ transition = list(alter = "auto"))
)
summary(model)
diff --git a/man/approx_with_monotonic_spline.Rd b/man/approx_with_monotonic_spline.Rd
index 43a7cb7..baf8284 100644
--- a/man/approx_with_monotonic_spline.Rd
+++ b/man/approx_with_monotonic_spline.Rd
@@ -4,21 +4,22 @@
\alias{approx_with_monotonic_spline}
\title{Approximate monotonic spline on data}
\usage{
-approx_with_monotonic_spline(bb_response_data, response_var, pred_var,
- env = parent.frame(), increasing, ...)
+approx_with_monotonic_spline(effect_data, response, predictor,
+ env = parent.frame(), monotonic, ...)
}
\arguments{
-\item{response_var}{Name of response value from bb_response_data.}
+\item{response}{Name of response value from effect_data.}
-\item{pred_var}{Name of predictor value from bb_response_data.}
+\item{predictor}{Name of predictor value from effect_data.}
\item{env}{Formula environment that should be used for fitting gam model.}
-\item{increasing}{If TRUE, spline approximation is increasing, if FALSE decreasing.}
+\item{monotonic}{Possible options "up", "down" and "auto. If up the spline is incresing, when down decreasing.
+For auto the better one (based on r.squared statistic) is chosen.}
\item{...}{Other arguments passed to \link{mgcv::s} function.}
-\item{bb_response_data.}{Blackbox response data, for example pdp curve.}
+\item{effect_data.}{Blackbox response data, for example pdp curve.}
}
\value{
Object of class "gam". See \link{mgcv::gamObject}
@@ -30,5 +31,5 @@ It aproximates data with monotonic spline function by fitting GAM model.
x <- sort(rnorm(20, 5, 5))
y <- rnorm(20, 2, 2)
env <- new.env()
-approx_with_monotonic_spline(data.frame(x = x, y = y), "y", "x", env, TRUE)
+approx_with_monotonic_spline(data.frame(x = x, y = y), "y", "x", env, "up")
}
diff --git a/man/approx_with_spline.Rd b/man/approx_with_spline.Rd
index 60e7315..ccc81da 100644
--- a/man/approx_with_spline.Rd
+++ b/man/approx_with_spline.Rd
@@ -4,15 +4,15 @@
\alias{approx_with_spline}
\title{Approximate spline on data}
\usage{
-approx_with_spline(bb_response_data, response_var, pred_var,
+approx_with_spline(effect_data, response, predictor,
env = parent.frame(), ...)
}
\arguments{
-\item{bb_response_data}{Blackbox response data, for example pdp curve.}
+\item{effect_data}{Blackbox response data, for example pdp curve.}
-\item{response_var}{Name of response value from bb_response_data.}
+\item{response}{Name of response value from effect_data.}
-\item{pred_var}{Name of predictor value from bb_response_data.}
+\item{predictor}{Name of predictor value from effect_data.}
\item{env}{Formula environment that should be used for fitting gam model.}
diff --git a/man/get_xs_call.Rd b/man/build_xs_function.Rd
similarity index 77%
rename from man/get_xs_call.Rd
rename to man/build_xs_function.Rd
index 2fc8f27..8491517 100644
--- a/man/get_xs_call.Rd
+++ b/man/build_xs_function.Rd
@@ -1,10 +1,10 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/utils-approximations.R
-\name{get_xs_call}
-\alias{get_xs_call}
+\name{build_xs_function}
+\alias{build_xs_function}
\title{It extracts fitted spline function by \link{xspline_approx_gam}.}
\usage{
-get_xs_call(xs_env, pred_var_name)
+build_xs_function(quantitative_transition, predictor_name)
}
\arguments{
\item{fitted_gam}{Fitted gam model approximating data.}
@@ -28,10 +28,10 @@ blackbox <- randomForest::randomForest(y ~ ., data)
z_var_response <- pdp::partial(blackbox, "z")
z_var_response_approx <- approx_with_spline(z_var_response, "yhat", "z")
z_env <- list(
- blackbox_response_obj = z_var_response,
- blackbox_response_approx = z_var_response_approx
+ effect_outcome = z_var_response,
+ transition_outcome = z_var_response_approx
)
-z_var_spline <- get_xs_call(z_env, "z")
+z_var_spline <- build_xs_function(z_env, "z")
z_range <- attr(z_var_spline, "variable_range")
z_axis <- seq(z_range[1], z_range[2], length.out = 50)
@@ -42,10 +42,10 @@ lines(z_axis, z_var_spline(z_axis))
x_var_response <- pdp::partial(blackbox, "x")
x_var_response_approx <- approx_with_spline(x_var_response, "yhat", "x")
x_env <- list(
- blackbox_response_obj = x_var_response,
- blackbox_response_approx = x_var_response_approx
+ effect_outcome = x_var_response,
+ transition_outcome = x_var_response_approx
)
-x_var_spline <- get_xs_call(x_env, "x")
+x_var_spline <- build_xs_function(x_env, "x")
x_range <- attr(x_var_spline, "variable_range")
x_axis <- seq(x_range[1], x_range[2], length.out = 50)
diff --git a/man/build_xspliner.Rd b/man/build_xspliner.Rd
index 3fd5807..a8e4f59 100644
--- a/man/build_xspliner.Rd
+++ b/man/build_xspliner.Rd
@@ -4,9 +4,9 @@
\alias{build_xspliner}
\title{Helper function for building GLM object with transformed variables.}
\usage{
-build_xspliner(formula, model, data, link = "identity",
- family = "gaussian", env = parent.frame(), alter = list(numeric =
- "always", factor = "never"), compare_stat = r_squared)
+build_xspliner(formula, model, data, xf_opts = xf_opts_default,
+ xs_opts = xs_opts_default, link = "identity", family = "gaussian",
+ env = parent.frame(), compare_stat = aic)
}
\arguments{
\item{formula}{xspliner-specific formula object. Check vignette("xspliner") for more details.}
@@ -15,6 +15,10 @@ build_xspliner(formula, model, data, link = "identity",
\item{data}{Training data of \code{model}.}
+\item{xf_opts}{Formula parameters used for factor variable transformatoins inherited from factorMerger package.}
+
+\item{xs_opts}{Predictive model response method and approximation parameters used for quantitative.}
+
\item{link}{Link function that should be used in final model. The passed is used when cannot be extracted from
model. By default 'identity'. See \link{stats::family} for possibilities.}
@@ -23,10 +27,6 @@ be extracted from model. By default 'gaussian'. See \link{stats::family} for pos
\item{env}{Environment in which optional variables passed into parameters are stored.}
-\item{alter}{Specifies if each variable transformation should be compared with bare variable usage.
-List of the form: list(numeric = type, factor = type), type one of c('always', 'auto', 'never).
-'auto' option available only for qualitative variable. The better model is specified by \code{compare_stat} parameter then.}
-
\item{compare_stat}{Function of linear model (lm function output). Statistic that measures if linear model is better that transformed one.
See \link{stats}.}
}
diff --git a/man/stats.Rd b/man/stats.Rd
index 7f6657e..88ad031 100644
--- a/man/stats.Rd
+++ b/man/stats.Rd
@@ -2,13 +2,18 @@
% Please edit documentation in R/xspline.R
\name{stats}
\alias{stats}
-\alias{r_squared}
+\alias{aic}
+\alias{hoslem}
\title{Statistics used for better linear model selection}
\usage{
-r_squared(lm_model)
+aic(glm_model)
+
+hoslem(glm_model)
}
\arguments{
-\item{lm_model}{Linear model - \code{lm} function output.}
+\item{glm_model}{Linear model - \code{glm} function output.}
+
+\item{family}{Family used for fitting the model.}
}
\description{
Used as \code{compare_stat} parameter in \code{xspline} method.
diff --git a/man/xf_opts_default.Rd b/man/xf_opts_default.Rd
new file mode 100644
index 0000000..9abe44c
--- /dev/null
+++ b/man/xf_opts_default.Rd
@@ -0,0 +1,18 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/xspline.R
+\docType{data}
+\name{xf_opts_default}
+\alias{xf_opts_default}
+\alias{xs_opts_default}
+\title{Default parameters for transition methods}
+\format{An object of class \code{list} of length 2.}
+\usage{
+xf_opts_default
+
+xs_opts_default
+}
+\description{
+While constructing formula interpreted by xspliner package, some parameters may be specified within xs(..) or xf(..) symbols.
+Below are default parameters. See details in \code{vignette("xspliner")}
+}
+\keyword{datasets}
diff --git a/man/xspline.Rd b/man/xspline.Rd
index f0dcb08..9f49ab9 100644
--- a/man/xspline.Rd
+++ b/man/xspline.Rd
@@ -10,13 +10,12 @@
xspline(object, ...)
\method{xspline}{default}(model, lhs = NULL, response = NULL,
- predictors = NULL, data = NULL, env = parent.frame(),
- factor_opts = factor_opts_default,
- numeric_opts = numeric_opts_default, ...)
-
-\method{xspline}{formula}(formula, model, data = NULL, exact = TRUE,
+ predictors = NULL, data = NULL, form = "additive",
env = parent.frame(), ...)
+\method{xspline}{formula}(formula, model, data = NULL,
+ consider = "specials", env = parent.frame(), ...)
+
\method{xspline}{explainer}(explainer, env = parent.frame(), ...)
}
\arguments{
@@ -26,22 +25,23 @@ xspline(object, ...)
\item{model}{Predictive model. Basic model used for extracting predictors transformation.}
+\item{lhs}{Left-hand side of model formula. Can be transformed response.}
+
\item{response}{Name of response variable of \code{model}.}
\item{predictors}{Predictor values that should be used in final model.}
\item{data}{Training data of \code{model}.}
-\item{env}{Environment in which optional variables passed into parameters are stored.}
-
-\item{factor_opts}{Formula parameters used for factor variable transformatoins inherited from factorMerger package.}
+\item{form}{Can be 'additive' (default) or 'multiplicative'. Specifies formula form in final model.}
-\item{numeric_opts}{Predictive model response method and approximation parameters used for numeric
+\item{env}{Environment in which optional variables passed into parameters are stored.
variables transformation. See vignette("xspliner") for details.}
\item{formula}{xspliner-specific formula object. Check vignette("xspliner") for more details.}
-\item{exact}{If TRUE, exact formula call is used. If not all formula variables are altered.}
+\item{consider}{One of \code{c("specials", "all")}. If "specials", only components with xs or xf
+call are considered in transition.}
\item{explainer}{Object of class 'explainer' (see \link{DALEX} package).}
}
diff --git a/tests/testthat/test-model.R b/tests/testthat/test-model.R
index dba7178..906e418 100644
--- a/tests/testthat/test-model.R
+++ b/tests/testthat/test-model.R
@@ -1,7 +1,7 @@
context("test-model")
test_that("xspline return object with correct attributes and values", {
- formula <- y ~ xs(x, method_opts = list(type = "pdp")) * z
+ formula <- y ~ xs(x, effect = list(type = "pdp")) * z
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10))
blackbox <- randomForest::randomForest(y ~ ., data)
model <- xspline(formula, blackbox, data)
@@ -9,13 +9,13 @@ test_that("xspline return object with correct attributes and values", {
expect_true("glm" %in% class(model))
expect_equal(
ls(environment(model$formula)),
- c("response", "xf", "xf_call", "xf_env_list", "xs", "xs_call", "xs_env_list"))
+ c("qualitative_transitions", "quantitative_transitions", "response", "xf", "xf_functions", "xs", "xs_functions"))
expect_equal(deparse(model$formula), "y ~ xs(x) * z")
})
test_that("xspline correctly predicts values", {
set.seed(123)
- formula <- y ~ xs(x, method_opts = list(type = "pdp")) * z
+ formula <- y ~ xs(x, effect = list(type = "pdp")) * z
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10))
blackbox <- randomForest::randomForest(y ~ ., data)
model <- xspline(formula, blackbox, data)
diff --git a/tests/testthat/test-utils-approximations.R b/tests/testthat/test-utils-approximations.R
index 0ecf74e..d6c3015 100644
--- a/tests/testthat/test-utils-approximations.R
+++ b/tests/testthat/test-utils-approximations.R
@@ -2,12 +2,12 @@ context("test-utils-approximations")
test_that("formula for spline approximation is prepared correctly", {
env <- new.env()
- expect_equal(get_spline_formula("y", "x", env), as.formula("y ~ s(x)", env = env))
+ expect_equal(build_approximation_formula("y", "x", env), as.formula("y ~ s(x)", env = env))
- expect_equal(get_spline_formula("y", "x", env, k = 6), as.formula("y ~ s(x, k = 6)", env = env))
+ expect_equal(build_approximation_formula("y", "x", env, k = 6), as.formula("y ~ s(x, k = 6)", env = env))
- params = list(pred_var = "x", response_var = "y", env = env, k = 6)
- expect_equal(do.call(get_spline_formula, params), as.formula("y ~ s(x, k = 6)", env = env))
+ params = list(predictor = "x", response = "y", env = env, k = 6)
+ expect_equal(do.call(build_approximation_formula, params), as.formula("y ~ s(x, k = 6)", env = env))
})
test_that("spline approximation is made correctly with mgcv::gam and mgcv::s", {
@@ -15,22 +15,22 @@ test_that("spline approximation is made correctly with mgcv::gam and mgcv::s", {
data <- data.frame(x = 1:10, y = 11:20)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...) as.formula("y ~ s(x)", env = env),
+ build_approximation_formula = function(response, predictor, env, ...) as.formula("y ~ s(x)", env = env),
expect_true("gam" %in% class(approx_with_spline(data, "y", "x", env)))
)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...) as.formula("y ~ s(x)", env = env),
+ build_approximation_formula = function(response, predictor, env, ...) as.formula("y ~ s(x)", env = env),
expect_equal(approx_with_spline(data, "y", "x", env)$formula, as.formula("y ~ s(x)", env = env))
)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...) as.formula("y ~ s(x, k = 6)", env = env),
+ build_approximation_formula = function(response, predictor, env, ...) as.formula("y ~ s(x, k = 6)", env = env),
expect_equal(approx_with_spline(data, "y", "x", env, k = 6)$smooth[[1]]$bs.dim, 6)
)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...) as.formula("y ~ s(x, k = 6)", env = env),
+ build_approximation_formula = function(response, predictor, env, ...) as.formula("y ~ s(x, k = 6)", env = env),
expect_equal(approx_with_spline(data, "y", "x", env, k = 6)$formula, as.formula("y ~ s(x, k = 6)", env = env))
)
})
@@ -40,13 +40,13 @@ test_that("monotonic spline approximation is made correctly with mgcv::gam and m
data <- data.frame(x = 1:10, y = sort(rnorm(10)))
suppressWarnings({
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...)
+ build_approximation_formula = function(response, predictor, env, ...)
as.formula("y ~ s(x)", env = env),
expect_true("gam" %in% class(approx_with_monotonic_spline(data, "y", "x", env, TRUE)))
)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...)
+ build_approximation_formula = function(response, predictor, env, ...)
as.formula("y ~ s(x)", env = env),
expect_equal(
approx_with_monotonic_spline(data, "y", "x", env, TRUE)$formula,
@@ -54,13 +54,13 @@ test_that("monotonic spline approximation is made correctly with mgcv::gam and m
)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...)
+ build_approximation_formula = function(response, predictor, env, ...)
as.formula("y ~ s(x, k = 6)", env = env),
expect_equal(approx_with_monotonic_spline(data, "y", "x", env, TRUE, k = 6)$smooth[[1]]$bs.dim, 6)
)
with_mock(
- get_spline_formula = function(response_var, pred_var, env, ...)
+ build_approximation_formula = function(response, predictor, env, ...)
as.formula("y ~ s(x, k = 6)", env = env),
expect_equal(
approx_with_monotonic_spline(data, "y", "x", env, TRUE, k = 6)$formula,
@@ -69,125 +69,137 @@ test_that("monotonic spline approximation is made correctly with mgcv::gam and m
})
})
-test_that("prepare_spline_params_pdp correctly gets pdp response and its approximation", {
- formula <- log(y) ~ xs(x, method_opts = list(type = "pdp")) * z + xf(t) + log(a)
- formula_details <- get_formula_details(formula, c("y" ,"x", "z", "t", "a"))
+test_that("prepare_transition_params_pdp correctly gets pdp response and its approximation", {
+ formula <- log(y) ~ xs(x, effect = list(type = "pdp")) * z + xf(t) + log(a)
+ formula_metadata <- get_formula_metadata(formula, c("y" ,"x", "z", "t", "a"))
set.seed(123)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10), a = rexp(10))
blackbox <- randomForest::randomForest(y ~ ., data)
- special_components_details <- get_special_components_info(formula_details)
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(stat = "GIC", value = 3))
+ special_components_details <- collect_specials_metadata(formula_metadata, xs_opts, xf_opts)
- x_var_spline_params <- prepare_spline_params_pdp(formula_details, special_components_details$x, blackbox, data)
+ x_var_spline_params <- prepare_transition_params_pdp(formula_metadata, special_components_details$x, blackbox, data)
- expect_equal(names(x_var_spline_params), c("bb_response_data", "pred_var", "response_var", "env"))
- expect_true("partial" %in% class(x_var_spline_params$bb_response_data))
- expect_equal(colnames(x_var_spline_params$bb_response_data), c("x", "yhat"))
+ expect_equal(names(x_var_spline_params), c("alter", "monotonic", "effect_data", "predictor", "response", "env"))
+ expect_true("partial" %in% class(x_var_spline_params$effect_data))
+ expect_equal(colnames(x_var_spline_params$effect_data), c("x", "yhat"))
})
-test_that("prepare_spline_params_ale correctly gets ale response and its approximation", {
- formula <- log(y) ~ xs(x, method_opts = list(type = "ale")) * z + xf(t) + log(a)
- formula_details <- get_formula_details(formula, c("y" ,"x", "z", "t", "a"))
+test_that("prepare_transition_params_ale correctly gets ale response and its approximation", {
+ formula <- log(y) ~ xs(x, effect = list(type = "ale")) * z + xf(t) + log(a)
+ formula_metadata <- get_formula_metadata(formula, c("y" ,"x", "z", "t", "a"))
set.seed(123)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10), a = rexp(10))
blackbox <- randomForest::randomForest(y ~ ., data)
- special_components_details <- get_special_components_info(formula_details)
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(stat = "GIC", value = 3))
+ special_components_details <- collect_specials_metadata(formula_metadata, xs_opts, xf_opts)
- x_var_spline_params <- prepare_spline_params_ale(formula_details, special_components_details$x, blackbox, data)
+ x_var_spline_params <- prepare_transition_params_ale(formula_metadata, special_components_details$x, blackbox, data)
- expect_equal(names(x_var_spline_params), c("bb_response_data", "pred_var", "response_var", "env"))
- expect_equal("data.frame", class(x_var_spline_params$bb_response_data))
- expect_equal(colnames(x_var_spline_params$bb_response_data), c("x", "yhat"))
+ expect_equal(names(x_var_spline_params), c("alter", "monotonic", "effect_data", "predictor", "response", "env"))
+ expect_equal("data.frame", class(x_var_spline_params$effect_data))
+ expect_equal(colnames(x_var_spline_params$effect_data), c("x", "yhat"))
})
-test_that("numeric_component_env correctly gets response and its approximation", {
- formula <- log(y) ~ xs(x, method_opts = list(type = "pdp")) * z + xf(t) + log(a)
- formula_details <- get_formula_details(formula, c("y" ,"x", "z", "t", "a"))
+test_that("get_quantitative_transition correctly gets response and its approximation", {
+ formula <- log(y) ~ xs(x, effect = list(type = "pdp")) * z + xf(t) + log(a)
+ formula_metadata <- get_formula_metadata(formula, c("y" ,"x", "z", "t", "a"))
set.seed(123)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10), a = rexp(10))
blackbox <- randomForest::randomForest(y ~ ., data)
- special_components_details <- get_special_components_info(formula_details)
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(stat = "GIC", value = 3))
+ special_components_details <- collect_specials_metadata(formula_metadata, xs_opts, xf_opts)
- x_var_approx_env <- numeric_component_env(formula_details, special_components_details$x, blackbox, data)
+ x_var_approx_env <- get_quantitative_transition(formula_metadata, special_components_details$x, blackbox, data)
- expect_equal(names(x_var_approx_env), c("blackbox_response_obj", "blackbox_response_approx"))
- expect_true("partial" %in% class(x_var_approx_env$blackbox_response_obj))
- expect_true("gam" %in% class(x_var_approx_env$blackbox_response_approx))
- expect_equal(colnames(x_var_approx_env$blackbox_response_obj), c("x", "yhat"))
+ expect_equal(names(x_var_approx_env), c("effect_outcome", "transition_outcome"))
+ expect_true("partial" %in% class(x_var_approx_env$effect_outcome))
+ expect_true("glm" %in% class(x_var_approx_env$transition_outcome))
+ expect_equal(colnames(x_var_approx_env$effect_outcome), c("x", "yhat"))
- expect_error(numeric_component_env(formula_details, special_components_details$t, blackbox, data))
+ expect_error(get_quantitative_transition(formula_metadata, special_components_details$t, blackbox, data))
})
-test_that("get_common_components_env correctly gets response and its approximation for all special calls", {
+test_that("get_transitions_outcome correctly gets response and its approximation for all special calls", {
formula <- log(y) ~
- xs(x, method_opts = list(type = "pdp")) * z + xs(t, method_opts = list(type = "pdp", k = 6)) + log(a)
- formula_details <- get_formula_details(formula, c("y" ,"x", "z", "t", "a"))
+ xs(x, effect = list(type = "pdp")) * z + xs(t, effect = list(type = "pdp", k = 6)) + log(a)
+ formula_metadata <- get_formula_metadata(formula, c("y" ,"x", "z", "t", "a"))
set.seed(123)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10), a = rexp(10))
blackbox <- randomForest::randomForest(y ~ ., data)
- special_components_details <- get_special_components_info(formula_details)
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(stat = "GIC", value = 3))
+ special_components_details <- collect_specials_metadata(formula_metadata, xs_opts, xf_opts)
- vars_approx_env <- get_common_components_env(formula_details, special_components_details, blackbox, data)
+ vars_approx_env <- get_transitions_outcome(formula_metadata, special_components_details, blackbox, data)
- expect_equal(names(vars_approx_env), c("xs_env", "xf_env"))
- expect_equal(vars_approx_env$xf_env, list())
- expect_equal(names(vars_approx_env$xs_env$x), c("blackbox_response_obj", "blackbox_response_approx"))
- expect_equal(names(vars_approx_env$xs_env$t), c("blackbox_response_obj", "blackbox_response_approx"))
- expect_equal(colnames(vars_approx_env$xs_env$x$blackbox_response_obj), c("x", "yhat"))
- expect_equal(colnames(vars_approx_env$xs_env$t$blackbox_response_obj), c("t", "yhat"))
+ expect_equal(names(vars_approx_env), c("quantitative", "qualitative"))
+ expect_equal(vars_approx_env$qualitative_transition, NULL)
+ expect_equal(names(vars_approx_env$quantitative$x), c("effect_outcome", "transition_outcome"))
+ expect_equal(names(vars_approx_env$quantitative$t), c("effect_outcome", "transition_outcome"))
+ expect_equal(colnames(vars_approx_env$quantitative$x$effect_outcome), c("x", "yhat"))
+ expect_equal(colnames(vars_approx_env$quantitative$t$effect_outcome), c("t", "yhat"))
})
-test_that("get_xs_call correctly use gam object for prediction", {
+test_that("build_xs_function correctly use gam object for prediction", {
set.seed(123)
x = rnorm(10)
y = 2 * x + rnorm(10, 0, 0.001)
data <- data.frame(x, y)
- xs_env <- list()
- xs_env$blackbox_response_approx <- mgcv::gam(y ~ x, data = data)
- xs_env$blackbox_response_obj <- data.frame(x, y)
- xs <- get_xs_call(xs_env, "x")
+ quantitative_transition <- list()
+ quantitative_transition$transition_outcome <- mgcv::gam(y ~ x, data = data)
+ quantitative_transition$effect_outcome <- data.frame(x, y)
+ xs <- build_xs_function(quantitative_transition, "x")
expect_equivalent(round(xs(1)), 2)
- expect_equal(attr(xs, "variable_range"), range(xs_env$blackbox_response_obj$x))
+ expect_equal(attr(xs, "variable_range"), range(quantitative_transition$effect_outcome$x))
- expect_error(suppressWarnings(get_xs_call(xs_env, "t")(1)))
+ expect_error(suppressWarnings(build_xs_function(quantitative_transition, "t")(1)))
})
# (todo)
-# test_that("get_xf_call correctly use gam object for prediction", {
+# test_that("build_xs_function correctly use gam object for prediction", {
# })
-test_that("is_lm_better_than_approx correctly chooses model", {
+test_that("is_lm_better_than_xs correctly chooses model", {
x = 1:10
y = 2 * x + rnorm(10, 0, 0.001)
data <- data.frame(x, y)
approx_fun <- sin
- expect_true(is_lm_better_than_approx(data, "y", "x", approx_fun, r_squared))
+ expect_true(is_lm_better_than_xs(data, "y", "x", approx_fun, gaussian(), aic))
y = x ^ 2 + rnorm(10, 0, 0.001)
data <- data.frame(x, y)
approx_fun <- function(x) x ^ 2
- expect_false(is_lm_better_than_approx(data, "y", "x", approx_fun, r_squared))
+ expect_false(is_lm_better_than_xs(data, "y", "x", approx_fun, gaussian(), aic))
})
test_that("correct_improved_components changes calls", {
- formula <- y ~ xs(x, method_opts = list(type = "pdp")) + log(a)
- formula_details <- get_formula_details(formula, c("y" ,"x", "a"))
+ formula <- y ~ xs(x, effect = list(type = "pdp")) + log(a)
+ formula_metadata <- get_formula_metadata(formula, c("y" ,"x", "a"))
x = 1:10
data <- data.frame(y = 2 * x + rnorm(10, 0, 0.1), x, a = rexp(10))
- special_components_details <- get_special_components_info(formula_details)
- xs <- sin
- xf <- function(x) x
- alter <- function(type) list(numeric = type)
- expect_equal(
- correct_improved_components(alter('always'), r_squared, xs, xf, special_components_details, data, "log(y)"),
- special_components_details)
- expect_equal(
- correct_improved_components(alter('auto'), r_squared, xs, xf, special_components_details, data, "y")$x$new_call,
- "x")
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(stat = "GIC", value = 3))
+ special_components_details <- collect_specials_metadata(formula_metadata, xs_opts, xf_opts)
- data <- data.frame(y = sin(x) + rnorm(10, 0, 0.1), x, a = rexp(10))
expect_equal(
- correct_improved_components(alter('auto'), r_squared, xs, xf, special_components_details, data, "y"),
+ correct_improved_components(special_components_details, "x"),
special_components_details)
+ expect_equal(
+ correct_improved_components(special_components_details, "y")$x$new_call, "x")
})
diff --git a/tests/testthat/test-utils-formula-build.R b/tests/testthat/test-utils-formula-build.R
index 9967a1b..dedc757 100644
--- a/tests/testthat/test-utils-formula-build.R
+++ b/tests/testthat/test-utils-formula-build.R
@@ -3,33 +3,33 @@ context("test-utils-formula-build")
test_that("raw variable names correspond to additive components", {
type <- "pdp"
formula <- log(y) ~
- xs(x, method_opts = list(type = type)) * z + xf(t) + w ^ 2 + I(z ^ 2)
+ xs(x, effect = list(type = type)) * z + xf(t) + w ^ 2 + I(z ^ 2)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10), w = rexp(10))
formula_terms <- terms.formula(formula, specials = c("xs", "xf"))
# (todo) test shows that functionality doesn't work when variables are duplicated
expect_equal(
- get_formula_raw_components(formula_terms),
- c("xs(x, method_opts = list(type = type))", "z", "xf(t)", "w", "I(z^2)")
+ get_formula_single_components(formula_terms),
+ c("xs(x, effect = list(type = type))", "z", "xf(t)", "w", "I(z^2)")
)
data$a <- rnorm(10)
data$b <- rnorm(10)
formula_2 <- log(y) ~
- xs(x, method_opts = list(type = type)) * log(z) + xf(t) + w ^ 2 + log(a) + sqrt(exp(b))
+ xs(x, effect = list(type = type)) * log(z) + xf(t) + w ^ 2 + log(a) + sqrt(exp(b))
formula_terms <- terms.formula(formula_2, specials = c("xs", "xf"))
expect_equal(
- get_formula_raw_components(formula_terms),
- c("xs(x, method_opts = list(type = type))", "log(z)", "xf(t)", "w", "log(a)", "sqrt(exp(b))")
+ get_formula_single_components(formula_terms),
+ c("xs(x, effect = list(type = type))", "log(z)", "xf(t)", "w", "log(a)", "sqrt(exp(b))")
)
})
test_that("formula variables are extracted properly", {
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10), t = runif(10), w = rexp(10))
is_centered <- FALSE
- formula_1 <- y ~ log(x) + xs(z, transform_opts = list(k = 6))
+ formula_1 <- y ~ log(x) + xs(z, transition = list(k = 6))
formula_2 <- log(y) ~
- xs(x, transform_opts = list(k = 6), method_opts = list(type = "pdp", center = is_centered)) * z + xf(t) + w ^ 2
+ xs(x, transition = list(k = 6), effect = list(type = "pdp", center = is_centered)) * z + xf(t) + w ^ 2
expect_equal(extract_formula_var_names(formula_1, data), c("y", "x", "z"))
expect_equal(extract_formula_var_names(formula_2, data), c("y", "x", "z", "t", "w"))
@@ -40,86 +40,90 @@ test_that("formula variables are extracted properly", {
x <- rnorm(10)
y <- x + rnorm(10, 0, 0.001)
z <- x ^ 2 + rnorm(10, 0, 0.001)
- formula_3 <- y ~ log(x, method_opts = list(type = type)) + xs(z, transform_opts = list(k = 6))
+ formula_3 <- y ~ log(x, effect = list(type = type)) + xs(z, transition = list(k = 6))
expect_equal(suppressWarnings(extract_formula_var_names(formula_3)), c("y", "x", "z"))
# (todo) should z be duplicated?
type <- "pdp"
formula_4 <- log(y) ~
- xs(x, method_opts = list(type = type)) * z + xf(t) + w ^ 2 + z ^ 2
+ xs(x, effect = list(type = type)) * z + xf(t) + w ^ 2 + z ^ 2
expect_equal(extract_formula_var_names(formula_4, data), c("y", "x", "z", "t", "w"))
})
-test_that("get_formula_details returns formula info in correct form", {
- # get_formula_details depends on other functions -> use with_mock
+test_that("get_formula_metadata returns formula info in correct form", {
+ # get_formula_metadata depends on other functions -> use with_mock
is_centered <- FALSE
formula <- log(y) ~
- xs(x, transform_opts = list(k = 6), method_opts = list(type = "pdp", center = is_centered)) * z + xf(t) + w ^ 2
+ xs(x, transition = list(k = 6), effect = list(type = "pdp", center = is_centered)) * z + xf(t) + w ^ 2
variable_names <- c("y", "x", "z", "t", "w")
- formula_details <- get_formula_details(formula, variable_names)
-
- expect_equal(formula_details$formula, formula)
- expect_equal(formula_details$response, "y")
- expect_equal(formula_details$predictors, c("x", "z", "t", "w"))
- expect_equal(formula_details$lhs, "log(y)")
- expect_equal(formula_details$xs_variables, "x")
- expect_equal(formula_details$xf_variables, "t")
+ formula_metadata <- get_formula_metadata(formula, variable_names)
+
+ expect_equal(formula_metadata$formula, formula)
+ expect_equal(formula_metadata$response, "y")
+ expect_equal(formula_metadata$predictors, c("x", "z", "t", "w"))
+ expect_equal(formula_metadata$lhs, "log(y)")
+ expect_equal(formula_metadata$xs_variables, "x")
+ expect_equal(formula_metadata$xf_variables, "t")
expect_identical(
- formula_details$additive_components,
- c("xs(x, transform_opts = list(k = 6), method_opts = list(type = \"pdp\", center = is_centered))",
+ formula_metadata$additive_components,
+ c("xs(x, transition = list(k = 6), effect = list(type = \"pdp\", center = is_centered))",
"z", "xf(t)", "w")
)
})
-test_that("prepare_call transforms component into simple form", {
- expect_equal(prepare_call("log(x)"), "log(x)")
- expect_equal(prepare_call("x ^ 2"), "x ^ 2")
- expect_equal(prepare_call("I(x ^ 2)"), "I(x ^ 2)")
- expect_equal(prepare_call("xs(x)"), "xs(x)")
- expect_equal(prepare_call("xf(x)"), "xf(x)")
- expect_equal(prepare_call("xs(var_name)"), "xs(var_name)")
- expect_equal(prepare_call("xs(x, method_opts = list(type = 'pdp'))"), "xs(x)")
- expect_equal(prepare_call("xs(x ^ 2)"), "xs(x ^ 2)")
- expect_equal(prepare_call("xs(x ^ 2, method_opts = list(type = 'pdp'))"), "xs(x ^ 2)")
+test_that("clear_special_component transforms component into simple form", {
+ expect_equal(clear_special_component("log(x)"), "log(x)")
+ expect_equal(clear_special_component("x ^ 2"), "x ^ 2")
+ expect_equal(clear_special_component("I(x ^ 2)"), "I(x ^ 2)")
+ expect_equal(clear_special_component("xs(x)"), "xs(x)")
+ expect_equal(clear_special_component("xf(x)"), "xf(x)")
+ expect_equal(clear_special_component("xs(var_name)"), "xs(var_name)")
+ expect_equal(clear_special_component("xs(x, effect = list(type = 'pdp'))"), "xs(x)")
+ expect_equal(clear_special_component("xs(x ^ 2)"), "xs(x ^ 2)")
+ expect_equal(clear_special_component("xs(x ^ 2, effect = list(type = 'pdp'))"), "xs(x ^ 2)")
})
test_that("formula component parameters are extracted correctly", {
env_0 <- new.env()
env_1 <- new.env() # parent.frame as parent env
env_1$a <- 1
- env_1$type <- "pdp"
+ env_1$type <- "foo"
env_2 <- as.environment(list(a = 1, type = "pdp")) # empty env as parent env
additive_component_1 <- "xf(x)"
- additive_component_2 <- "xs(x, method_opts = list(type = 'pdp'))"
- additive_component_3 <- "xs(x, method_opts = list(type = type))"
- additive_component_4 <- "xs(x, method_opts = list(type = type), transform_opts = list(k = a))"
+ additive_component_2 <- "xs(x, effect = list(type = 'ale'))"
+ additive_component_3 <- "xs(x, effect = list(type = type))"
+ additive_component_4 <- "xs(x, effect = list(type = type), transition = list(k = a))"
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(alter = "never", stat = "GIC", value = 3))
expect_identical(
- get_component_params(additive_component_1, env_0),
- list(transform_opts = NULL, method_opts = NULL)
+ get_component_params(additive_component_1, xs_opts, xf_opts, env_0),
+ list(transition = xf_opts$transition, effect = xf_opts$effect)
)
expect_identical(
- get_component_params(additive_component_2, env_0),
- list(transform_opts = NULL, method_opts = list(type = "pdp"))
+ get_component_params(additive_component_2, xs_opts, xf_opts, env_0),
+ list(transition = xs_opts$transition, effect = list(type = "ale"))
)
expect_error(
- get_component_params(additive_component_3, env_0)
+ get_component_params(additive_component_3, xs_opts, xf_opts, env_0)
)
expect_identical(
- get_component_params(additive_component_3, env_1),
- list(transform_opts = NULL, method_opts = list(type = "pdp"))
+ get_component_params(additive_component_3, xs_opts, xf_opts, env_1),
+ list(transition = xs_opts$transition, effect = list(type = "foo"))
)
expect_identical(
- get_component_params(additive_component_4, env_1),
- list(transform_opts = list(k = 1), method_opts = list(type = "pdp"))
+ get_component_params(additive_component_4, xs_opts, xf_opts, env_1),
+ list(transition = list(k = 1, alter = "always", monotonic = "not"), effect = list(type = "foo"))
)
expect_error(
- get_component_params(additive_component_3, env_2)
+ get_component_params(additive_component_3, xs_opts, xf_opts, env_2)
)
expect_error(
- get_component_params(additive_component_4, env_2)
+ get_component_params(additive_component_4, xs_opts, xf_opts, env_2)
)
})
@@ -128,98 +132,109 @@ test_that("additive component details are extracted and stored correctly", {
env_0 <- new.env()
env_1 <- new.env()
env_1$a <- 1
- env_1$type <- "pdp"
+ env_1$type <- "foo"
additive_component_1 <- "xf(x)"
- additive_component_2 <- "xs(x, method_opts = list(type = 'pdp'))"
- additive_component_3 <- "xs(x, method_opts = list(type = type))"
- additive_component_4 <- "xs(x, method_opts = list(type = type), transform_opts = list(k = a))"
+ additive_component_2 <- "xs(x, effect = list(type = 'pdp'))"
+ additive_component_3 <- "xs(x, effect = list(type = type))"
+ additive_component_4 <- "xs(x, effect = list(type = type), transition = list(k = a))"
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(alter = "newer", stat = "GIC", value = 3))
expect_equal(
- get_special_component_details("x", additive_component_1, env_0),
+ get_special_component_metadata("x", additive_component_1, xs_opts, xf_opts, env_0),
list(var = "x", call = "xf(x)", new_call = "xf(x)",
- call_fun = "xf", transform_opts = NULL, method_opts = NULL)
+ call_fun = "xf", transition = xf_opts$transition, effect = xf_opts$effect)
)
expect_equal(
- get_special_component_details("x", additive_component_2, env_0),
- list(var = "x", call = "xs(x, method_opts = list(type = 'pdp'))",
- new_call = "xs(x)", call_fun = "xs", transform_opts = NULL, method_opts = list(type = "pdp"))
+ get_special_component_metadata("x", additive_component_2, xs_opts, xf_opts, env_0),
+ list(var = "x", call = "xs(x, effect = list(type = 'pdp'))",
+ new_call = "xs(x)", call_fun = "xs", transition = xs_opts$transition, effect = list(type = "pdp"))
)
expect_error(
- get_special_component_details("x", additive_component_3, env_0)
+ get_special_component_metadata("x", additive_component_3, xs_opts, xf_opts, env_0)
)
expect_equal(
- get_special_component_details("x", additive_component_3, env_1),
- list(var = "x", call = "xs(x, method_opts = list(type = type))", new_call = "xs(x)",
- call_fun = "xs", transform_opts = NULL, method_opts = list(type = "pdp"))
+ get_special_component_metadata("x", additive_component_3, xs_opts, xf_opts, env_1),
+ list(var = "x", call = "xs(x, effect = list(type = type))", new_call = "xs(x)",
+ call_fun = "xs", transition = xs_opts$transition, effect = list(type = "foo"))
)
expect_equal(
- get_special_component_details("x", additive_component_4, env_1),
- list(var = "x", call = "xs(x, method_opts = list(type = type), transform_opts = list(k = a))", new_call = "xs(x)",
- call_fun = "xs", transform_opts = list(k = 1), method_opts = list(type = "pdp"))
+ get_special_component_metadata("x", additive_component_4, xs_opts, xf_opts, env_1),
+ list(var = "x", call = "xs(x, effect = list(type = type), transition = list(k = a))", new_call = "xs(x)",
+ call_fun = "xs", transition = list(k = 1, alter = "always", monotonic = "not"), effect = list(type = "foo"))
)
})
-test_that("get_special_components_info properly identifies special components and extracts its details", {
- formula_details <- list(
- formula = log(y) ~ xs(x, method_opts = list(type = "type")) * z + xf(t) + log(a) + xs(d),
+test_that("collect_specials_metadata properly identifies special components and extracts its details", {
+ formula_metadata <- list(
+ formula = log(y) ~ xs(x, effect = list(type = "type")) * z + xf(t) + log(a) + xs(d),
response = "y", predictors = c("x", "z", "t", "a", "d"),
lhs = "log(y)",
- rhs = "xs(x, method_opts = list(type = \"type\")) * z + xf(t) + log(a) + xs(d)",
- additive_components = c("xs(x, method_opts = list(type = \"type\"))", "z", "xf(t)", "log(a)", "xs(d)"),
+ rhs = "xs(x, effect = list(type = \"type\")) * z + xf(t) + log(a) + xs(d)",
+ additive_components = c("xs(x, effect = list(type = \"type\"))", "z", "xf(t)", "log(a)", "xs(d)"),
xs_variables = c("x", "d"), xf_variables = "t", xs_variables_idx = c(1, 5), xf_variables_idx = 3)
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(stat = "GIC", value = 3))
- special_components_info <- get_special_components_info(formula_details)
+ special_components_info <- collect_specials_metadata(formula_metadata, xs_opts, xf_opts)
expect_equal(names(special_components_info), c("x", "d", "t"))
expect_equal(
special_components_info$x,
- list(var = "x", call = "xs(x, method_opts = list(type = \"type\"))",
- new_call = "xs(x)", call_fun = "xs", transform_opts = NULL, method_opts = list(type = "type"))
+ list(var = "x", call = "xs(x, effect = list(type = \"type\"))",
+ new_call = "xs(x)", call_fun = "xs", transition = xs_opts$transition, effect = list(type = "type"))
)
})
test_that("formula last string form is correct", {
- formula_details <- list(
- formula = log(y) ~ xs(x, method_opts = list(type = "type")) * z + xf(t) + log(a),
+ formula_metadata <- list(
+ formula = log(y) ~ xs(x, effect = list(type = "type")) * z + xf(t) + log(a),
response = "y", predictors = c("x", "z", "t", "a"),
lhs = "log(y)",
- rhs = "xs(x, method_opts = list(type = \"type\")) * z + xf(t) + log(a)",
- additive_components = c("xs(x, method_opts = list(type = \"type\"))", "z", "xf(t)", "log(a)"),
+ rhs = "xs(x, effect = list(type = \"type\")) * z + xf(t) + log(a)",
+ additive_components = c("xs(x, effect = list(type = \"type\"))", "z", "xf(t)", "log(a)"),
xs_variables = "x", xf_variables = "t", xs_variables_idx = 1, xf_variables_idx = 3)
special_component_info <- list(
- x = list(var = "x", call = "xs(x, method_opts = list(type = \"type\"))",
- new_call = "xs(x)", transform_opts = NULL, method_opts = list(type = "type")),
+ x = list(var = "x", call = "xs(x, effect = list(type = \"type\"))",
+ new_call = "xs(x)", transition = list(alter = "auto"), effect = list(type = "type")),
t = list(var = "t", call = "xf(t)",
- new_call = "xf(t)", transform_opts = NULL, method_opts = NULL))
+ new_call = "xf(t)", transition = list(stat = "GIC"), effect = list(type = "fM")))
- expect_equal(transform_formula_chr(formula_details, special_component_info), "log(y) ~ xs(x) * z + xf(t) + log(a)")
+ expect_equal(transform_formula_chr(formula_metadata, special_component_info), "log(y) ~ xs(x) * z + xf(t) + log(a)")
})
test_that("transformed_formula_object returns correct formula form and environment", {
- formula <- log(y) ~ xs(x, method_opts = list(type = "pdp")) * z + xf(t, method_opts = list(type = "ice")) + log(a)
- formula_details <- get_formula_details(formula, c("y" ,"x", "z", "t", "a"))
+ formula <- log(y) ~ xs(x, effect = list(type = "pdp"), transition = list(alter = "auto")) * z +
+ xf(t, effect = list(type = "fM")) + log(a)
+ formula_metadata <- get_formula_metadata(formula, c("y" ,"x", "z", "t", "a"))
set.seed(123)
data <- data.frame(y = rnorm(10, 2), x = rnorm(10), z = rnorm(10, 10),
t = factor(sample(LETTERS[1:2], 10, replace = TRUE)), a = rexp(10))
- alter <- list(numeric = 'always', factor = 'never')
blackbox <- randomForest::randomForest(y ~ ., data)
+ xs_opts <- list(effect = list(type = "pdp"),
+ transition = list(alter = "always", monotonic = "not"))
+ xf_opts <- list(effect = list(type = "fM"),
+ transition = list(alter = "never", stat = "GIC", value = 3))
-
- transformed_formula <- transformed_formula_object(formula_details, blackbox, data, alter)
+ transformed_formula <- transformed_formula_object(formula_metadata, blackbox, data, gaussian(), xs_opts, xf_opts, aic)
env <- attr(transformed_formula, ".Environment")
expect_true(inherits(transformed_formula, "formula"))
expect_true(all(c("xf", "xs") %in% ls(env)))
expect_equal(length(env$xs), 1)
expect_equal(length(env$xf), 1)
- alter <- list(numeric = 'auto', factor = 'never')
compare_stat <- function(lm_model) 1
attr(compare_stat, "higher-better") <- TRUE
- transformed_formula <- transformed_formula_object(formula_details, blackbox, data, alter, compare_stat)
+ transformed_formula <- transformed_formula_object(formula_metadata, blackbox, data, gaussian(),
+ xs_opts, xf_opts, compare_stat)
env <- attr(transformed_formula, ".Environment")
expect_true(inherits(transformed_formula, "formula"))
diff --git a/vignettes/xspliner.Rmd b/vignettes/xspliner.Rmd
index b736868..7086af1 100644
--- a/vignettes/xspliner.Rmd
+++ b/vignettes/xspliner.Rmd
@@ -43,7 +43,7 @@ In each case, we get a single variable function, which should explain the impact
The following pictures show the `ptration` impact on `cmedv` in some randomForest model based on Boston Housing Data. Below curves are obtained by the approach of the pdp and ale methods.
-```{r include = FALSE}
+```{r include = FALSE, message = FALSE}
data(boston)
set.seed(123)
@@ -53,16 +53,16 @@ boston.rf <- randomForest(cmedv ~ lstat + ptratio + age, data = boston)
# build xspline model with specified response method and approximation options
model_pdp <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "pdp", grid.resolution = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "pdp", grid.resolution = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "pdp", grid.resolution = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "pdp", grid.resolution = 40)) +
age,
model = boston.rf
)
model_ale <- xspline(
cmedv ~
- xs(lstat, transform_opts = list(k = 6), method_opts = list(type = "ale", K = 60)) +
- xs(ptratio, transform_opts = list(k = 4), method_opts = list(type = "ale", K = 40)) +
+ xs(lstat, transition = list(k = 6), effect = list(type = "ale", K = 60)) +
+ xs(ptratio, transition = list(k = 4), effect = list(type = "ale", K = 40)) +
age,
model = boston.rf
)
@@ -136,7 +136,7 @@ As the algoritm goes threw creating response function and its approximation we n
#### Specifying which method should we use to build response function
```
-method_opts = list(
+effect = list(
type =