Skip to content

Commit

Permalink
fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
@strengejacke
strengejacke committed May 23, 2024
1 parent ec00fdc commit 0445811
Show file tree
Hide file tree
Showing 12 changed files with 231 additions and 182 deletions.
36 changes: 21 additions & 15 deletions R/estimate_means.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,12 +20,12 @@
#'
#' estimate_means(model)
#' estimate_means(model, fixed = "Sepal.Width")
#' estimate_means(model, at = c("Species", "Sepal.Width"), length = 2)
#' estimate_means(model, at = "Species=c('versicolor', 'setosa')")
#' estimate_means(model, at = "Sepal.Width=c(2, 4)")
#' estimate_means(model, at = c("Species", "Sepal.Width=0"))
#' estimate_means(model, at = "Sepal.Width", length = 5)
#' estimate_means(model, at = "Sepal.Width=c(2, 4)")
#' estimate_means(model, by = c("Species", "Sepal.Width"), length = 2)
#' estimate_means(model, by = "Species=c('versicolor', 'setosa')")
#' estimate_means(model, by = "Sepal.Width=c(2, 4)")
#' estimate_means(model, by = c("Species", "Sepal.Width=0"))
#' estimate_means(model, by = "Sepal.Width", length = 5)
#' estimate_means(model, by = "Sepal.Width=c(2, 4)")
#'
#' # Methods that can be applied to it:
#' means <- estimate_means(model, fixed = "Sepal.Width")
Expand All @@ -42,24 +42,30 @@
#'
#' model <- lmer(Petal.Length ~ Sepal.Width + Species + (1 | Petal.Length_factor), data = data)
#' estimate_means(model)
#' estimate_means(model, at = "Sepal.Width", length = 3)
#' estimate_means(model, by = "Sepal.Width", length = 3)
#' }
#' @return A data frame of estimated marginal means.
#' @export
estimate_means <- function(model,
at = "auto",
by = "auto",
fixed = NULL,
transform = "response",
ci = 0.95,
backend = "emmeans",
at = NULL,
...) {
if (!is.null(at)) {
insight::format_warning("The `at` argument is deprecated and will be removed in the future. Please use `by` instead.") # nolint
by <- at
}

if (backend == "emmeans") {
# Emmeans ------------------------------------------------------------------
estimated <- get_emmeans(model, at, fixed, transform = transform, ...)
estimated <- get_emmeans(model, by, fixed, transform = transform, ...)
means <- .format_emmeans_means(estimated, model, ci, transform, ...)
} else {
# Marginalmeans ------------------------------------------------------------
estimated <- .get_marginalmeans(model, at, ci = ci, ...)
estimated <- .get_marginalmeans(model, by, ci = ci, ...)
means <- .format_marginaleffects_means(estimated, model, ...)
}

Expand Down Expand Up @@ -88,14 +94,14 @@ estimate_means <- function(model,
# Table Formating ----------------------------------------------------------


.estimate_means_footer <- function(x, at = NULL, type = "means", p_adjust = NULL) {
.estimate_means_footer <- function(x, by = NULL, type = "means", p_adjust = NULL) {
table_footer <- paste("\nMarginal", type)

# Levels
if (!is.null(at) && length(at) > 0) {
table_footer <- paste0(table_footer, " estimated at ", toString(at))
if (!is.null(by) && length(by) > 0) {
table_footer <- paste0(table_footer, " estimated at ", toString(by))
} else {
table_footer <- paste0(table_footer, " estimated at ", attr(x, "at"))
table_footer <- paste0(table_footer, " estimated at ", attr(x, "by"))
}

# P-value adjustment footer
Expand All @@ -107,6 +113,6 @@ estimate_means <- function(model,
}
}

if (all(table_footer == "")) table_footer <- NULL
if (all(table_footer == "")) table_footer <- NULL # nolint
c(table_footer, "blue")
}
49 changes: 27 additions & 22 deletions R/get_emcontrasts.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,41 +23,48 @@
#' # Can fixate the numeric at a specific value
#' get_emcontrasts(model, fixed = "Petal.Width")
#' # Or modulate it
#' get_emcontrasts(model, at = "Petal.Width", length = 4)
#' get_emcontrasts(model, by = "Petal.Width", length = 4)
#' }
#' @export
get_emcontrasts <- function(model,
contrast = NULL,
at = NULL,
by = NULL,
fixed = NULL,
transform = "none",
method = "pairwise",
at = NULL,
...) {
# check if available
insight::check_if_installed("emmeans")

if (!is.null(at)) {
insight::format_warning("The `at` argument is deprecated and will be removed in the future. Please use `by` instead.") # nolint
by <- at
}

# Guess arguments
args <- .guess_emcontrasts_arguments(model, contrast, at, fixed, ...)
my_args <- .guess_emcontrasts_arguments(model, contrast, by, fixed, ...)

# Run emmeans
estimated <- emmeans::emmeans(
model,
specs = args$emmeans_specs,
at = args$emmeans_at,
specs = my_args$emmeans_specs,
at = my_args$emmeans_at,
type = transform,
...
)

# Find by variables
by <- args$emmeans_specs[!args$emmeans_specs %in% args$contrast]
if (length(by) == 0) by <- NULL
emm_by <- my_args$emmeans_specs[!my_args$emmeans_specs %in% my_args$contrast]
if (length(emm_by) == 0) emm_by <- NULL

contrasts <- emmeans::contrast(estimated, by = by, method = method, ...)
out <- emmeans::contrast(estimated, by = emm_by, method = method, ...)

attr(contrasts, "contrast") <- args$contrast
attr(contrasts, "at") <- args$at
attr(contrasts, "fixed") <- args$fixed
contrasts
attr(out, "contrast") <- my_args$contrast
attr(out, "at") <- my_args$by
attr(out, "by") <- my_args$by
attr(out, "fixed") <- my_args$fixed
out
}

#' @rdname get_emmeans
Expand All @@ -72,26 +79,24 @@ model_emcontrasts <- get_emcontrasts
#' @keywords internal
.guess_emcontrasts_arguments <- function(model,
contrast = NULL,
at = NULL,
by = NULL,
fixed = NULL,
...) {
# Gather info
predictors <- insight::find_predictors(model, effects = "fixed", flatten = TRUE, ...)
data <- insight::get_data(model)
model_data <- insight::get_data(model)

# Guess arguments
if (is.null(contrast)) {
contrast <- predictors[!sapply(data[predictors], is.numeric)][1]
contrast <- predictors[!sapply(model_data[predictors], is.numeric)][1]
if (!length(contrast) || is.na(contrast)) {
contrast <- predictors[1]
}
message('No variable was specified for contrast estimation. Selecting `contrast = "', contrast, '"`.')
} else {
if (all(contrast == "all")) {
contrast <- predictors
}
insight::format_alert('No variable was specified for contrast estimation. Selecting `contrast = "', contrast, '"`.') # nolint
} else if (all(contrast == "all")) {
contrast <- predictors
}

args <- list(contrast = contrast, at = at, fixed = fixed)
.format_emmeans_arguments(model, args, data, ...)
my_args <- list(contrast = contrast, by = by, fixed = fixed)
.format_emmeans_arguments(model, args = my_args, data = model_data, ...)
}
36 changes: 18 additions & 18 deletions R/get_emmeans.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -172,33 +172,33 @@ model_emmeans <- get_emmeans
data <- data[insight::find_predictors(model, effects = "fixed", flatten = TRUE, ...)]

# Deal with 'at'
if (is.null(args$at)) {
if (is.null(args$by)) {
args$data_matrix <- NULL
} else if (is.data.frame(args$at)) {
args$data_matrix <- args$at
args$at <- names(args$at)
} else if (is.list(args$at)) {
args$data_matrix <- expand.grid(args$at)
args$at <- names(args$data_matrix)
} else if (inherits(args$at, "formula")) {
args$data_matrix <- stats::model.frame(args$at, data = data)
args$at <- names(args$data_matrix)
} else if (is.data.frame(args$by)) {
args$data_matrix <- args$by
args$by <- names(args$by)
} else if (is.list(args$by)) {
args$data_matrix <- expand.grid(args$by)
args$by <- names(args$data_matrix)
} else if (inherits(args$by, "formula")) {
args$data_matrix <- stats::model.frame(args$by, data = data)
args$by <- names(args$data_matrix)
} else {
if (!is.null(args$at) && all(args$at == "all")) {
if (!is.null(args$by) && all(args$by == "all")) {
target <- insight::find_predictors(model, effects = "fixed", flatten = TRUE)
target <- target[!target %in% args$fixed]
} else {
target <- args$at
target <- args$by
}
datagrid <- insight::get_datagrid(data, at = target, ...)
args$at <- attributes(datagrid)$at_specs$varname
args$data_matrix <- as.data.frame(datagrid[args$at])
if (length(args$at) == 0) args$at <- NULL # Post-clean
datagrid <- insight::get_datagrid(data, by = target, ...)
args$by <- attributes(datagrid)$at_specs$varname
args$data_matrix <- as.data.frame(datagrid[args$by])
if (length(args$by) == 0) args$by <- NULL # Post-clean
}

# Deal with 'contrast'
if (!is.null(args$contrast)) {
contrast <- insight::get_datagrid(data, at = args$contrast, ...)
contrast <- insight::get_datagrid(data, by = args$contrast, ...)
args$contrast <- attributes(contrast)$at_specs$varname
contrast <- as.data.frame(contrast[args$contrast])
if (is.null(args$data_matrix)) {
Expand All @@ -211,7 +211,7 @@ model_emmeans <- get_emmeans

# Deal with 'fixed'
if (!is.null(args$fixed)) {
fixed <- insight::get_datagrid(data[args$fixed], at = NULL, ...)
fixed <- insight::get_datagrid(data[args$fixed], by = NULL, ...)
if (is.null(args$data_matrix)) {
args$data_matrix <- fixed
} else {
Expand Down
50 changes: 28 additions & 22 deletions R/get_emtrends.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,46 +8,52 @@
#' model <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
#'
#' get_emtrends(model)
#' get_emtrends(model, at = "Species")
#' get_emtrends(model, at = "Petal.Length")
#' get_emtrends(model, at = c("Species", "Petal.Length"))
#' get_emtrends(model, by = "Species")
#' get_emtrends(model, by = "Petal.Length")
#' get_emtrends(model, by = c("Species", "Petal.Length"))
#'
#' model <- lm(Petal.Length ~ poly(Sepal.Width, 4), data = iris)
#' get_emtrends(model)
#' get_emtrends(model, at = "Sepal.Width")
#' get_emtrends(model, by = "Sepal.Width")
#' }
#' @export
get_emtrends <- function(model,
trend = NULL,
at = NULL,
by = NULL,
fixed = NULL,
levels = NULL,
modulate = NULL,
at = NULL,
...) {
# Deprecation
if (!is.null(at)) {
insight::format_warning("The `at` argument is deprecated and will be removed in the future. Please use `by` instead.") # nolint
by <- at
}
if (!is.null(levels) || !is.null(modulate)) {
warning("The `levels` and `modulate` arguments are deprecated. Please use `at` instead.", call. = FALSE)
at <- c(levels, modulate)
insight::format_warning("The `levels` and `modulate` arguments are deprecated. Please use `by` instead.") # nolint
by <- c(levels, modulate)
}

# check if available
insight::check_if_installed("emmeans")

# Guess arguments
args <- .guess_emtrends_arguments(model, trend, at, fixed, ...)
my_args <- .guess_emtrends_arguments(model, trend, by, fixed, ...)

# Run emtrends
estimated <- emmeans::emtrends(
model,
specs = args$emmeans_specs,
var = args$trend,
at = args$emmeans_at,
specs = my_args$emmeans_specs,
var = my_args$trend,
at = my_args$emmeans_at,
...
)

attr(estimated, "trend") <- args$trend
attr(estimated, "at") <- args$at
attr(estimated, "fixed") <- args$fixed
attr(estimated, "trend") <- my_args$trend
attr(estimated, "at") <- my_args$by
attr(estimated, "by") <- my_args$by
attr(estimated, "fixed") <- my_args$fixed
estimated
}

Expand All @@ -62,26 +68,26 @@ model_emtrends <- get_emtrends
#' @keywords internal
.guess_emtrends_arguments <- function(model,
trend = NULL,
at = NULL,
by = NULL,
fixed = NULL,
...) {
# Gather info
predictors <- insight::find_predictors(model, effects = "fixed", flatten = TRUE, ...)
data <- insight::get_data(model)
model_data <- insight::get_data(model)

# Guess arguments
if (is.null(trend)) {
trend <- predictors[sapply(data[predictors], is.numeric)][1]
trend <- predictors[sapply(model_data[predictors], is.numeric)][1]
if (!length(trend) || is.na(trend)) {
stop("Model contains no numeric predictor. Please specify 'trend'.", call. = FALSE)
insight::format_error("Model contains no numeric predictor. Please specify `trend`.")
}
message('No numeric variable was specified for slope estimation. Selecting `trend = "', trend, '"`.')
insight::format_alert('No numeric variable was specified for slope estimation. Selecting `trend = "', trend, '"`.')
}
if (length(trend) > 1) {
message("More than one numeric variable was selected for slope estimation. Keeping only ", trend[1], ".")
insight::format_alert("More than one numeric variable was selected for slope estimation. Keeping only ", trend[1], ".")

Check warning on line 87 in R/get_emtrends.R

View workflow job for this annotation

GitHub Actions / lint / lint 

file=R/get_emtrends.R,line=87,col=121,[line_length_linter] Lines should not be more than 120 characters. This line is 123 characters.

Check warning on line 87 in R/get_emtrends.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/get_emtrends.R,line=87,col=121,[line_length_linter] Lines should not be more than 120 characters. This line is 123 characters.
trend <- trend[1]
}

args <- list(trend = trend, at = at, fixed = fixed)
.format_emmeans_arguments(model, args, data, ...)
my_args <- list(trend = trend, by = by, fixed = fixed)
.format_emmeans_arguments(model, args = my_args, data = model_data, ...)
}
16 changes: 8 additions & 8 deletions R/get_marginalcontrasts.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,12 +9,12 @@
#
# estimate_means(model)
# estimate_means(model, fixed = "Sepal.Width")
# estimate_means(model, at = c("Species", "Sepal.Width"), length = 2)
# estimate_means(model, at = "Species=c('versicolor', 'setosa')")
# estimate_means(model, at = "Sepal.Width=c(2, 4)")
# estimate_means(model, at = c("Species", "Sepal.Width=0"))
# estimate_means(model, at = "Sepal.Width", length = 5)
# estimate_means(model, at = "Sepal.Width=c(2, 4)")
# estimate_means(model, by = c("Species", "Sepal.Width"), length = 2)
# estimate_means(model, by = "Species=c('versicolor', 'setosa')")
# estimate_means(model, by = "Sepal.Width=c(2, 4)")
# estimate_means(model, by = c("Species", "Sepal.Width=0"))
# estimate_means(model, by = "Sepal.Width", length = 5)
# estimate_means(model, by = "Sepal.Width=c(2, 4)")
#
# # Methods that can be applied to it:
# means <- estimate_means(model, fixed = "Sepal.Width")
Expand All @@ -29,13 +29,13 @@
#
# model <- lmer(Petal.Length ~ Sepal.Width + Species + (1 | Petal.Length_factor), data = data)
# estimate_means(model)
# estimate_means(model, at = "Sepal.Width", length = 3)
# estimate_means(model, by = "Sepal.Width", length = 3)
# }
# }
# }
# #' @keywords internal
# .get_marginalmeans <- function(model,
# at = "auto",
# by = "auto",
# fixed = NULL,
# transform = "response",
# ci = 0.95,
Expand Down
Loading

0 comments on commit 0445811

Please sign in to comment.