R/act24_get_activity_info.R

In PAHPLabResearch/FLASH: FLASH: Free Living Activity Study for Health

#' @rdname get_activity_info
#' @keywords internal
get_activity_intervals <- function(a, verbose) {

  if (verbose) cat("\n...getting activity intervals")
  intervals <- with(
    a,
    lubridate::interval(ActivityStartTime, ActivityEndTime)
  )
  lubridate::int_end(intervals) %<>% {. - 1}
  stats::setNames(intervals, a$Activity)

}

#' @rdname get_activity_info
#' @param intervals output from \code{\link{get_activity_intervals}}
#' @keywords internal
get_activity_matches <- function(intervals, verbose) {

  if (verbose) cat("\n...matching timestamps to intervals")

  .minutes$Timestamp %>%
  lapply(
    function(x) {
      lubridate::`%within%`(x, intervals) %>%
      which(.)
    }
  )

}

#' @rdname get_activity_info
#' @param info internal object storing useful information related to activity
#'   intervals, multitasking, etc.
#' @param type The type of assembly to perform, either activity-based
#'   (\code{type="Activity}) or index-based (\code{type="Index})
#' @keywords internal
assembler <- function(info, type) {

  stopifnot(type %in% c("Activity", "Index"))

  info$matches %>%
  lapply(function(x) {
    switch(
      type,
      "Activity" =
        if (
          !length(names(info$intervals)[x])
        ) "Not reported" else names(info$intervals)[x],
      "Index" =
        x
    ) %>%
    c(info$dummy_val) %>%
    {.[info$dummy_ind]} %>%
    matrix(ncol = info$max_activities)
  }) %>%
  do.call(rbind, .) %>%
  data.frame(stringsAsFactors = FALSE) %>%
  stats::setNames(paste0(type, info$dummy_ind)) %T>%
  {if (type == "Activity") stopifnot(!anyNA(.$Activity1))} %>%
  list(.) %>%
  stats::setNames(type)

}

#' @rdname get_activity_info
#' @keywords internal
preliminary_labels <- function(info, mxm, verbose) {

  info$Activity %>%
  data.frame(
    mxm,
    n_activities = info$n_activities,
    .,
    info$Index,
    Primary_Activity = ifelse(
      info$n_activities > 1, "Multitasking", .$Activity1
    ),
    stringsAsFactors = FALSE
  ) %>%
  within({
    Activity1 = ifelse(
      Primary_Activity=="Multitasking", Activity1, NA_character_
    )
    Index1 = ifelse(
      Primary_Activity=="Multitasking", Index1, NA_integer_
    )
    Primary_Index = ifelse(
      Primary_Activity=="Multitasking",
      NA_integer_,
      as.integer(as.character(info$Index$Index1))
    )
  }) %T>%
  {stopifnot(all(
    info$original$Activity[.$Primary_Index] == .$Primary_Activity,
    na.rm = TRUE
  ))} %>%
  list(preliminary_labels = .) %T>%
  {if (verbose) message(
    "\nSuccessfully labeled ",
    sum(
      .[[1]]$Primary_Activity != "Multitasking",
      na.rm = TRUE
    ),
    " minutes of data"
  )}

}

#' @rdname get_activity_info
#' @param matches output from \code{\link{get_activity_matches}}
#' @param mxm shell of minute-by-minute data containing id and timestamps
#' @keywords internal
initialize_activity_info <- function(a, intervals, matches, mxm, verbose) {

  if (verbose) cat("\n...initializing info object")
  n_activities <- sapply(matches, length)
  max_activities <- max(n_activities)

  dummy_val <- rep(NA, max_activities)
  dummy_ind <- seq_len(max_activities)

  list(
    original = a, intervals = intervals, matches = matches,
    n_activities = n_activities, max_activities = max_activities,
    dummy_val = dummy_val, dummy_ind = dummy_ind
  ) %>%
  c(., assembler(., "Activity"), assembler(., "Index")) %>%
  c(., preliminary_labels(., mxm, verbose)) %>%
  c(
    list(complete = which(
      .$preliminary_labels$Primary_Activity!="Multitasking"
    )),
    list(incomplete = which(
      .$preliminary_labels$Primary_Activity=="Multitasking"
    ))
  )

}

#' @rdname get_activity_info
#' @param new_matches updated list of matches for use in labeling newly
#'   confirmed activity indices
#' @keywords internal
update_info <- function(new_matches, info, verbose) {

  initial_missing <- length(info$incomplete)

  info$matches[info$incomplete] <- new_matches
  info$n_activities <- sapply(info$matches, length)

  needs_update <-
    (info$preliminary_labels$Primary_Activity == "Multitasking") %>%
    {. & info$n_activities == 1}

  if (any(needs_update)) {

    info$preliminary_labels[
    needs_update, "Primary_Activity"
    ] <- sapply(
      info$matches[needs_update],
      function(x) info$original$Activity[x]
    )

    info$preliminary_labels[
      needs_update, "Primary_Index"
    ] <- unlist(info$matches[needs_update])

    info$complete <- which(
      info$preliminary_labels$Primary_Activity!="Multitasking"
    )

    info$incomplete <- which(
      info$preliminary_labels$Primary_Activity=="Multitasking"
    )

  }

  if (verbose) {
    (initial_missing - length(info$incomplete)) %>%
    message("\nSuccessfully labeled ", ., " additional minutes of data")
  }

  info

}

#' @rdname get_activity_info
#' @keywords internal
check_nonprimary <- function(info, verbose) {

  if (verbose) cat(
    "\n...checking for fully secondary activities"
  )

  zeroes <-
    (info$original$Duration_Primary == 0) %>%
    {seq(nrow(info$original))[.]}

  if (!length(zeroes)) return(info)

  info$incomplete %>%
  info$matches[.] %>%
  lapply(function(x) x[!x %in% zeroes]) %>%
  update_info(info, verbose)

}

#' @rdname get_activity_info
#' @keywords internal
check_quota <- function(info, verbose) {

  if (verbose) cat(
    "\n...checking for fully assigned activities"
  )

  missing_info <- get_missing_info(info, FALSE)

  if (nrow(missing_info$remaining) == 0) return(info)

  remaining <- missing_info$remaining$index

  info$incomplete %>%
  info$matches[.] %>%
  lapply(
    function(x) x[x %in% remaining]
  ) %>%
  update_info(info, verbose)

}

#' @rdname get_activity_info
#' @keywords internal
summarize_missing <- function(info, verbose) {

  get_missing_info(info, verbose) %>%
  {list(info = list(info), missing_info = list(.))} %>%
  lapply(function(x) x[[1]])

}

#' Gather ACT24 information about activity intervals and overlap (multitasking)
#' @inheritParams act24_wrapper
#' @keywords internal
get_activity_info <- function(id = a$id, a, verbose = TRUE) {

  if (verbose) cat("\nRetrieving activity info for", id)

  mxm <- data.frame(
    id = id, Timestamp = .minutes,
    stringsAsFactors = FALSE
  )

  intervals <- get_activity_intervals(a, verbose)
  matches <- get_activity_matches(intervals, verbose)

  initialize_activity_info(
    a, intervals, matches, mxm, verbose
  ) %>%
  check_nonprimary(verbose) %>%
  check_quota(verbose) %>%
  summarize_missing(verbose)

}