R/doe_plots.R

In DavidBarke/QWUtils: Useful Methods For Programming with Shiny

#' Effect Plot
#'
#' Visualize main effects of a full factorial design.
#'
#' @param fac_design A \code{\link{FacDesign}} object.
#' @param factor_ids One or more ids of
#' \code{fac_design$get_factor_storage()$get_ids()}. If \code{\link[base]{NULL}},
#' all factors are selected.
#'
#' @export
doe_effect_plot <- function(fac_design, factor_ids = NULL) {
  # Get factors and response from fac_design
  factors <- fac_design$get_table(index = FALSE, response = FALSE)
  response <- fac_design$get_table(index = FALSE, factors = FALSE)

  # Subset factors if supplied
  if (!is.null(factor_ids)) {
    factors <- factors[names(factors) %in% factor_ids]
    # Early return if no factor is selected
    if (length(factors) == 0) {
      return(NULL)
    }
  }

  # Calculate responses means for high and low values of the factors
  means <- map_dfr(factors, function(factor) {
    high_lgl <- factor == 1
    low_lgl <- factor == -1
    list(
      low = mean(response[[1]][low_lgl]),
      high = mean(response[[1]][high_lgl])
    )
  })

  factor_objects <- fac_design$get_factor_storage()$get_objects(factor_ids)
  factor_names <- purrr::map_chr(factor_objects, function(object) {
    object$get_name()
  })

  df <- tibble(factors = factor_names, low = means$low, high = means$high)

  plot <- ggplot(data = df) +
    facet_grid(facets = . ~ factors) +
    geom_segment(mapping = aes(x = -1, xend = 1, y = low, yend = high)) +
    scale_x_continuous(name = "", breaks = c(-1, 1), minor_breaks = NULL, expand = c(0, 0)) +
    scale_y_continuous(name = label_lang(
      de = "Zielgröße",
      en = "Target variable"
    )) +
    theme_bw()

  # Use of ggplotly as ggplot2 provides better faceting than plotly
  return(ggplotly(plot))
}

#' Interaction Plot
#'
#' Visualize the interaction between two factors of a full factorial design.
#'
#' @param fac_design A \code{\link{FacDesign}} object.
#' @param factor_1,factor2 A \code{FacDesignFactor} object in
#' \code{fac_design$get_factor_storage()}.
#'
#' @export
doe_interaction_plot <- function(fac_design, factor_1, factor_2) {
  factors <- fac_design$get_table(index = FALSE, response = FALSE)

  factor_1_value <- factors[[factor_1$get_id()]]
  factor_2_value <- factors[[factor_2$get_id()]]

  response <- fac_design$get_table(index = FALSE, factors = FALSE)[[1]]

  combinations <- map2_dbl(c(-1, 1, -1, 1), c(-1, -1, 1, 1), function(x, y) {
    mean(response[factor_1_value == x & factor_2_value == y])
  })

  df <- tibble::tibble(
    x = c(-1, 1, -1, 1),
    y = combinations,
    group = c(-1, -1, 1, 1)
  )

  p <- plot_ly(
    data = df,
    x = ~x,
    y = ~y,
    name = ~group,
    type = "scatter",
    mode = "lines"
  ) %>%
    layout(
      xaxis = list(
        title = factor_1$get_name()
      ),
      yaxis = list(
        title = fac_design$get_response_name()
      )
    ) %>%
    add_annotations(
      text = factor_2$get_name(),
      xref = "paper",
      yref = "paper",
      x = 1.08,
      y = 1.03,
      showarrow = FALSE
    )
  p
}

