Nothing
#' @title Find names of model weights
#' @name find_weights
#'
#' @description Returns the name of the variable that describes the weights of a
#' model.
#'
#' @param x A fitted model.
#' @param ... Currently not used.
#'
#' @return The name of the weighting variable as character vector, or `NULL`
#' if no weights were specified.
#'
#' @examples
#' data(mtcars)
#' mtcars$weight <- rnorm(nrow(mtcars), 1, .3)
#' m <- lm(mpg ~ wt + cyl + vs, data = mtcars, weights = weight)
#' find_weights(m)
#' @export
find_weights <- function(x, ...) {
UseMethod("find_weights")
}
#' @export
find_weights.default <- function(x, ...) {
tryCatch(
{
call_string <- safe_deparse(get_call(x))
if (!is.null(call_string)) {
w <- safe_deparse(parse(text = call_string)[[1]]$weights)
# edge case, users use "eval(parse())" to parse weight variables
if (grepl("eval(parse(", w, fixed = TRUE)) {
w <- eval(parse(text = trim_ws(gsub("eval\\(parse\\((.*)=(.*)\\)\\)", "\\2", w))))
}
if (is_empty_object(w) || w == "NULL") w <- NULL
} else {
w <- NULL
}
w
},
error = function(e) {
NULL
}
)
}
#' @export
find_weights.brmsfit <- function(x, ...) {
f <- find_formula(x, verbose = FALSE)
if (is_multivariate(f)) {
resp <- unlist(lapply(f, function(i) safe_deparse(i$conditional[[2L]])), use.names = FALSE)
} else {
resp <- safe_deparse(f$conditional[[2L]])
}
resp <- compact_character(unname(sapply(resp, function(i) {
if (grepl("(.*)\\|(\\s+)weights\\((.*)\\)", i)) {
i
} else {
""
}
})))
w <- trim_ws(sub("(.*)\\|(\\s+)weights\\((.*)\\)", "\\3", resp))
if (is_empty_object(w)) w <- NULL
w
}
#' @export
find_weights.model_fit <- function(x, ...) {
find_weights(x$fit, ...)
}
#' @export
find_weights.merMod <- function(x, ...) {
tryCatch(
{
w <- safe_deparse(parse(text = safe_deparse(x@call))[[1]]$weights)
# edge case, users use "eval(parse())" to parse weight variables
if (grepl("eval(parse(", w, fixed = TRUE)) {
w <- eval(parse(text = trim_ws(gsub("eval\\(parse\\((.*)=(.*)\\)\\)", "\\2", w))))
}
if (is_empty_object(w) || w == "NULL") w <- NULL
w
},
error = function(e) {
NULL
}
)
}
#' @export
find_weights.lme <- function(x, ...) {
w <- find_weights.default(x, ...)
# any weights? If so, get formula
if (!is.null(w)) {
# in lme(), weights are either an optional varFunc object or a one-sided
# formula. The formula is usally stored in "$modelStruct$varStruct"
w_formula <- .safe(stats::formula(x$modelStruct$varStruct))
if (!is.null(w_formula)) {
w <- all.vars(w_formula)
} else {
w <- NULL
}
}
w
}
#' @export
find_weights.gls <- find_weights.lme
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.