diff --git a/DESCRIPTION b/DESCRIPTION index f9840ac6..54624ac5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,7 +36,6 @@ Imports: glue, lifecycle, posterior, - reshape2, rlang (>= 1.0.0), stats, tibble (>= 2.0.0), diff --git a/NEWS.md b/NEWS.md index bf6aaef8..06ca17cf 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # bayesplot (development version) +* Replace deprecated `reshape2::melt()` with base R `as.data.frame.table()` and `tidyr::pivot_longer()` across all internal data-reshaping helpers. `reshape2` has been removed from `Imports`. + * Use `rlang::warn()` and `rlang::inform()` for selected PPC user messages instead of base `warning()` and `message()`. * Standardize input validation errors in `ppc_km_overlay()` and interpolation helpers to use `rlang::abort()` for consistent error handling. * Fix assignment-in-call bug in `mcmc_rank_ecdf()` (#). diff --git a/R/bayesplot-extractors.R b/R/bayesplot-extractors.R index 19c6df88..a9cf18ef 100644 --- a/R/bayesplot-extractors.R +++ b/R/bayesplot-extractors.R @@ -15,12 +15,12 @@ #' @return #' \describe{ #' \item{`log_posterior()`}{ -#' `log_posterior()` methods return a molten data frame (see [reshape2::melt()]). +#' `log_posterior()` methods return a long-format data frame. #' The data frame should have columns `"Iteration"` (integer), `"Chain"` #' (integer), and `"Value"` (numeric). See **Examples**, below. #' } #' \item{`nuts_params()`}{ -#' `nuts_params()` methods return a molten data frame (see [reshape2::melt()]). +#' `nuts_params()` methods return a long-format data frame. #' The data frame should have columns `"Parameter"` (factor), `"Iteration"` #' (integer), `"Chain"` (integer), and `"Value"` (numeric). See **Examples**, below. #' } @@ -85,8 +85,13 @@ log_posterior.stanfit <- function(object, inc_warmup = FALSE, ...) { lp <- rstan::get_logposterior(object, inc_warmup = inc_warmup, ...) - lp <- lapply(lp, as.array) - lp <- set_names(reshape2::melt(lp), c("Iteration", "Value", "Chain")) + lp <- dplyr::bind_rows(lapply(seq_along(lp), function(i) { + data.frame( + Iteration = seq_along(lp[[i]]), + Value = as.numeric(lp[[i]]), + Chain = as.integer(i) + ) + })) validate_df_classes(lp[, c("Chain", "Iteration", "Value")], c("integer", "integer", "numeric")) } @@ -104,7 +109,10 @@ log_posterior.stanreg <- function(object, inc_warmup = FALSE, ...) { #' @method log_posterior CmdStanMCMC log_posterior.CmdStanMCMC <- function(object, inc_warmup = FALSE, ...) { lp <- object$draws("lp__", inc_warmup = inc_warmup) - lp <- reshape2::melt(lp) + lp <- as.data.frame.table(unclass(lp), responseName = "value", + stringsAsFactors = FALSE) + lp[[1]] <- as.integer(lp[[1]]) + lp[[2]] <- as.integer(lp[[2]]) lp$variable <- NULL lp <- dplyr::rename_with(lp, capitalize_first) validate_df_classes(lp[, c("Chain", "Iteration", "Value")], @@ -163,8 +171,19 @@ nuts_params.list <- function(object, pars = NULL, ...) { object <- lapply(object, function(x) x[, pars, drop = FALSE]) } - out <- reshape2::melt(object) - out <- set_names(out, c("Iteration", "Parameter", "Value", "Chain")) + out <- dplyr::bind_rows(lapply(seq_along(object), function(i) { + mat <- object[[i]] + n_iter <- nrow(mat) + par_names <- colnames(mat) + data.frame( + Iteration = rep(seq_len(n_iter), times = length(par_names)), + Parameter = factor(rep(par_names, each = n_iter), levels = par_names), + Value = as.vector(mat), + Chain = as.integer(i), + stringsAsFactors = FALSE + ) + })) + out <- out[c("Iteration", "Parameter", "Value", "Chain")] validate_df_classes(out[, c("Chain", "Iteration", "Parameter", "Value")], c("integer", "integer", "factor", "numeric")) } @@ -177,8 +196,12 @@ nuts_params.CmdStanMCMC <- function(object, pars = NULL, ...) { if (!is.null(pars)) { arr <- arr[,, pars] } - out <- reshape2::melt(arr) - colnames(out)[colnames(out) == "variable"] <- "parameter" + out <- as.data.frame.table(unclass(arr), responseName = "value", + stringsAsFactors = FALSE) + out[[1]] <- as.integer(out[[1]]) + out[[2]] <- as.integer(out[[2]]) + out[[3]] <- factor(out[[3]]) + names(out)[names(out) == "variable"] <- "parameter" out <- dplyr::rename_with(out, capitalize_first) validate_df_classes(out[, c("Chain", "Iteration", "Parameter", "Value")], c("integer", "integer", "factor", "numeric")) diff --git a/R/helpers-mcmc.R b/R/helpers-mcmc.R index 41e2c4ee..2669f93b 100644 --- a/R/helpers-mcmc.R +++ b/R/helpers-mcmc.R @@ -120,8 +120,10 @@ select_parameters <- #' #' @noRd #' @param x An mcmc_array (from prepare_mcmc_array). -#' @param varnames,value.name,... Passed to reshape2::melt (array method). -#' @return A molten data frame. +#' @param varnames Character vector of names for the dimension columns. +#' @param value.name Name for the value column. +#' @param ... Unused; kept for backward compatibility. +#' @return A long-format data frame. #' melt_mcmc <- function(x, ...) UseMethod("melt_mcmc") @@ -130,18 +132,16 @@ melt_mcmc.mcmc_array <- function(x, varnames = c("Iteration", "Chain", "Parameter"), value.name = "Value", - as.is = TRUE, ...) { stopifnot(is_mcmc_array(x)) - long <- reshape2::melt( - data = x, - varnames = varnames, - value.name = value.name, - as.is = FALSE, - ...) + long <- as.data.frame.table(x, responseName = value.name, + stringsAsFactors = FALSE) + colnames(long)[seq_along(varnames)] <- varnames - long$Parameter <- factor(long$Parameter) + long[[varnames[1]]] <- as.integer(long[[varnames[1]]]) # Iteration + long[[varnames[2]]] <- as.integer(long[[varnames[2]]]) # Chain + long$Parameter <- factor(long$Parameter) long } @@ -151,14 +151,12 @@ melt_mcmc.matrix <- function(x, varnames = c("Draw", "Parameter"), value.name = "Value", ...) { - long <- reshape2::melt( - data = x, - varnames = varnames, - value.name = value.name, - as.is = FALSE, - ...) - - long$Parameter <- factor(long$Parameter) + long <- as.data.frame.table(x, responseName = value.name, + stringsAsFactors = FALSE) + colnames(long)[seq_along(varnames)] <- varnames + + long[[varnames[1]]] <- as.integer(long[[varnames[1]]]) # Draw + long$Parameter <- factor(long$Parameter) long } diff --git a/R/helpers-ppc.R b/R/helpers-ppc.R index 5206b9af..998f02a7 100644 --- a/R/helpers-ppc.R +++ b/R/helpers-ppc.R @@ -239,9 +239,13 @@ from_grouped <- function(dots) { #' @noRd melt_predictions <- function(predictions) { obs_names <- attr(predictions, "obs_names") - out <- predictions %>% - reshape2::melt(varnames = c("rep_id", "y_id")) %>% - tibble::as_tibble() + n_reps <- nrow(predictions) + n_obs <- ncol(predictions) + out <- tibble::tibble( + rep_id = rep(seq_len(n_reps), times = n_obs), + y_id = rep(seq_len(n_obs), each = n_reps), + value = as.vector(predictions) + ) rep_labels <- create_rep_ids(out$rep_id) y_names <- obs_names[out$y_id] %||% out$y_id diff --git a/R/ppc-discrete.R b/R/ppc-discrete.R index 2c3f54a9..7b493187 100644 --- a/R/ppc-discrete.R +++ b/R/ppc-discrete.R @@ -435,8 +435,10 @@ ppc_bars_data <- y = y, yrep = t(yrep) ) + var_levels <- setdiff(colnames(tmp_data), "group") data <- - reshape2::melt(tmp_data, id.vars = "group") %>% + tidyr::pivot_longer(tmp_data, cols = -group, names_to = "variable", values_to = "value") %>% + dplyr::mutate(variable = factor(.data$variable, levels = var_levels)) %>% count(.data$group, .data$value, .data$variable) %>% tidyr::complete(.data$group, .data$value, .data$variable, fill = list(n = 0)) %>% group_by(.data$variable, .data$group) %>% diff --git a/R/ppd-test-statistics.R b/R/ppd-test-statistics.R index d7146405..c6ba19e7 100644 --- a/R/ppd-test-statistics.R +++ b/R/ppd-test-statistics.R @@ -291,7 +291,9 @@ ppd_stat_data <- function(ypred, group = NULL, stat) { ypred = t(predictions) ) colnames(d) <- gsub(".", "_", colnames(d), fixed = TRUE) - molten_d <- reshape2::melt(d, id.vars = "group") + var_levels <- setdiff(colnames(d), "group") + molten_d <- tidyr::pivot_longer(d, cols = -group, names_to = "variable", values_to = "value") %>% + dplyr::mutate(variable = factor(.data$variable, levels = var_levels)) molten_d <- group_by(molten_d, .data$group, .data$variable) data <- diff --git a/man/bayesplot-extractors.Rd b/man/bayesplot-extractors.Rd index 593a2b0e..825b0596 100644 --- a/man/bayesplot-extractors.Rd +++ b/man/bayesplot-extractors.Rd @@ -76,12 +76,12 @@ perform a similar function.} \value{ \describe{ \item{\code{log_posterior()}}{ -\code{log_posterior()} methods return a molten data frame (see \code{\link[reshape2:melt]{reshape2::melt()}}). +\code{log_posterior()} methods return a long-format data frame. The data frame should have columns \code{"Iteration"} (integer), \code{"Chain"} (integer), and \code{"Value"} (numeric). See \strong{Examples}, below. } \item{\code{nuts_params()}}{ -\code{nuts_params()} methods return a molten data frame (see \code{\link[reshape2:melt]{reshape2::melt()}}). +\code{nuts_params()} methods return a long-format data frame. The data frame should have columns \code{"Parameter"} (factor), \code{"Iteration"} (integer), \code{"Chain"} (integer), and \code{"Value"} (numeric). See \strong{Examples}, below. }