fix multiple ci printing method

DESCRIPTION

@@ -67,7 +67,7 @@ Depends:
     R (>= 3.6)
 Imports:
     insight (>= 0.20.4.2),
-    datawizard (>= 0.10.0),
+    datawizard (>= 0.12.3.1),
     graphics,
     methods,
     stats,

R/bci.R

@@ -56,7 +56,7 @@ bci.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) {
 
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    return(.append_datagrid(out, x))
+    return(.append_datagrid(out, x, long = length(ci) > 1L))
   }
 
   dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "bci")
@@ -183,7 +183,7 @@ bci.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) {
 bci.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xdf <- insight::get_parameters(x)
   dat <- bci(xdf, ci = ci, verbose = verbose, ...)
-  dat <- .append_datagrid(dat, x)
+  dat <- .append_datagrid(dat, x, long = length(ci) > 1L)
   attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   dat
 }
@@ -196,7 +196,7 @@ bci.emm_list <- bci.emmGrid
 bci.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xrvar <- .get_marginaleffects_draws(x)
   dat <- bci(xrvar, ci = ci, verbose = verbose, ...)
-  dat <- .append_datagrid(dat, x)
+  dat <- .append_datagrid(dat, x, long = length(ci) > 1L)
   attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   dat
 }

R/ci.R

@@ -170,7 +170,7 @@ ci.data.frame <- function(x, ci = 0.95, method = "ETI", BF = 1, rvar_col = NULL,
     obj_name <- insight::safe_deparse_symbol(substitute(x))
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    return(.append_datagrid(out, x))
+    return(.append_datagrid(out, x, long = length(ci) > 1L))
   }
 
   .ci_bayesian(x, ci = ci, method = method, verbose = verbose, BF = BF, ...)
@@ -197,7 +197,7 @@ ci.emmGrid <- function(x, ci = NULL, ...) {
   if (is.null(ci)) ci <- 0.95
   xdf <- insight::get_parameters(x)
   out <- ci(xdf, ci = ci, ...)
-  out <- .append_datagrid(out, x)
+  out <- .append_datagrid(out, x, long = length(ci) > 1L)
   out
 }
 
@@ -216,7 +216,7 @@ ci.slopes <- function(x, ci = NULL, ...) {
   if (is.null(ci)) ci <- 0.95
   xrvar <- .get_marginaleffects_draws(x)
   out <- ci(xrvar, ci = ci, ...)
-  out <- .append_datagrid(out, x)
+  out <- .append_datagrid(out, x, long = length(ci) > 1L)
   out
 }
 

R/estimate_density.R

@@ -246,11 +246,7 @@ estimate_density.data.frame <- function(x,
     obj_name <- insight::safe_deparse_symbol(substitute(x))
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    # This doesn't use .append_datagrid because we get a non-grid output
-    dgrid <- x[,vapply(x, function(col) !inherits(col, "rvar"), FUN.VALUE = logical(1)), drop = FALSE]
-    dgrid$Parameter <- unique(out$Parameter)
-    out <- datawizard::data_join(dgrid, out, by = "Parameter")
-    out$Parameter <- NULL
+    out <- .append_datagrid(out, x, long = TRUE)
     class(out) <- .set_density_class(out)
     return(out)
   }
@@ -398,11 +394,7 @@ estimate_density.emmGrid <- function(x,
     bw = bw, ...
   )
 
-  # This doesn't use .append_datagrid because we get a non-grid output
-  dgrid <- insight::get_datagrid(x)
-  dgrid$Parameter <- unique(out$Parameter)
-  out <- datawizard::data_join(dgrid, out, by = "Parameter")
-  out$Parameter <- NULL
+  out <- .append_datagrid(out, x, long = TRUE)
   class(out) <- .set_density_class(out)
   out
 }
@@ -426,11 +418,7 @@ estimate_density.slopes <- function(x,
     bw = bw, ...
   )
 
-  # This doesn't use .append_datagrid because we get a non-grid output
-  dgrid <- insight::get_datagrid(x)
-  dgrid$Parameter <- unique(out$Parameter)
-  out <- datawizard::data_join(dgrid, out, by = "Parameter")
-  out$Parameter <- NULL
+  out <- .append_datagrid(out, x, long = TRUE)
   class(out) <- .set_density_class(out)
   out
 }

R/eti.R

@@ -80,7 +80,7 @@ eti.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) {
 
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    return(.append_datagrid(out, x))
+    return(.append_datagrid(out, x, long = length(ci) > 1L))
   }
 
 
