Skip to content

Commit

Permalink
insight::get_data issue with subset argument provided via eval(parse(…
Browse files Browse the repository at this point in the history 
…text=...)) (#956)

* insight::get_data issue with subset argument provided via eval(parse(text=...))
Fixes #819

* test

* news

* fix

* add test

* style

* docs

* fix

* lintr
  • Loading branch information
@strengejacke
strengejacke authored Nov 4, 2024
1 parent c9b0ba8 commit e023a26
Show file tree
Hide file tree
Showing 6 changed files with 93 additions and 56 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Type: Package
Package: insight
Title: Easy Access to Model Information for Various Model Objects
Version: 0.99.0.6
Version: 0.99.0.7
Authors@R:
c(person(given = "Daniel",
family = "Lüdecke",
Expand Down
5 changes: 5 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,8 @@

* All deprecated arguments have been removed.

* The `table_width` argument in `export_table()` now defaults to `"auto"`.

## General

* `get_dispersion()` is now an exported function.
Expand Down Expand Up @@ -31,6 +33,9 @@
* `clean_parameters()` now uses the correct labels for the random effects
variances (`"SD/Cor"` has changed to `"Var/Cov"`).

* When `get_data()` could not properly evaluate the subset of a data set, it
now returns an informative warning and no longer errors.

# insight 0.20.5

## General
Expand Down
34 changes: 18 additions & 16 deletions R/format_value.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -44,16 +44,16 @@
#' format_value(1.2)
#' format_value(1.2012313)
#' format_value(c(0.0045, 234, -23))
#' format_value(c(0.0045, .12, .34))
#' format_value(c(0.0045, .12, .34), as_percent = TRUE)
#' format_value(c(0.0045, .12, .34), digits = "scientific")
#' format_value(c(0.0045, .12, .34), digits = "scientific2")
#' format_value(c(0.045, .12, .34), lead_zero = FALSE)
#' format_value(c(0.0045, 0.12, 0.34))
#' format_value(c(0.0045, 0.12, 0.34), as_percent = TRUE)
#' format_value(c(0.0045, 0.12, 0.34), digits = "scientific")
#' format_value(c(0.0045, 0.12, 0.34), digits = "scientific2")
#' format_value(c(0.045, 0.12, 0.34), lead_zero = FALSE)
#'
#' # default
#' format_value(c(0.0045, .123, .345))
#' format_value(c(0.0045, 0.123, 0.345))
#' # significant figures
#' format_value(c(0.0045, .123, .345), digits = "signif")
#' format_value(c(0.0045, 0.123, 0.345), digits = "signif")
#'
#' format_value(as.factor(c("A", "B", "A")))
#' format_value(iris$Species)
Expand Down Expand Up @@ -112,8 +112,8 @@ format_value.numeric <- function(x,
style_negative = "hyphen",
...) {
# check input
style_positive <- match.arg(style_positive, choices = c("none", "plus", "space"))
style_negative <- match.arg(style_negative, choices = c("hyphen", "minus", "parens"))
style_positive <- validate_argument(style_positive, c("none", "plus", "space"))
style_negative <- validate_argument(style_negative, c("hyphen", "minus", "parens"))

if (protect_integers) {
out <- .format_value_unless_integer(
Expand Down Expand Up @@ -224,7 +224,13 @@ format_percent <- function(x, ...) {



.format_value <- function(x, digits = 2, .missing = "", .width = NULL, .as_percent = FALSE, .zap_small = FALSE, ...) {
.format_value <- function(x,
digits = 2,
.missing = "",
.width = NULL,
.as_percent = FALSE,
.zap_small = FALSE,
...) {
# proper character NA
if (is.na(.missing)) .missing <- NA_character_

Expand All @@ -248,9 +254,7 @@ format_percent <- function(x, ...) {
}
} else if (is.character(digits) && grepl("scientific", digits, fixed = TRUE)) {
digits <- tryCatch(
expr = {
as.numeric(gsub("scientific", "", digits, fixed = TRUE))
},
as.numeric(gsub("scientific", "", digits, fixed = TRUE)),
error = function(e) {
5
}
Expand All @@ -259,9 +263,7 @@ format_percent <- function(x, ...) {
x <- sprintf("%.*e", digits, x)
} else if (is.character(digits) && grepl("signif", digits, fixed = TRUE)) {
digits <- tryCatch(
expr = {
as.numeric(gsub("signif", "", digits, fixed = TRUE))
},
as.numeric(gsub("signif", "", digits, fixed = TRUE)),
error = function(e) {
NA
}
Expand Down
54 changes: 30 additions & 24 deletions R/get_data.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -114,7 +114,7 @@ get_data <- function(x, ...) {
out <- tryCatch(
{
# recover data frame from environment
dat <- .recover_data_from_environment(x, data_name = data_name)
dat <- .recover_data_from_environment(x, data_name = data_name, verbose = verbose)
# for metafor, we need to add weights...
if (inherits(x, c("rma.uni", "rma"))) {
## TODO: check if we need to do this for other meta-analysis packages, too
Expand Down Expand Up @@ -147,7 +147,8 @@ get_data <- function(x, ...) {
vars <- c(vars, find_offset(x))
# subset?
if (!is.null(model_call$subset)) {
vars <- c(vars, all.vars(model_call$subset))
subset_vars <- .safe(all.vars(model_call$subset))
vars <- c(vars, subset_vars)
}
vars <- unique(vars)
# if "additional_variables" is TRUE, keep *all* variables from original
Expand Down Expand Up @@ -214,7 +215,7 @@ get_data <- function(x, ...) {

# return data from a data frame that is in the environment,
# and subset the data, if necessary
.recover_data_from_environment <- function(x, data_name = NULL) {
.recover_data_from_environment <- function(x, data_name = NULL, verbose = FALSE) {
model_call <- get_call(x)

if (is.null(model_call[["data"]]) && is.character(data_name)) {
Expand Down Expand Up @@ -263,7 +264,12 @@ get_data <- function(x, ...) {
}

if (!is.null(dat) && object_has_names(model_call, "subset")) {
dat <- subset(dat, subset = eval(model_call$subset))
subset_data <- .safe(subset(dat, subset = eval(model_call$subset)))
if (!is.null(subset_data)) {
dat <- subset_data
} else if (verbose) {
format_warning("Looks like the original data was subset, however `get_data()` could not retrieve the subset of the data. The full data set is returned.") # nolint
}
}

dat
Expand Down Expand Up @@ -302,7 +308,7 @@ get_data.default <- function(x, source = "environment", verbose = TRUE, ...) {
if ((is.null(mf) || nrow(mf) == 0) && source != "environment") {
mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
vars <- find_variables(x, flatten = TRUE, verbose = FALSE)
dat[, intersect(vars, colnames(dat)), drop = FALSE]
},
Expand Down Expand Up @@ -335,7 +341,7 @@ get_data.maxim <- get_data.default
#' @export
get_data.summary.lm <- function(x, verbose = TRUE, ...) {
mf <- tryCatch(
.recover_data_from_environment(x)[, all.vars(x$terms), drop = FALSE],
.recover_data_from_environment(x, verbose = verbose)[, all.vars(x$terms), drop = FALSE],
error = function(x) NULL
)
.prepare_get_data(x, mf, verbose = verbose)
Expand Down Expand Up @@ -451,7 +457,7 @@ get_data.gee <- function(x,
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
vars <- switch(effects,
all = find_variables(x, flatten = TRUE, verbose = FALSE),
fixed = find_variables(x, effects = "fixed", flatten = TRUE, verbose = FALSE),
Expand Down Expand Up @@ -490,7 +496,7 @@ get_data.rqss <- function(x,

mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
vars <- find_variables(
x,
effects = "all",
Expand Down Expand Up @@ -520,7 +526,7 @@ get_data.gls <- function(x, source = "environment", verbose = TRUE, ...) {
# fall back to extract data from model frame
mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
data_columns <- intersect(
colnames(dat),
find_variables(x, flatten = TRUE, verbose = FALSE)
Expand Down Expand Up @@ -929,7 +935,7 @@ get_data.glmmadmb <- function(x,
effects <- match.arg(effects, choices = c("all", "fixed", "random"))

fixed_data <- x$frame
random_data <- .recover_data_from_environment(x)[, find_random(x, split_nested = TRUE, flatten = TRUE), drop = FALSE]
random_data <- .recover_data_from_environment(x, verbose = verbose)[, find_random(x, split_nested = TRUE, flatten = TRUE), drop = FALSE]

mf <- .safe({
switch(effects,
Expand Down Expand Up @@ -1020,7 +1026,7 @@ get_data.sem <- function(x,
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
vars <- switch(effects,
all = find_variables(x, flatten = TRUE, verbose = FALSE),
fixed = find_variables(x, effects = "fixed", flatten = TRUE, verbose = FALSE),
Expand Down Expand Up @@ -1135,7 +1141,7 @@ get_data.BBmm <- function(x, effects = "all", source = "environment", verbose =
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)[, find_variables(x, flatten = TRUE), drop = FALSE]
dat <- .recover_data_from_environment(x, verbose = verbose)[, find_variables(x, flatten = TRUE), drop = FALSE]
switch(effects,
all = dat[, find_variables(x, flatten = TRUE), drop = FALSE],
fixed = dat[, find_variables(x, effects = "fixed", flatten = TRUE), drop = FALSE],
Expand Down Expand Up @@ -1179,7 +1185,7 @@ get_data.glimML <- function(x, effects = "all", source = "environment", verbose
get_data.lavaan <- function(x, source = "environment", verbose = TRUE, ...) {
# try to recover data from environment
if (identical(source, "environment")) {
model_data <- .safe(.recover_data_from_environment(x), NULL)
model_data <- .safe(.recover_data_from_environment(x, verbose = verbose), NULL)

if (!is.null(model_data)) {
return(model_data)
Expand Down Expand Up @@ -1326,7 +1332,7 @@ get_data.feis <- function(x, effects = "all", source = "environment", verbose =
# fall back to extract data from model frame
# original data does not appear to be stored in the model object
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
mf <- tryCatch(.recover_data_from_environment(x),
mf <- tryCatch(.recover_data_from_environment(x, verbose = verbose),
error = function(x) stats::model.frame(x)
)
.get_data_from_modelframe(x, mf, effects, verbose = verbose)
Expand All @@ -1347,7 +1353,7 @@ get_data.fixest <- function(x, source = "environment", verbose = TRUE, ...) {
# see https://github.com/lrberge/fixest/issues/340 and #629
model_call <- get_call(x)
mf <- eval(model_call$data, envir = parent.env(x$call_env))
# mf <- .recover_data_from_environment(x)
# mf <- .recover_data_from_environment(x, verbose = verbose)
.get_data_from_modelframe(x, mf, effects = "all", verbose = verbose)
}

Expand Down Expand Up @@ -1378,7 +1384,7 @@ get_data.pgmm <- function(x, source = "environment", verbose = TRUE, ...) {

# fall back to extract data from model frame
model_terms <- find_variables(x, effects = "all", component = "all", flatten = TRUE)
mf <- tryCatch(.recover_data_from_environment(x)[, model_terms, drop = FALSE],
mf <- tryCatch(.recover_data_from_environment(x, verbose = verbose)[, model_terms, drop = FALSE],
error = function(x) NULL
)
.prepare_get_data(x, mf, verbose = verbose)
Expand Down Expand Up @@ -1427,7 +1433,7 @@ get_data.plm <- function(x, source = "environment", verbose = TRUE, ...) {

# try to get index variables from orignal data
if (!is.null(index)) {
original_data <- .recover_data_from_environment(x)
original_data <- .recover_data_from_environment(x, verbose = verbose)
keep <- intersect(index, colnames(original_data))
if (length(keep)) {
mf <- cbind(mf, original_data[, keep, drop = FALSE])
Expand Down Expand Up @@ -1476,7 +1482,7 @@ get_data.ivreg <- function(x, source = "environment", verbose = TRUE, ...) {

if (is_empty_object(mf)) {
final_mf <- .safe({
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
dat[, ft, drop = FALSE]
})
} else {
Expand All @@ -1486,7 +1492,7 @@ get_data.ivreg <- function(x, source = "environment", verbose = TRUE, ...) {
final_mf <- mf
} else {
final_mf <- .safe({
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
cbind(mf, dat[, remain, drop = FALSE])
})
}
Expand Down Expand Up @@ -1832,7 +1838,7 @@ get_data.coxph <- function(x, source = "environment", verbose = TRUE, ...) {
# first try, parent frame
dat <- tryCatch(
{
mf <- .recover_data_from_environment(x)
mf <- .recover_data_from_environment(x, verbose = verbose)
mf <- .prepare_get_data(x, stats::na.omit(mf), verbose = FALSE)
},
error = function(x) NULL
Expand Down Expand Up @@ -1938,7 +1944,7 @@ get_data.LORgee <- function(x, source = "environment", effects = "all", verbose
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
mf <- tryCatch(
{
dat <- .recover_data_from_environment(x)[, find_variables(x, flatten = TRUE), drop = FALSE]
dat <- .recover_data_from_environment(x, verbose = verbose)[, find_variables(x, flatten = TRUE), drop = FALSE]
switch(effects,
all = dat[, find_variables(x, flatten = TRUE), drop = FALSE],
fixed = dat[, find_variables(x, effects = "fixed", flatten = TRUE), drop = FALSE],
Expand Down Expand Up @@ -1998,7 +2004,7 @@ get_data.tobit <- function(x, source = "environment", verbose = TRUE, ...) {
}

# fall back to extract data from model frame
dat <- .recover_data_from_environment(x)
dat <- .recover_data_from_environment(x, verbose = verbose)
ft <- find_variables(x, flatten = TRUE, verbose = FALSE)
remain <- intersect(ft, colnames(dat))

Expand Down Expand Up @@ -2155,7 +2161,7 @@ get_data.rma <- function(x,
}

# fall back to extract data from model frame
mf <- tryCatch(.recover_data_from_environment(x), error = function(x) NULL)
mf <- tryCatch(.recover_data_from_environment(x, verbose = verbose), error = function(x) NULL)
mf_attr <- attributes(mf)
mf <- merge(mf, data.frame(Weights = get_weights(x)), by = "row.names", all = TRUE, sort = FALSE)
rownames(mf) <- mf$Row.names
Expand Down Expand Up @@ -2209,7 +2215,7 @@ get_data.metaplus <- function(x, source = "environment", verbose = TRUE, ...) {
}

# fall back to extract data from model frame
mf <- .safe(.recover_data_from_environment(x))
mf <- .safe(.recover_data_from_environment(x, verbose = verbose))
.prepare_get_data(x, stats::na.omit(mf), verbose = verbose)
}

Expand Down
14 changes: 7 additions & 7 deletions man/format_value.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading

0 comments on commit e023a26

Please sign in to comment.