esci2: Effect Sizes and Confidence Intervals

# Tools for working with plots

# This function is for formatting the floating axis on difference plots
esci_scaleFUN <- function(x) sprintf("%.2f", x)


# This function helps with plotting sampling error in esci graphs
#  The user provides a short/user-friendly name for the style of
#  plotting sampling error, and this maps it onto the specific 
#  geom from ggdist
# If no friendly name is passed or the friendly name is not
#  recognized, point_interval is returned, which does not plot sampling error
esci_plot_error_layouts <- function(error_layout = "none") {
  
  # Mapping of friendly names to ggdist geoms
  error_layouts <- list(
    halfeye = "ggdist::stat_dist_halfeye",
    eye = "ggdist::stat_dist_eye",
    gradient = "ggdist::stat_dist_gradientinterval",
    none = "ggdist::stat_dist_pointinterval"
  )

  # Handle if friendly name not on list
  if(!error_layout %in% names(error_layouts)) {error_layout <- "none"}

  # Return appropriate ggdist geom
  return(error_layouts[[error_layout]])
}


# Same as above, but in this case, maps friendly names for styles of
#  plotting raw data to different geoms in ggplot2, ggbeeswarm, and ggdist
esci_plot_data_layouts <- function(data_layout = "none", data_spread){
  
  # Mapping of friendly names to geoms for plotting raw data
  data_layouts <- list(
    swarm = "ggbeeswarm::geom_beeswarm",
    random = "ggbeeswarm::geom_quasirandom",
    none = NULL
  )
  
  extra_options <- list(
    swarm = paste(", cex = ", data_spread * 4, sep = ""),
    random = paste(", varwidth = TRUE, width = ", data_spread, sep = ""),
    none = NULL
  )
  
  # Handle if friendly name not on list
  if(!data_layout %in% names(data_layouts)) {data_layout <- "none"}
  
  res <- list()
  res$call <- data_layouts[[data_layout]]
  res$extras <- extra_options[[data_layout]]
  
  # Return appropriate ggdist geom
  return(res)
}


# Matches up attributes by type for a difference plot
esci_plot_match_attributes <- function(condition, attributes) {
  res <- attributes[match(unlist(condition), names(attributes))]
  if (!is.null(attributes$default)) {
    names(res)[vapply(res, is.null, TRUE)] <- "Default"
    res[vapply(res, is.null, TRUE)] <- attributes$default
  }
  return(unlist(res))
}  

