R/segmentRefine_protocol.r

In TheGreatGospel/FemFit: Functions to Analyse FemFit Datasets

#' Segment within a JSONLabel with protocol information
#'
#' Takes a segmented "FemFit" object and constructs new baseline and event labels within the specified JSONLabel.
#'
#' @param x An "FemFit" object.
#' @param whichSession A character string which identifies which session to edit.
#' @param whichJSONLabel A character string which identifies which \code{JSONLabel} to edit.
#' @param numOfEvents How many events to identify.
#' @param baselineDuration Define the duration of a baseline region before an event region (in seconds). Recyles to length \code{numOfEvents}.
#' @param eventDuration Define the duration of an event region (in seconds). Recyles to length \code{numOfEvents}.
#' @param timeScale Time scale to work on. Defaults to working in seconds.
#'
#' @details
#' If a vector is inputted for either \code{whichSession} or \code{whichJSONLabel}, only the first element is used.
#'
#' @examples
#' # Read in the FemFit data
#' AS005 = read_FemFit(c(
#'         "Datasets_AukRepeat/61aa0782289af385_283_csv.zip",
#'         "Datasets_AukRepeat/61aa0782289af385_284_csv.zip"
#'     ),
#'     remove.NAs = TRUE
#'   ) %>%
#'   # Segment the FemFit data
#'   segment(
#'     cp. = 0.001,
#'     numOfNodesToLabel = list(c(3, 1, 3, 4), c(4, 1, 5, 3))
#'   )
#'
#' # Within a session refine the segmentation with protocol information
#' AS005r = segmentRefine_protocol(
#'     x = AS005,
#'     whichSession = "283 09:28",
#'     whichJSONLabel = "valsalva3x6s_rest30s",
#'     numOfEvents = 3,
#'     baselineDuration = c(16, 12, 12),
#'     eventDuration =  c(5.5, 5, 5)
#'   )
#'
#' @export
segmentRefine_protocol = function(x, whichSession, whichJSONLabel, numOfEvents, baselineDuration, eventDuration, timeScale = 1000) {
  # 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 trLabel does not exists in x$df
  if (x$df %>% colnames %>% {any(grepl("^trLabel$", .))} %>% !.) {
    stop("trLabel does not exist in the FemFit object.", call. = FALSE)
  }

  # Throw an error if the whichSession argument is not a character or missing
  if (!is.character(whichSession[1]) || is.na(whichSession[1])) {
    stop("The provided whichSession argument is not a character.", call. = FALSE)
  }

  # Throw an error if the whichJSONLabel argument is not a character or missing
  if (!is.character(whichJSONLabel[1]) || is.na(whichJSONLabel[1])) {
    stop("The provided whichJSONLabel argument is not a character.", call. = FALSE)
  }

  # Throw an error if the numOfEvents argument is not a numeric or missing
  if (!is.numeric(numOfEvents[1]) || is.na(numOfEvents[1])) {
    stop("The provided numOfEvents argument is not a numeric.", call. = FALSE)
  }

  # Throw an error if numOfEvents is not a positive integer
  if (numOfEvents[1] %% 1 != 0 || numOfEvents <= 0) {
    stop("The provided numOfEvents argument is not a positive integer.", call. = FALSE)
  }

  # Throw an error if the baselineDuration argument is not a numeric or missing
  if (!is.numeric(baselineDuration) || anyNA(baselineDuration)) {
    stop("The provided baselineDuration argument is not a numeric.", call. = FALSE)
  }

  # Throw an error if the eventDuration argument is not a numeric or missing
  if (!is.numeric(eventDuration) || anyNA(eventDuration)) {
    stop("The provided eventDuration argument is not a numeric.", call. = FALSE)
  }

  # Throw an error if the timeScale argument is not a numeric or missing
  if (!is.numeric(timeScale[1]) || is.na(timeScale[1])) {
    stop("The provided timeScale argument is not a numeric.", call. = FALSE)
  }

  # Recycle elements of baselineDuration and eventDuration if necessary
  baselineDuration = rep(baselineDuration, length.out = numOfEvents)
  eventDuration = rep(eventDuration, length.out = numOfEvents)

  # Extract out the region to apply the protocol event identification
  x_Child = x$df %>%
    dplyr::filter(sessionID == whichSession[1], JSONLabel == whichJSONLabel[1])

  if (nrow(x_Child) < 1) {
    stop("The provided whichSession and whichJSONLabel arguments selected no observations.", call. = FALSE)
  }

  # Rescale baselineDuration and eventDuration to timeScale
  baselineDuration = baselineDuration * timeScale[1]
  eventDuration = eventDuration * timeScale[1]

  x_Table = dplyr::tibble(
    # Note that the c(rbind(<vector>, <vector>)) trick was done to interleave baselineDuration and eventDuration
    timestamp = cumsum(c(rbind(baselineDuration, eventDuration))) + min(x_Child$time),
    label = rep(c("baseline", "event"), times = numOfEvents)) %>%
    dplyr::arrange(desc(timestamp))

  # Construct the call to enforce a protocol informed segmentation
  evalString = "x_Child = x_Child %>% mutate(trLabel = \"baseline\")"
  for (i in 1:nrow(x_Table)) {
    evalString = paste(evalString, sep = "%>%",
      paste0("mutate(trLabel = if_else(time < ", x_Table$timestamp[i], ", \"", x_Table$label[i],"\", trLabel))")
    )
  }
  eval(parse(text = evalString))

  # Send back the results to the inputted object
  x$df$trLabel[which(x$df$sessionID == whichSession[1] & x$df$JSONLabel == whichJSONLabel[1])] = x_Child$trLabel

  return (x)
}