R/FRR_S3Constructors.R

In fastrerandomize: Hardware-Accelerated Rerandomization for Improved Balance

#' Constructor for fastrerandomize randomizations
#'
#' @description
#' Create an S3 object of class \code{fastrerandomize_randomizations} that stores
#' the randomizations (and optionally balance statistics) generated by 
#' functions such as \code{\link{generate_randomizations}}.
#'
#' @param randomizations A matrix or array where each row (or slice) represents one 
#'   randomization.
#' @param balance A numeric vector or similar object holding balance statistics 
#'   for each randomization, or \code{NULL} if not applicable.
#' @param fastrr_env Associated \code{fastrr_env} environment.  
#' @param call The function call, if you wish to store it for reference (optional).
#'
#' @return An object of class \code{fastrerandomize_randomizations}.
#'
#' @export
fastrerandomize_class <- function(randomizations, balance = NULL, fastrr_env=NULL, call = NULL) {
  structure(
    list(
      randomizations = randomizations,
      balance = balance,
      fastrr_env = fastrr_env, 
      call = call
    ),
    class = "fastrerandomize_randomizations"
  )
}

#' Print method for fastrerandomize_randomizations objects
#'
#' @param x An object of class \code{fastrerandomize_instance}.
#' @param ... Further arguments passed to or from other methods.
#'
#' @method print fastrerandomize_randomizations
#' 
#' @return Prints an object of class \code{fastrerandomize_randomizations}.
#' 
#' @export
print.fastrerandomize_randomizations <- function(x, ...) {
  cat("Object of class 'fastrerandomize_randomizations'\n\n")
  
  if (!is.null(x$call)) {
    cat("Call:\n  ", paste(deparse(x$call), collapse = "\n  "), "\n\n")
  }
  
  # Basic info about randomizations
  if (is.null(x$randomizations)) {
    cat("No randomizations stored.\n")
  } else {
    # For matrices/arrays: 
    cat("Number of candidate randomizations:", nrow(x$randomizations), "\n")
    cat("Number of units (columns):", ncol(x$randomizations), "\n")
  }
  
  # Balance info if available
  if (!is.null(x$balance)) {
    cat("Balance statistics available for each randomization.\n")
  }
  
  invisible(x)
}

#' Summary method for fastrerandomize_randomizations objects
#'
#' @param object An object of class \code{fastrerandomize_randomizations}.
#' @param ... Further arguments passed to or from other methods.
#'
#' @return A list with summary statistics, printed by default.
#'
#' @method summary fastrerandomize_randomizations
#' @export
summary.fastrerandomize_randomizations <- function(object, ...) {
  cat("Summary of 'fastrerandomize_randomizations' object:\n\n")
  
  if (!is.null(object$balance)) {
    # Provide some numeric summary:
    bal_stats <- summary(object$balance)
    cat("Balance statistics (summary):\n")
    print(bal_stats)
  } else {
    cat("No balance statistics found.\n")
  }
  
  # Optionally return an invisible list for programmatic use
  invisible(list(
    call = object$call,
    num_randomizations = nrow(object$randomizations),
    balance_summary = if (!is.null(object$balance)) summary(object$balance)
  ))
}

#' Plot method for fastrerandomize_test objects
#'
#' @description 
#' Plots the observed treatment effect and, if available, the fiducial interval 
#' on a horizontal axis.
#'
#' @param x An object of class \code{fastrerandomize_test}.
#' @param ... Further graphical parameters passed to \code{\link{plot}}.
#'
#' @return No return value. This function is called for the side effect of
#' generating a histogram of the accepted balance measures of object with class \code{fastrerandomize_randomizations}. 
#'   
#' @export
plot.fastrerandomize_randomizations <- function(x, ...) {
  if (is.null(x$balance)) {
    message("No balance data in this randomization object. Nothing to plot.")
    return(invisible(NULL))
  }
  graphics::hist(
    x$balance, 
    main = "Distribution of balance measures \n(among accepted randomizations)",
    xlab = "Balance Measure",
    col = "steelblue", 
    ...
  )
}

#' Constructor for fastrerandomize randomization test objects
#'
#' @param p_value A numeric value representing the p-value of the test.
#' @param FI A numeric vector (length 2) representing the fiducial interval, or \code{NULL} if not requested.
#' @param tau_obs A numeric value (or vector) representing the estimated treatment effect.
#' @param fastrr_env Associated `fastrr_env` environment.  
#' @param call An optional function call, stored for reference.
#' @param ... Other slots you may want to store (e.g. additional diagnostics).
#'
#' @return An object of class \code{fastrerandomize_test}.
#'
#' @export
fastrerandomize_test <- function(
    p_value,
    FI,
    tau_obs,
    fastrr_env = NULL,
    call = NULL,
    ...
){
  structure(
    list(
      p_value = p_value,
      FI = FI,
      tau_obs = tau_obs,
      fastrr_env = fastrr_env, 
      call = call,
      ...
    ),
    class = "fastrerandomize_test"
  )
}

