R/plot.R

In causal.decomp: Causal Decomposition Analysis

##' Visualize sensitivity Objects
##'
##' S3 methods visualizing results for some objects generated by \code{sensitivity}.
##'
##' @name plot
##'
##' @param x an object of class \code{sensitivity}.
##' @param xlim limits of the x-axis of contour plots.
##' @param ylim limits of the y-axis of contour plots.
##' @param ... Other arguments for future usage.
NULL


##' @rdname plot
##' @export
plot.sensitivity <- function(x, xlim = c(0, 0.3), ylim = c(0, 0.3), ...){
  
  rm <- x$rm
  ry <- x$ry
  red <- x$red
  lower_red <- x$lower_red
  rem <- x$rem
  lower_rem <- x$lower_rem
  RV_red_alpha <- x$RV_red_alpha
  RV_rem_alpha <- x$RV_rem_alpha
  
  ### + warning messages later
  
  red <- red[rm <= xlim[2], ry <= ylim[2]]
  lower_red <- lower_red[rm <= xlim[2], ry <= ylim[2]]
  rem <- rem[rm <= xlim[2], ry <= ylim[2]]
  lower_rem <- lower_rem[rm <= xlim[2], ry <= ylim[2]]
  rm <- rm[rm <= xlim[2]]
  ry <- ry[ry <= ylim[2]]
  
  par(mfrow = c(1, 2))
  
  ################################
  ### Disparity reduction plot ###
  ################################
  
  ## Contours
  contour(rm, ry, red, levels = 0, lwd = 2, main = "A) Disparity reduction",  
          xlab = expression(paste("partial ", R^2, "of U with the outcome")), 
          ylab = expression(paste("partial ", R^2, "of U with the mediators")),
          ylim = ylim, xlim = xlim)
  contour(rm, ry, red, levels = seq(-1, 1, 0.2), lwd = 1, add = TRUE, lty = 1)
  contour(rm, ry, lower_red, levels = 0, lwd = 1, add = TRUE, lty = 4)
  
  ## Reference values
  # present minimum r2 value that will wash out the estimate
  points(RV_red_alpha, RV_red_alpha, pch = 16, col = "red", cex = 1) # add text to it
  text(RV_red_alpha, RV_red_alpha, paste("(", round(RV_red_alpha, 3), "," , round(RV_red_alpha, 3), ")", sep = ""),
       cex = 0.65, pos = 3, col = "red")
  
  # present minimum r2 value that will change the conclusion
  kk <- which(abs(lower_red - 0) < 0.01, arr.ind = TRUE)
  rm2 <- rm[kk[, 1]]
  ry2 <- ry[kk[, 2]]
  b <- mean(sqrt(rm2 * ry2))  # this is the minimum R squred of unobserved confounder 
  points(b, b, pch = 16, col = "red", cex = 1) # add text to it
  text(b, b, paste("(", round(b, 3), "," , round(b, 3), ")", sep = ""), cex = 0.65, pos = 3, col = "red")
  
  ################################
  ### Disparity remaining plot ###
  ################################
  
  ## Contours
  contour(rm, ry, rem, levels = 0, lwd = 2, main = "B) Disparity remaining",  
          xlab = expression(paste("partial ", R^2, "of U with the outcome")),
          ylab = expression(paste("partial ", R^2, "of U with the mediators")),
          ylim = ylim, xlim = xlim)
  contour(rm, ry, rem, levels = seq(-1, 1, 0.2), lwd = 1, add = TRUE, lty = 1)
  contour(rm, ry, lower_rem, levels = 0, lwd = 1, add = TRUE, lty = 4)
  
  ## Reference values
  # present minimum r2 value that will wash out the estimate
  points(RV_rem_alpha, RV_rem_alpha, pch = 16, col = "red", cex = 1) # add text to it
  text(RV_rem_alpha, RV_rem_alpha, paste("(", round(RV_rem_alpha, 3), "," , round(RV_rem_alpha, 3), ")", sep = ""),
       cex = 0.65, pos = 3, col = "red")
  
  # present minimum r2 value that will change the conclusion
  kk <- which(abs(lower_rem - 0) < 0.01, arr.ind = TRUE)
  rm2 <- rm[kk[, 1]]
  ry2 <- ry[kk[, 2]]
  b <- mean(sqrt(rm2 * ry2))  # this is the minimum R squred of unobserved confounder 
  points(b, b, pch = 16, col = "red", cex = 1) # add text to it
  text(b, b, paste("(", round(b, 3), "," , round(b, 3), ")", sep = ""), cex = 0.65, pos = 3, col = "red")
  
}