R/plot.FemFit.r

Defines functions plot.FemFit

Documented in plot.FemFit

#' Plot an FemFit object.
#'
#' @description
#' A plot method for "FemFit" objects.
#'
#' @param x An "FemFit" object.
#' @param formula Specifies the response variable and up to two facetting variables. Must not be a variable used in the \code{colorCode} argument.
#' @param colorCode A variable color the pressure traces of the response. Must not be a variable used in the \code{formula} argument.
#' @param subset A conditional expression to subset \code{x$df}.
#' @param timeScale A numeric constant used to divide \code{x$df$time}.
#' @param xlab Label the x-axis.
#' @param ylab Label the y-axis. Defaults to the name of the response variable specified in \code{formula}.
#' @param main Label the title.
#' @param printPlot A logical constant to set whether \code{plot.FemFit} prints the plot. Defaults to \code{TRUE}.
#' @param ... Other arguments not used by this method.
#'
#' @details
#' The \code{formula} has up to three components, \code{y ~ facet_1 + facet_2}. \code{y} is a variable found in \code{x$df} and has special exceptions to grab all sensors when \code{y = prssr_sensor}, \code{y = zeroPrssr}, or \code{y = tmprtr_sensor}.
#'
#' If you do not want to facet, use \code{.} in the RHS of the formula.
#'
#' There is a special keyword, \code{sensor}, which allows the user to facet the pressure traces by sensor number or color the pressure traces by sensor number.
#'
#' \code{xlab} defaults to "Time (s)" if \code{timeScale = 1000} and \code{xlab = "Time (ms)"}.
#'
#' \code{timeScale}, \code{xlab}, \code{ylab}, \code{main}, and \code{printPlot} only uses the first element if there is a vector input.
#'
#' @return
#' \code{plot.FemFit} silently returns a \code{ggplot2} object which can then be edited.
#'
#' @examples
#' # Load in the FemFit dataset
#' session488 = read.FemFit("./Datasets_AukRepeat/2c2cc798481d05da_488_csv.zip")
#'
#' # Plot the FemFit dataset with the default arguments
#' plot(session488)
#'
#' # The absence of the `sensor` keyword in the formula argument simultaneously plots all pressure traces with an opacity value fo 25%
#' plot(session488, formula = prssr_sensor ~ sessionID)
#'
#' # Utilising the `sensor` keyword in the colorCode argument plots all pressure traces with a unique color.
#' plot(session488, formula = prssr_sensor ~ sessionID, colorCode = sensor)
#'
#' # Use subset to plot a portion of the FemFit dataset
#' plot(session488, subset = JSONLabel == "pfmc3x5s_rest30s")
#'
#' # xlab, ylab, and title must be character inputs. So, here is the current work-around to use mathematical symbols for those fields
#' plotObj = plot(session488, formula = zeroPrssr ~ sensor + sessionID, printPlot = FALSE)
#' plotObj = plotObj + labs(y = expression("Zeroed Pressure ("*Delta*"mmHg)"))
#' print(plotObj)
#'
#' @export plot.FemFit
plot.FemFit = function(x, formula = prssr_sensor ~ sensor + sessionID, colorCode = NULL, subset = NULL, timeScale = 1, xlab = "Time (ms)", ylab = NULL, main = NULL, printPlot = TRUE, ...) {
  # Define a vector containing variable names for partial matching to plot all eight sensors
  partialMatchVector = c("prssr_sensor", "zeroPrssr", "tmprtr_sensor")

  # Throw an error if the x argument is not an FemFit object or missing
  if (!inherits(x, "FemFit") || is.na(x)) {
    stop("The x argument is not an FemFit object.", call. = FALSE)
  }

  # Throw an error if the FemFit object does not have a `df` element
  if (!exists("df", x)) {
    stop("The provided FemFit object does not have a `df` element.", call. = FALSE)
  }

  # Throw an error if formula is not a formula or it has any NAs
  if (class(formula) != "formula") {
    stop("The provided formula value is not a formula.", call. = FALSE)
  }

  # Extract the components found in formula into parts
  parts = formula %>% all.vars()

  # Throw an error if parts has three or more components
  if (length(parts) >= 4) {
    stop("The provided formula value has four or more components.")
  }

  # Throw an error if some of the specified variables in parts does not exist in the `df` element
  parts.Check = sapply(parts %>% .[!grepl("(\\.|sensor)", .)], function (parts_Child) {
    x$df %>%
      colnames %>%
      grepl(if_else(parts_Child %in% partialMatchVector, parts_Child, paste0("^", parts_Child, "$")), .) %>%
      any
  })
  if (parts.Check %>% all %>% !.) {
    stop("The `df` element does not contain some of the specified variables in formula.", call. = FALSE)
  }

  # Throw an error if the variable specified for colorCode does not exist in the `df` element
  colorCode.String = as.character(substitute(colorCode))
  if (!is.null(substitute(colorCode))) {
    if (!{x$df %>% colnames %>% grepl(paste0("^", colorCode.String, "$"), .) %>% any} & colorCode.String != "sensor") {
      stop("The `df` element does not contain the specified colorCode variable.", call. = FALSE)
    }
  }

  # Throw an error if timeScale is not a numeric or it has any NAs
  if (!is.numeric(timeScale[1]) || is.na(timeScale[1])) {
    stop("The provided timeScale value is not a numeric.", call. = FALSE)
  }

  # Throw an error if xlab is not a numeric or it has any NAs
  if (!is.character(xlab[1]) || is.na(xlab[1])) {
    stop("The provided xlab value is not a character.", call. = FALSE)
  }

  # Automatically update xlab to seconds if timeScale = 1000 and xlab is set to it's default argument
  if (timeScale == 1000 && xlab[1] == "Time (ms)") {
    xlab[1] = "Time (s)"
  }

  # Assign a string to ylab if it is set to NULL
  if (is.null(ylab[1])) {
    ylab[1] = parts[1]
  }

  # Throw an error if ylab is not a numeric or it has any NAs
  if (!is.character(ylab[1]) || is.na(ylab[1])) {
    stop("The provided ylab value is not a character.", call. = FALSE)
  }

  # Throw an error if main is not NULL and is not a character
  if (!is.character(main[1]) && !is.null(main[1])) {
    stop("The provided main value is not a character.", call. = FALSE)
  }

  # Throw an error if printPlot is not a numeric or it has any NAs
  if (!is.logical(printPlot[1]) || is.na(printPlot[1])) {
    stop("The provided printPlot value is not a logical.", call. = FALSE)
  }

  # Typecast parts into individual variables
  parts.1 = parts[1]; parts.2 = dplyr::if_else(is.na(parts[2]), " ", parts[2]); parts.3 = dplyr::if_else(is.na(parts[3]), " ", parts[3])

  # Throw an error if any of the parts are used in the colorCode argument
  if (!is.null(substitute(colorCode)) && (parts.2 == colorCode.String || parts.3 == colorCode.String)) {
    stop("The provided colorCode value specifies a component of the provided formula value.", call. = FALSE)
  }

  # Filter the data.frame object
  subset_quo = dplyr::enquo(subset)
  if (length(all.vars(subset_quo)) != 0) {
    x$df = filter(x$df, !!subset_quo)
  }

  # Throw a warning if there is two or more sessionIDs in x$df and it was not specified in the formula
  if (x$df$sessionID %>% unique %>% length >= 2 && all(parts.2 != "sessionID", parts.3 != "sessionID", colorCode.String != "sessionID")) {
    warning("The provided FemFit object has two or more sessions. Use sessionID in either the formula or colorCode arguments.", call. = FALSE)
  }

  # Setup the logicals which will control the construction of the eval + parse strings
  partialMatch.Switch = parts.1 %in% partialMatchVector
  parts.2.Switch = !grepl("(\\.|sensor|[[:space:]])", parts.2)
  parts.3.Switch = !grepl("(\\.|sensor|[[:space:]])", parts.3)
  colorCode.Switch = !is.null(substitute(colorCode)) && colorCode.String != "sensor"
  colorCode.sensor.Switch = ifelse(length(colorCode.String) != 0, colorCode.String == "sensor", FALSE)
  overPlot.Switch = dplyr::if_else(partialMatch.Switch, !any(parts.2 == "sensor" || parts.3 == "sensor"), FALSE)

  if (colorCode.Switch || colorCode.sensor.Switch) {
    # ifelse rather than if_else to prevent if_else's safe evaluation when colorCode.String = "sensor"
    colorCode.n = ifelse(colorCode.sensor.Switch, as.integer(8), x$df %>% dplyr::select(colorCode.String) %>% dplyr::pull(colorCode.String) %>% unique %>% length)
  }

  # Wrangle together a data.frame which has our plotable elements
  selectString =
    paste0("dplyr::select(",
      dplyr::if_else(partialMatch.Switch, "dplyr::contains(parts.1),", "parts.1,"),
      dplyr::if_else(parts.2.Switch, "parts.2,", ""),
      dplyr::if_else(parts.3.Switch, "parts.3,", ""),
      dplyr::if_else(colorCode.Switch, "color = colorCode.String,", ""),
      "time)")

  gatherString =
    paste0("tidyr::gather(sensor, prssr,",
      dplyr::if_else(parts.2.Switch, "-parts.2,", ""),
      dplyr::if_else(parts.3.Switch, "-parts.3,", ""),
      dplyr::if_else(colorCode.Switch, "-color,", ""),
      "-time)")

  # Note that we're using eval + parse here to effectively reduce the number of if/else statements
  work.df = eval(
    parse(
      text =
        paste0(
          "x$df %>%",
          selectString,
          "%>%",
          gatherString,
          "%>%",
          "dplyr::mutate(time = time/timeScale",
          dplyr::if_else(colorCode.Switch, ", color = dplyr::if_else(is.na(color), \"NA\", as.character(color))", ""),
          ", sensor = gsub(paste0(\"(\", paste0(partialMatchVector, collapse = \"|\"), \")([0-9])\"), \"Sensor \\\\2\", sensor)",
          ")"
        )
      )
    )

  # Create a variable to allow line breaks if colorCode is not set to NULL
  if (colorCode.Switch) {
    work.df$lineBreaks = c(TRUE, work.df$color[2:nrow(work.df)] == work.df$color[1:(nrow(work.df)-1)]) %>%
      {c(1, which(. != 1), nrow(work.df)+1)} %>%
      {rep(1:length(diff(.)), diff(.))}
  }

  # Create the ggplot2 object
  toReturn = eval(
    parse(
      text = paste0(
        "ggplot2::ggplot(data = work.df, aes(x = time, y = prssr,",
          dplyr::if_else(colorCode.Switch, "color = color, group = interaction(lineBreaks, sensor)", "group = sensor"),
          dplyr::if_else(colorCode.sensor.Switch, ", color = sensor", ""),
        ")) +",
        "ggplot2::theme_bw() +",
        "ggplot2::labs(x = xlab, y = ylab, title = main) +",
        "ggplot2::geom_line(",
          dplyr::if_else(overPlot.Switch, dplyr::if_else(colorCode.sensor.Switch, "", "alpha = 0.25"), ""),
        ")",
        dplyr::if_else(
          parts.3 != " ",
          paste0("+ ggplot2::facet_grid(", parts.2, "~", parts.3, ")"),
          dplyr::if_else(
            parts.2 != ".",
            paste0("+ ggplot2::facet_wrap(", "~", parts.2, ")"),
            ""
          )
        ),
        ifelse(
          colorCode.Switch || colorCode.sensor.Switch,
          paste0(
            dplyr::if_else(colorCode.n <= 8,
                           "+ ggplot2::scale_color_brewer(type = \"qual\", palette = \"Dark2\", name = \"",
                           "+ ggplot2::scale_color_discrete(name = \""),
            colorCode.String,
            "\") + guides(colour = guide_legend(override.aes = list(alpha = 1)))"),
          "")
      )
    )
  )

  # If printPlot is set to TRUE, print the ggplot2 object
  if (printPlot[1]) {
    print(toReturn)
  }

  # Return the ggplot2 object
  invisible(toReturn)
}
TheGreatGospel/IVPSA documentation built on May 19, 2019, 1:47 a.m.