#' Print method for fastrerandomize_test objects
#'
#' @param x An object of class \code{fastrerandomize_test}.
#' @param ... Further arguments passed to or from other methods.
#'
#' @method print fastrerandomize_test
#' 
#' @return No return value, prints object of class \code{fastrerandomize_test}.
#' 
#' @export
print.fastrerandomize_test <- function(x, ...) {
  cat("Object of class 'fastrerandomize_test'\n\n")
  
  # Show the function call if stored
  if (!is.null(x$call)) {
    cat("Call:\n  ", paste(deparse(x$call), collapse = "\n  "), "\n\n")
  }
  
  cat("P-value: ", x$p_value, "\n")
  cat("Observed effect (tau_obs): ", x$tau_obs, "\n")
  
  if (!is.null(x$FI)) {
    cat("Fiducial interval: [", x$FI[1], ", ", x$FI[2], "]\n", sep = "")
  } else {
    cat("No fiducial interval computed (findFI = FALSE)\n")
  }
  
  invisible(x)
}

#' Summary method for fastrerandomize_test objects
#'
#' @param object An object of class \code{fastrerandomize_test}.
#' @param ... Further arguments passed to or from other methods.
#'
#' @return Returns an (invisible) list with a summary of \code{fastrerandomize_test} class objects. 
#'
#' @method summary fastrerandomize_test
#' @export
summary.fastrerandomize_test <- function(object, ...) {
  cat("Summary of 'fastrerandomize_test' object:\n\n")
  
  if (!is.null(object$call)) {
    cat("Call:\n  ", paste(deparse(object$call), collapse = "\n  "), "\n\n")
  }
  
  cat("P-value:\n  ", object$p_value, "\n\n")
  cat("Observed effect (tau_obs):\n  ", object$tau_obs, "\n\n")
  
  if (!is.null(object$FI)) {
    cat("Fiducial Interval:\n  [", object$FI[1],
        ", ", object$FI[2], "]\n\n", sep = "")
  } else {
    cat("No Fiducial Interval.\n\n")
  }
  
  out <- list(
    p_value = object$p_value,
    tau_obs = object$tau_obs,
    FI      = object$FI,
    call    = object$call
  )
  
  invisible(out)
}


#' Plot method for fastrerandomize_test objects
#'
#' @description 
#' Plots a simple visualization of the observed effect and the 
#' fiducial interval (if present) on a horizontal axis.
#'
#' @param x An object of class \code{fastrerandomize_test}.
#' @param ... Further graphical parameters passed to \code{\link{plot}}.
#' 
#' @return No output returned. Performs side effect of plotting \code{fastrerandomize_test} class objects. 
#'
#' @method plot fastrerandomize_test
#' @export
plot.fastrerandomize_test <- function(x, ...) {
  if (is.null(x$FI)) {
    message("No fiducial interval to plot, only a single observed effect.")
    graphics::plot(x = x$tau_obs, y = 0,
         xlab = "Effect Size", ylab = "", 
         main = "Observed Effect (No FI available)",
         xlim = c(x$tau_obs - abs(x$tau_obs)*0.5, x$tau_obs + abs(x$tau_obs)*0.5),
         pch = 19, ...)
    return(invisible(NULL))
  }
  
  # If FI is present, draw a simple horizontal line for the interval
  left  <- x$FI[1]
  right <- x$FI[2]
  mid   <- x$tau_obs
  
  # Set up plot space
  graphics::plot(NULL, NULL,
       xlim = c(min(left, mid) - 1, max(right, mid) + 1),
       ylim = c(-1, 1),
       xlab = "Effect Scale",
       ylab = "",
       main = "Fiducial Interval and Observed Effect",
       axes = FALSE, ...)
  graphics::axis(1)
  
  # Plot the FI
  graphics::segments(x0 = left,  y0 = 0,
                     x1 = right, y1 = 0,
                     lwd = 2, col = "blue")
  
  # Mark the midpoint
  graphics::segments(x0 = mid, y0 = -0.2,
                     x1 = mid, y1 =  0.2,
                     col = "red", lwd = 2)
  
  # Points/labels
  graphics::points(x = c(left, right),
                   y = c(0, 0), pch = 16, col = "blue")
  graphics::text(x = mid, y = 0.3, 
       labels = eval(parse(text = sprintf("expression(hat(tau)~%s)",
                                          sprintf(" '= %s'", round(mid, 3))) )),
       col = "red")
  graphics::box()
  
  # Return invisibly
  invisible(x)
}