@@ -192,7 +192,7 @@ eti.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) {
 eti.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xdf <- insight::get_parameters(x)
   dat <- eti(xdf, ci = ci, verbose = verbose, ...)
-  dat <- .append_datagrid(dat, x)
+  dat <- .append_datagrid(dat, x, long = length(ci) > 1L)
   attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   dat
 }
@@ -204,7 +204,7 @@ eti.emm_list <- eti.emmGrid
 eti.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xrvar <- .get_marginaleffects_draws(x)
   dat <- eti(xrvar, ci = ci, verbose = verbose, ...)
-  dat <- .append_datagrid(dat, x)
+  dat <- .append_datagrid(dat, x, long = length(ci) > 1L)
   attr(dat, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   dat
 }

R/hdi.R

@@ -157,7 +157,7 @@ hdi.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) {
 
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    return(.append_datagrid(out, x))
+    return(.append_datagrid(out, x, long = length(ci) > 1L))
   }
 
   dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "hdi")
@@ -279,7 +279,7 @@ hdi.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) {
 hdi.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xdf <- insight::get_parameters(x)
   out <- hdi(xdf, ci = ci, verbose = verbose, ...)
-  out <- .append_datagrid(out, x)
+  out <- .append_datagrid(out, x, long = length(ci) > 1L)
   attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   out
 }
@@ -291,7 +291,7 @@ hdi.emm_list <- hdi.emmGrid
 hdi.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xrvar <- .get_marginaleffects_draws(x)
   out <- hdi(xrvar, ci = ci, verbose = verbose, ...)
-  out <- .append_datagrid(out, x)
+  out <- .append_datagrid(out, x, long = length(ci) > 1L)
   attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   out
 }

R/print.equivalence_test.R

