R/plot_tail_ratio.R

In cyplessen/tailRatio: What the Package Does (One Line, Title Case)

#' Plot tail ratio
#'
#' This function plots tail ratios for two normal distributed populations.
#'
#' @param area Area of interest, either "below" or "above" cutoff
#' @param mean_high Mean of group with higher mean
#' @param mean_low Mean of group with lower mean
#' @param sd_high Standard deviation of group with higher mean
#' @param sd_low Standard deviation of group with lower mean
#' @param cutoff Cutoff value of interest, indicated in standard deviations from the higher mean group
#' @param x_lab_name Name for x-Axis
#' @param mean_of_interest Reference mean for visualization, i.e. 100 for IQ
#' @return A tail ratio
#' @export
plot_tail_ratio <- function(area, cutoff, mean_high, sd_high, mean_low, sd_low, x_lab_name, mean_of_interest) {

  if (area == "below") {

    limits = c(mean_high - 5 * sd_high, mean_high + 5 * sd_high) # minimum/maximum 5 sds below/above mean
    x <- seq(limits[1], limits[2], length.out = 100) # from minimum to maximum, i.e. 25 - 175 in 100 increments
    xmin <- max(0, limits[1])
    xmax <- min(mean_high - cutoff * sd_high, limits[2])
    areax <- seq(xmin, xmax, length.out = 100)

    annotation <- paste0("TR", cutoff, "SD", " = ",
                         (round(calculate_tail_ratio(area, mean_high, sd_high, mean_low, sd_low, cutoff),
                                digits = 2)))
    my_grob <- grid::textGrob(annotation, x = 0.8,  y = 0.5,
                               gp = grid::gpar(col="black", fontsize=12, fontface="bold"))

    # create df with area below cutoff for lower mean group with x, ymin, ymax
    area_low <- data.frame(x = areax, ymin = 0,
                           ymax = dnorm(areax, mean = mean_low, sd = sd_low))

    # create df with area below cutoff for higher mean group with x, ymin, ymax
    area_high <- data.frame(x = areax, ymin = 0,
                            ymax = dnorm(areax, mean = mean_high, sd = sd_high))

    ggplot2::ggplot() +
      ggplot2::geom_line(data.frame(x = x, y = dnorm(x, mean = mean_high, sd = sd_high)),
                mapping = ggplot2::aes(x = x, y = y), color = "red") +
      ggplot2::geom_line(data.frame(x = x, y = dnorm(x, mean = mean_low, sd = sd_low)),
                mapping = ggplot2::aes(x = x, y = y), color = "sky blue") +
      ggplot2::geom_vline(xintercept = mean_high - cutoff * sd_high, linetype="solid",
                 color = "black", size=.5) +
      ggplot2::geom_vline(xintercept = mean_of_interest, linetype = "dashed",
                 color = "black", size = .5) +
      ggplot2::geom_ribbon(data = area_high, mapping = ggplot2::aes(x = x, ymin = ymin, ymax = ymax),
                  alpha = .3, fill = "red") +
      ggplot2::geom_ribbon(data = area_low, mapping = ggplot2::aes(x = x, ymin = ymin, ymax = ymax),
                  alpha = .3, fill = "sky blue") +
      ggplot2::scale_x_continuous(name = x_lab_name, limits = limits, breaks = ggplot2::waiver()) +
      ggplot2::scale_y_continuous(breaks=NULL, name = "Density") +
      ggplot2::annotation_custom(my_grob) +
      ggplot2::theme_classic() +
      ggplot2::scale_color_discrete(name="Group",
                           breaks=c("sky blue", "red"),
                           labels=c("Lower Mean", "Higher Mean")) +
      ggplot2::ggtitle("Tail Ratio: Lower Tail") +
      ggplot2::theme(plot.title = ggplot2::element_text(color="black", size=14))

  } else if (area == "above") {

    limits = c(mean_high - 5 * sd_high, mean_high + 5 * sd_high) # minimum/maximum 5 sds below/above mean

    x <- seq(limits[1], limits[2], length.out = 100)

    xmin <- max(limits[1], mean_high + cutoff * sd_high)

    xmax <- min(limits[2], 200)

    areax <- seq(xmin, xmax, length.out = 100)

    annotation <- paste0("TR", cutoff, "SD", " = ",
                         (round(calculate_tail_ratio(area, mean_high, sd_high, mean_low, sd_low, cutoff), digits = 2)))

    my_grob <- grid::textGrob(annotation, x = 0.8 , y = .5,
                         gp = grid::gpar(col="black", fontsize = 12, fontface = "bold"))

    # create df with area above cutoff for lower mean group with x, ymin, ymax
    area_low <- data.frame(x = areax, ymin = 0,
                           ymax = dnorm(areax, mean = mean_low, sd = sd_low))

    # create df with area above cutoff for higher mean group with x, ymin, ymax
    area_high <- data.frame(x = areax, ymin = 0,
                            ymax = dnorm(areax, mean = mean_high, sd = sd_high))

    ggplot2::ggplot() +
      ggplot2::geom_line(data.frame(x = x, y = dnorm(x, mean = mean_high, sd = sd_high)),
                mapping = ggplot2::aes(x = x, y = y), color = "red") +
      ggplot2::geom_line(data.frame(x = x, y = dnorm(x, mean = mean_low, sd = sd_low)),
                mapping = ggplot2::aes(x = x, y = y), color = "sky blue") +
      ggplot2::geom_vline(xintercept = mean_high + cutoff * sd_high, linetype="solid",
                 color = "black", size=.5) +
      ggplot2::geom_vline(xintercept = mean_of_interest, linetype = "dashed",
                 color = "black", size=.5) +
      ggplot2::geom_ribbon(data = area_high, mapping = ggplot2::aes(x = x, ymin = ymin, ymax = ymax),
                  alpha = .3, fill = "red") +
      ggplot2::geom_ribbon(data = area_low, mapping = ggplot2::aes(x = x, ymin = ymin, ymax = ymax),
                  alpha = .3, fill = "sky blue") +
      ggplot2::scale_x_continuous(name = x_lab_name, limits = limits, ggplot2::waiver()) +
      ggplot2::scale_y_continuous(name = "Density", breaks=NULL) +
      ggplot2::annotation_custom(my_grob) +
      ggplot2::theme_classic() +
      ggplot2::scale_color_discrete(name="Group",
                           breaks=c("sky blue", "red"),
                           labels=c("Lower Mean", "Higher Mean")) +
      ggplot2::ggtitle("Tail Ratio: Upper Tail") +
      ggplot2::theme(plot.title = ggplot2::element_text(color="black", size=14))
  }
}