# Creates an set of valid plot attributes for a differencer plot
# and/or merges these
esci_plot_attributes <- function(check =  NULL) {
  
  # Kludges - define the valid linetypes and shapes
  valid_linetypes <- c("solid", "blank", "dashed", "dotted", "dotdash",
                       "longdash", "twodash")
  
  valid_shapes <- c(
    "circle", 
    paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
    "square", 
    paste("square", c("open", "filled", "cross", "plus", "triangle")),
    "diamond", 
    paste("diamond", c("open", "filled", "plus")),
    "triangle", 
    paste("triangle", c("open", "filled", "square")),
    paste("triangle down", c("open", "filled")),
    "plus", "cross", "asterisk"
  )
  
  
  # Define the attributes for a difference plot
  model <- list()
  model$data_shape <- list(
    Default = "circle filled",
    Reference = "circle filled",
    Comparison = "circle filled",
    Difference = "triangle filled",
    Unused = "circle filled"
  )
  model$data_size <- list(
    Default = 1,
    Reference = 1,
    Comparison = 1,
    Difference = 1,
    Unused = 0.5
  )
  model$data_colour <- list(
    Default = "black",
    Reference = "blue",
    Comparison = "green",
    Difference = "black",
    Unused = "black"
  )
  model$data_fill <- list(
    Default = NA,
    Reference = NA,
    Comparison = NA,
    Difference = NA,
    Unused = NA
  )
  model$data_alpha <- list(
    Default = 0.8,
    Reference = 0.8,
    Comparison = 0.8,
    Difference = 0.8,
    Unused = 0.5
  )
  model$summary_shape <- model$data_shape
  model$summary_size <- list(
    Default = 1,
    Reference = 1,
    Comparison = 1,
    Difference = 2,
    Unused = 1
  )
  model$summary_colour <- model$data_colour
  model$summary_fill <- model$data_colour
  model$summary_alpha <- list(
    Default = 1,
    Reference = 1,
    Comparison = 1,
    Difference = 1,
    Unused = 1
  )
  model$ci_colour <- list(
    Default = "black",
    Reference = "black",
    Comparison = "black",
    Difference = "black",
    Unused = "black"
  )
  model$ci_alpha <- list(
    Default = 1,
    Reference = 1,
    Comparison = 1,
    Difference = 1,
    Unused = 1
  )
  model$ci_size <- list(
    Default = 1,
    Reference = 1,
    Comparison = 1,
    Difference = 2,
    Unused = 1
  )
  model$ci_linetype <- list(
    Default = "solid",
    Reference = "solid",
    Comparison = "solid",
    Difference = "solid",
    Unused = "solid"
  )
  model$error_fill <- list(
    Default = "gray",
    Reference = "gray",
    Comparison = "gray",
    Difference = "gray",
    Unused = "gray"
  )
  model$error_alpha <- list(
    Default = 0.9,
    Reference = 0.9,
    Comparison = 0.9,
    Difference = 0.9,
    Unused = 0.9
  )
  check$warnings <- c(NULL)
  
  # If nothing passed, just return the model
  if (is.null(check)) { return (model)}
  
  # An object has been passed which will be checked and made to be a
  #  valid set of graph attributes
  
  # Cycle through the attribute groups in the model
  for (attrib_group in names(model)) {
    # See if the check object has that attribute group
    if (!(attrib_group %in% names(check))) {
      # No, it didn't so copy it from the model
      check[[attrib_group]] <- model[[attrib_group]]
    } else {
      # Yes, that group was defined, so let's cycle through the model attributes
      #  in that attribute group
      for (attrib in names(model[[attrib_group]])) {
        # See if the attribute has been defined in the check object
        if (is.null(check[[attrib_group]][[attrib]])) {
          # No, it hasn't, so set it to either the check default or the model's
          check[[attrib_group]][[attrib]] <- ifelse(
            is.null(check[[attrib_group]][["Default"]]),
            model[[attrib_group]][["Default"]],
            check[[attrib_group]][["Default"]]
          )
        }
        
        # The attribute is defined, is it valid?
        # First, check colors
        if(grepl("_colour", attrib_group, fixed = TRUE) |
           grepl("_fill", attrib_group, fixed = TRUE)
           ) {
          # The attribute group is a colour or fill type
          # So check if value is a valid colour
          if(!(is.na(check[[attrib_group]][[attrib]])) 
             & 
            !(check[[attrib_group]][[attrib]] %in% colors())) {
            # No, it wasn't a valid color
            # Store the invalid colour
            old <- check[[attrib_group]][[attrib]]
            # Replace with the check or model's default
            check[[attrib_group]][[attrib]] <- ifelse(
              is.null(check[[attrib_group]][["Default"]]) | attrib == "Default",
              model[[attrib_group]][["Default"]],
              check[[attrib_group]][["Default"]]
            )
            # Raise a warning
            this_warning <- glue::glue(
"In {attrib_group}, color for {attrib} was {old}, which is invalid; 
replaced with default value of {check[[attrib_group]][[attrib]]}"
            )
            check$warnings <- c(check$warnings, this_warning)
          }
        }
        
        # Next, check alphas
        if (grepl("_alpha", attrib_group, fixed = TRUE)) {
          if(!(is.numeric(check[[attrib_group]][[attrib]]))|
             check[[attrib_group]][[attrib]] < 0 |
             check[[attrib_group]][[attrib]] > 1
          ) {
            # No, it wasn't a valid alpa
            # Store the invalid alpha
            old <- check[[attrib_group]][[attrib]]
            # Replace with the check or model's default
            check[[attrib_group]][[attrib]] <- ifelse(
              is.null(check[[attrib_group]][["Default"]]) | attrib == "Default",
              model[[attrib_group]][["Default"]],
              check[[attrib_group]][["Default"]]
            )
            # Raise a warning
            this_warning <- glue::glue(
"In {attrib_group}, alpha for {attrib} was {old}, which is invalid; 
replaced with default value of {check[[attrib_group]][[attrib]]}"
            )
            check$warnings <- c(check$warnings, this_warning)
          }
        }
        

        # Next, check linetypes
        if (grepl("_linetype", attrib_group, fixed = TRUE)) {
          if(!(check[[attrib_group]][[attrib]] %in% valid_linetypes)) {
            # No, it wasn't a valid linetype
            # Store the invalid linetype
            old <- check[[attrib_group]][[attrib]]
            # Replace with the check or model's default
            check[[attrib_group]][[attrib]] <- ifelse(
              is.null(check[[attrib_group]][["Default"]]) | attrib == "Default",
              model[[attrib_group]][["Default"]],
              check[[attrib_group]][["Default"]]
            )
            # Raise a warning
            this_warning <- glue::glue(
"In {attrib_group}, linetype for {attrib} was {old}, which is invalid; 
replaced with default value of {check[[attrib_group]][[attrib]]}"
            )
            check$warnings <- c(check$warnings, this_warning)
          }
        }
        
        # Next, check shapes
        if (grepl("_shape", attrib_group, fixed = TRUE)) {
          if(!(check[[attrib_group]][[attrib]] %in% valid_shapes)) {
            # No, it wasn't a valid shape
            # Store the invalid shape
            old <- check[[attrib_group]][[attrib]]
            # Replace with the check or model's default
            check[[attrib_group]][[attrib]] <- ifelse(
              is.null(check[[attrib_group]][["Default"]]) | attrib == "Default",
              model[[attrib_group]][["Default"]],
              check[[attrib_group]][["Default"]]
            )
            # Raise a warning
            this_warning <- glue::glue(
"In {attrib_group}, shape for {attrib} was {old}, which is invalid; 
replaced with default value of {check[[attrib_group]][[attrib]]}"
            )
            check$warnings <- c(check$warnings, this_warning)
          }
        }
        
        # Next, check sizes
        if (grepl("_size", attrib_group, fixed = TRUE)) {
          if(!(is.numeric(check[[attrib_group]][[attrib]])) |
             !(check[[attrib_group]][[attrib]] > 0)) {
            # No, it is not a valid size
            # Store the invalid size
            old <- check[[attrib_group]][[attrib]]
            # Replace with the check or model's default
            check[[attrib_group]][[attrib]] <- ifelse(
              is.null(check[[attrib_group]][["Default"]]) | attrib == "Default",
              model[[attrib_group]][["Default"]],
              check[[attrib_group]][["Default"]]
            )
            # Raise a warning
            this_warning <- glue::glue(
"In {attrib_group}, size for {attrib} was {old}, which is invalid; 
replaced with default value of {check[[attrib_group]][[attrib]]}"
            )
            check$warnings <- c(check$warnings, this_warning)
          }
        }
        
      
      }  # Finish check of this attribute
      
    } # Continue cycling through attributes in this group
    
  } # Continue to next group of attributes
  
  for (my_warning in check$warnings) {
    warning(my_warning)
  }
  
  # All done, so we can return the checked set of attributes
  
  return(check)
}