#' Pareto Plot
#'
#' Visualize the significance of effects of a linear model. Currently this methods
#' needs a \code{\link{FacDesign}} object as input in addition to the linear model.
#'
#' @param A \code{\link{FacDesign}} object.
#' @param lm A linear model generated by \code{\link[stats]{lm}}.
#' @param alpha Level of significance.
#' @param title The title of the plot.
#'
#' @export
doe_pareto_plot <- function(
  fac_design, lm, alpha = 0.05,
  title = "Standardisierte Haupt- und Wechselwirkungen"
) {
  coef <- summary(lm)$coefficients

  t_values <- coef[-1, 3]

  effect_ids <- row.names(coef)[-1]

  # split all effects at ":" to get the ids as single character vectors
  split_effect_ids <- stringr::str_split(effect_ids, ":")
  effect_names <- purrr::map_chr(split_effect_ids, function(split_effect_id) {
    # example: for effect id "id_1:id_2" split effect id is c("id_1", "id_2")
    split_effect_names <- purrr::map_chr(split_effect_id, function(single_id) {
      fac_design$get_factor_storage()$get_object(single_id)$get_name()
    })
    paste(split_effect_names, collapse = ":")
  })

  df <- tibble::tibble(
    name = effect_names,
    values = abs(t_values)
  )

  df$name <- factor(
    df$name, levels = df$name[order(df$values, decreasing = TRUE)]
  )

  p <- ggplot2::ggplot(data = df) +
    ggplot2::geom_col(mapping = aes(x = name, y = values)) +
    ggplot2::geom_hline(
      yintercept = abs(qt(alpha/2, df = df.residual(lm))),
      col = "red"
    ) +
    ggplot2::scale_x_discrete(name = NULL) +
    ggplot2::scale_y_continuous(name = fac_design$get_response_name()) +
    ggplot2::theme_bw() +
    ggplot2::ggtitle(title)

  p <- plotly::ggplotly(p)
}

#' Contour Plot
#'
#' Visualize the prediction of a full factorial design for two factors with
#' a two-dimensional contour plot.
#'
#' @param fac_design A \code{\link{FacDesign}} object.
#' @param factor_1,factor2 A \code{FacDesignFactor} object in
#' \code{fac_design$get_factor_storage()}.
#' @param interactions If \code{\link[base:logical]{TRUE}}, interactions between
#' \code{factor_1} and \code{factor_2} are considered.
#'
#' @export
doe_contour_plot <- function(fac_design, factor_1, factor_2, interactions = FALSE) {
  lm_formula <- two_factor_formula(
    fac_design$get_response_name(), factor_1, factor_2, interactions
  )

  data <- fac_design$get_table(index = FALSE)
  .lm <- lm(as.formula(lm_formula), data)

  grid <- expand.grid(A = seq(-1, 1, by = 0.05), B = seq(-1, 1, by = 0.05))
  # temporarily change names for prediction of the model
  names(grid) <- c(factor_1$get_id(), factor_2$get_id())
  grid$predict <- predict(.lm, newdata = grid)
  # change names back so that names of grid are always the same
  names(grid) <- c("A", "B", "predict")
  p <- plot_ly(data = grid, x = ~A, y = ~B, z = ~predict, type = "contour") %>%
    layout(
      xaxis = list(
        title = factor_1$get_name()
      ),
      yaxis = list(
        title = factor_2$get_name()
      )
    )

  p
}

#' Surface Plot
#'
#' Visualize the prediction of a full factorial design with a three-dimensional
#' surface plot.
#'
#' @inheritParams doe_contour_plot
#'
#' @export
doe_surface_plot <- function(fac_design, factor_1, factor_2, interactions = FALSE) {
  lm_formula <- two_factor_formula(
    fac_design$get_response_name(), factor_1, factor_2, interactions
  )

  data <- fac_design$get_table(index = FALSE)
  .lm <- lm(as.formula(lm_formula), data)

  grid <- expand.grid(A = seq(-1, 1, by = 0.05), B = seq(-1, 1, by = 0.05))
  # compare doe_contour_plot for temporarily grid name change
  names(grid) <- c(factor_1$get_id(), factor_2$get_id())
  grid$predict <- predict(.lm, grid)
  names(grid) <- c("A", "B", "predict")
  m_lm <- reshape2::acast(grid, formula = B ~ A, value.var = "predict")
  p <- plotly::plot_ly(
    type = "surface", x = seq(-1, 1, by = 0.05), y = seq(-1, 1, by = 0.05), z = m_lm, colors = "Blues"
  ) %>%
    plotly::layout(
      scene = list(
        xaxis = list(
          title = factor_1$get_name()
        ),
        yaxis = list(
          title = factor_2$get_name()
        ),
        zaxis = list(
          title = fac_design$get_response_name()
        ),
        camera = list(
          eye = list(
            x = 1*1.5,
            y = 0.75*1.5,
            z = 0.75*1.5
          )
        )
      )
    )

  p
}