@@ -35,7 +35,7 @@ print.equivalence_test <- function(x, digits = 2, ...) {
 
   ci <- unique(x$CI)
   keep.columns <- c(
-    attr(x, "grid_cols"), "Parameter", "Effects", "Component",
+    attr(x, "idvars"), "Parameter", "Effects", "Component",
     "ROPE_Equivalence", "ROPE_Percentage", "CI", "HDI"
   )
 

R/print.rope.R

@@ -28,7 +28,7 @@ print.rope <- function(x, digits = 2, ...) {
 
   # These are the base columns we want to print
   cols <- c(
-    attr(x, "grid_cols"), "Parameter", "ROPE_Percentage", "Effects", "Component",
+    attr(x, "idvars"), "Parameter", "ROPE_Percentage", "Effects", "Component",
     if (is_multivariate) c("ROPE_low", "ROPE_high")
   )
 

R/si.R

@@ -168,7 +168,7 @@ si.emmGrid <- function(posterior, prior = NULL,
     BF = BF, verbose = verbose, ...
   )
 
-  out <- .append_datagrid(out, posterior)
+  out <- .append_datagrid(out, posterior, long = length(BF) > 1L)
   attr(out, "ci_method") <- "SI"
   attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(posterior))
   out
@@ -237,15 +237,9 @@ si.data.frame <- function(posterior, prior = NULL, BF = 1, rvar_col = NULL, verb
     obj_name <- insight::safe_deparse_symbol(substitute(posterior))
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    # This doesn't use .append_datagrid because we get a non-grid output
-    dgrid <- posterior[,vapply(posterior, function(col) !inherits(col, "rvar"), FUN.VALUE = logical(1)), drop = FALSE]
-    dgrid$Parameter <- unique(out$Parameter)
-    out_grid <- datawizard::data_join(dgrid, out, by = "Parameter")
-    class(out_grid) <- class(out)
-    return(out)
+    return(.append_datagrid(out, posterior, long = length(BF) > 1L))
   }
 
-
   if (is.null(prior)) {
     prior <- posterior
     insight::format_warning(

R/spi.R

@@ -80,7 +80,7 @@ spi.data.frame <- function(x, ci = 0.95, rvar_col = NULL, verbose = TRUE, ...) {
 
     attr(out, "object_name") <- sprintf('%s[["%s"]]', obj_name, rvar_col)
 
-    return(.append_datagrid(out, x))
+    return(.append_datagrid(out, x, long = length(ci) > 1L))
   }
 
   dat <- .compute_interval_dataframe(x = x, ci = ci, verbose = verbose, fun = "spi")
@@ -156,7 +156,7 @@ spi.sim <- function(x, ci = 0.95, parameters = NULL, verbose = TRUE, ...) {
 spi.emmGrid <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xdf <- insight::get_parameters(x)
   out <- spi(xdf, ci = ci, verbose = verbose, ...)
-  out <- .append_datagrid(out, x)
+  out <- .append_datagrid(out, x, long = length(ci) > 1L)
   attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   out
 }
@@ -168,7 +168,7 @@ spi.emm_list <- spi.emmGrid
 spi.slopes <- function(x, ci = 0.95, verbose = TRUE, ...) {
   xrvar <- .get_marginaleffects_draws(x)
   out <- spi(xrvar, ci = ci, verbose = verbose, ...)
-  out <- .append_datagrid(out, x)
+  out <- .append_datagrid(out, x, long = length(ci) > 1L)
   attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
   out
 }

R/utils.R

@@ -174,29 +174,39 @@
 }
 
 #' @keywords internal
-.append_datagrid <- function(results, object) {
+.append_datagrid <- function(results, object, long = FALSE) {
   UseMethod(".append_datagrid", object = object)
 }
 
 #' @keywords internal
-.append_datagrid.emmGrid <- function(results, object) {
+.append_datagrid.emmGrid <- function(results, object, long = FALSE) {
   # results is assumed to be a data frame with "Parameter" column
   # object is an emmeans / marginalefeects that results is based on
 
   all_attrs <- attributes(results) # save attributes for later
+  all_class <- class(results)
 
   grid <- insight::get_datagrid(object)
   grid_names <- colnames(grid)
 
-  results[colnames(grid)] <- grid
-  results$Parameter <- NULL
-  results <- results[, c(grid_names, setdiff(colnames(results), grid_names)), drop = FALSE]
+  if (long) {
+    grid$Parameter <- unique(results$Parameter)
+    results <- datawizard::data_merge(grid, results, by = "Parameter")
+    results$Parameter <- NULL
+    class(results) <- all_class
+  } else {
+    results[colnames(grid)] <- grid
+    results$Parameter <- NULL
+    results <- results[, c(grid_names, setdiff(colnames(results), grid_names)), drop = FALSE]
+
+    # add back attributes
+    most_attrs <- all_attrs[setdiff(names(all_attrs), names(attributes(grid)))]
+    attributes(results)[names(most_attrs)] <- most_attrs
+  }
 
-  # add back attributes
-  most_attrs <- all_attrs[setdiff(names(all_attrs), names(attributes(grid)))]
-  attributes(results)[names(most_attrs)] <- most_attrs
 
-  attr(results, "grid_cols") <- grid_names
+
+  attr(results, "idvars") <- grid_names
   results
 }
 
@@ -208,24 +218,33 @@
 
 .append_datagrid.comparisons <- .append_datagrid.emmGrid
 
-.append_datagrid.data.frame <- function(results, object) {
+.append_datagrid.data.frame <- function(results, object, long = FALSE) {
   # results is assumed to be a data frame with "Parameter" column
   # object is a data frame with an rvar column that results is based on
 
   all_attrs <- attributes(results) # save attributes for later
+  all_class <- class(results)
 
   is_rvar <- vapply(object, function(col) inherits(col, "rvar"), FUN.VALUE = logical(1))
   grid_names <- colnames(object)[!is_rvar]
+  grid <- data.frame(object[,grid_names,drop = FALSE])
 
-  results[grid_names] <- object[grid_names]
-  results$Parameter <- NULL
-  results <- results[, c(grid_names, setdiff(colnames(results), grid_names)), drop = FALSE]
+  if (long) {
+    grid$Parameter <- unique(results$Parameter)
+    results <- datawizard::data_merge(grid, results, by = "Parameter")
+    results$Parameter <- NULL
+    class(results) <- all_class
+  } else {
+    results[grid_names] <- object[grid_names]
+    results$Parameter <- NULL
+    results <- results[, c(grid_names, setdiff(colnames(results), grid_names)), drop = FALSE]
 
-  # add back attributes
-  most_attrs <- all_attrs[setdiff(names(all_attrs), names(attributes(object)))]
-  attributes(results)[names(most_attrs)] <- most_attrs
+    # add back attributes
+    most_attrs <- all_attrs[setdiff(names(all_attrs), names(attributes(object)))]
+    attributes(results)[names(most_attrs)] <- most_attrs
+  }
 
-  attr(results, "grid_cols") <- grid_names
+  attr(results, "idvars") <- grid_names
   results
 }