esci_color_examples <- function() {
  
  # ----------- Definitions -----------
  # Define colors to plot
  myc <- colors()[which(!grepl("[[:digit:]]", colors()))]
  myc <- myc[which(!grepl("medium", myc))]
  myc <- myc[which(!grepl("dark", myc))]
  myc <- myc[which(!grepl("light", myc))]
  dark_colors <- c("black", "navy", "midnightblue", "navyblue", "blue")
  
  # Shapes to plot
  valid_shapes <- c(
    "circle", 
    paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
    "square", 
    paste("square", c("open", "filled", "cross", "plus", "triangle")),
    "diamond", 
    paste("diamond", c("open", "filled", "plus")),
    "triangle", 
    paste("triangle", c("open", "filled", "square")),
    paste("triangle down", c("open", "filled")),
    "plus", "cross", "asterisk"
  )
  
  # --- Data prep ---------------------
  # Color data
  rows <- 25
  columns <- 4
  d <- data.frame(
    c=myc, 
    y=seq(0, length(myc)-1)%%rows, 
    x=seq(0, length(myc)-1)%/%rows,
    text = "black"
  )
  d[d$c %in% dark_colors, "text"] <- "white"
  
  # Shape data
  s <- data.frame(
    s = valid_shapes,
    y = seq(0, length(valid_shapes)-1)%/%(columns) + max(d$y)+4,
    x = seq(0, length(valid_shapes)-1)%%(columns) + 0.15
  )

  mylabs <- data.frame(
    text = c("Shapes:", "Example colors/fills:"),
    y = c(max(s$y)+2, max(d$y)+2),
    x = 0
  )
  
  # ------- Build the plot-----------
  myplot <- ggplot2::ggplot()
  
  # Set x and y axis to have 5% expansion, no ticks
  myplot <- myplot + ggplot2::scale_x_continuous(
    name="", breaks=NULL, expand=c(0.05, 0.05)
  )
  myplot <- myplot + ggplot2::scale_y_continuous(
    name="", breaks=NULL, expand=c(0.05, 0.05)
  )
  
  # Set scales for shape and fill and colour to be identity
  myplot <- myplot + ggplot2::scale_shape_identity()
  myplot <- myplot + ggplot2::scale_fill_identity()
  myplot <- myplot + ggplot2::scale_colour_identity()
  
  # Plot rectangles for colors
  myplot <- myplot + ggplot2::geom_rect(
      data=d, 
      mapping=ggplot2::aes(
        xmin=x+0.05, xmax=x+0.95, ymin=y, ymax=y+1, fill=c
      )
  )
  # Plot points for shapes
  myplot <- myplot + ggplot2::geom_point(
    data = s,
    ggplot2::aes(x = x, y = y, shape = s),
    fill = "green",
    size = 2
  )
  
  # Labels for colors and shapes
  myplot <- myplot + ggplot2::geom_text(
      data=d, 
      mapping=ggplot2::aes(
        x=x+0.5, y=y+1, label=c, colour = text
      ), 
      hjust=0.5, 
      vjust=1, 
      size=3
  )
  
  myplot <- myplot + ggplot2::geom_text(
    data=s, 
    mapping=ggplot2::aes(
      x=x+0.35, y=y+.28, label=s
    ), 
    colour="black", 
    hjust=0.5, 
    vjust=1, 
    size=3
  )
  
  myplot <- myplot + ggplot2::geom_text(
    data=mylabs, 
    mapping=ggplot2::aes(
      x=x+.05, y=y, label=text
    ), 
    hjust=0,
    colour="black", 
    size=5
  )
  
  return(myplot)
}

esci_effect_size_expression <- function(effect_size_name) {
  effect_size_name <- gsub("<sub>", "[", effect_size_name)
  effect_size_name <- gsub("</sub>", "]", effect_size_name)
  effect_size_name <- gsub("<i>", "italic(", effect_size_name)
  effect_size_name <- gsub("</i>", ")", effect_size_name)
  effect_size_name <- parse(text = effect_size_name)
  return(effect_size_name)
}