R/act24_get_ee.R

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

#' @rdname get_ee
#' @inheritParams act24_wrapper
#' @param pattern regular expression on which to search column names
#' @keywords internal
get_col_pattern <- function(a, pattern) {

  names(a) %>%
  grepl(pattern, ., TRUE) %>%
  a[ ,.] %>%
  as.list(.) %>%
  lapply(function(x) if (is.na(x)) 0 else x) %>%
  unlist(.)

}

#' @rdname get_ee
#' @param indices indices on which to operate
#' @param percents percentage of \code{indices} allotted to each activity/MET
#'   value
#' @keywords internal
get_counts <- function(indices, percents) {

  # Calculate real-valued minutes for each activity

    counts <- {length(indices) * percents}

  ## We need to allot elements of `indices` to each activity, based on the
  ## real-valued time spent in each activity (see above). That means we're
  ## converting the real-valued times to an integer-valued number of indices to
  ## allot for each activity. Simply rounding `counts` to the nearest integer may
  ## result in allotting too many or too few indices. Thus, we need to account
  ## for that rounding error by adjusting one or more allotments by 1 index. That
  ## should be done incrementally, and in a way that accounts for "distance
  ## travelled" during rounding.

  ## An example makes things clearer: Say we need to allot 80 1-minute indices to
  ## three activities that last 18.1, 25.4, and 35.8 minutes respectively. We
  ## round each to the nearest integer and come up with 18, 25, and 36, for a
  ## total of 79 (one short of our target). Thus, we need to add 1 allotment to
  ## one of the activities. We are very confident that 18.1 should be rounded to
  ## 18, somewhat confident that 35.8 should be rounded to 36, and not very
  ## confident that 25.4 should be rounded to 25. We can represent that
  ## confidence as the distance of the decimals (.1, .4, and .8) from .5. In
  ## other words, the closer to an extreme (<.1 or >.9), the more confident we
  ## are of the rounding. The further from an extreme (and thus the closer to
  ## .5), the less confident we are. Therefore, we take the following approach
  ## to make any necessary adjustments to the rouding-based allotment:

  # 1) Calculate distance from .5

    mid_distance <-
      floor(counts) %>% # Round down
      {counts - .} %>% # Subtract from original to isolate the decimal
      {0.5 - .} %>% # Signed distance from the middle
      abs(.) %>% # Unsigned difference from the middle
      order(.) # Indices of `counts`, in order from closest to furthest from .5

  # 2) Initialize the allotments by rounding to the nearest integer

    counts %<>% round(0)

  # 3) Determine whether to add or subtract (or neither) from the total allotment

    for (i in mid_distance) {

      counts[i] <-
        (length(indices) - sum(counts)) %>%
        sign(.) %>% # Results in addition for under-allotment
        {counts[i] + .} # and subtraction for over-allotment
                        # (and nothing for proper allotment)

    }

  counts %T>%
  {stopifnot(sum(.) == length(indices))}

}

#' @rdname get_ee
#' @keywords internal
get_mets <- function(info) {

  info$preliminary_labels$METs <-
    info$preliminary_labels %>%
    nrow(.) %>%
    rep(NA_real_, .)

  for (j in row.names(info$original)) {

    indices <- which(
      info$preliminary_labels$Primary_Index ==
      as.integer(as.character(j))
    )

    if (!length(indices)) next

    mets <-
      info$original[j, ] %>%
      get_col_pattern("^met_")

    percents <-
      info$original[j, ] %>%
      get_col_pattern("^Percent_") %T>%
      {stopifnot(sum(.) %in% c(0,100))}

    if (sum(percents) == 0) {

      mets %<>%
        {.[.!=0]} %T>%
        {stopifnot(length(.) == 1)}

      percents <- 100

    } else {

      percents %<>%
        .[.!=0] %T>%
        {stopifnot(sum(.) == 100)}

      mets <-
        gsub("Percent_", "", names(percents)) %>%
        match(gsub("Met_", "", names(mets))) %T>%
        {stopifnot(!anyNA(.))} %>%
        mets[.]

    }

    stopifnot(length(mets) == length(percents))

    orders <- order(percents, decreasing = TRUE)

    percents %<>% {.[orders] / 100}
    mets %<>% .[orders]

    counts <- get_counts(indices, percents)

    for (k in seq_along(counts)) {

      target_indices <- indices[
        seq_len(counts[k])
      ]

      info$preliminary_labels[
        target_indices, "METs"
      ] <- mets[k]

      indices %<>% setdiff(target_indices)

    }

    stopifnot(!length(indices))

  }

  info

}

#' @rdname get_ee
#' @keywords internal
check_met_hrs <- function(info) {

  target <-
    info$original %>%
    {.[ ,c("Duration_Primary", "MetHours_Primary")]} %>%
    {data.frame(
      index = seq(nrow(.)),
      duration = .$Duration_Primary,
      target = .$MetHours_Primary
    )}

  target$index %>%
    sapply(function(x) sum(
      info$preliminary_labels$Primary_Index == x,
      na.rm = TRUE
    )) %>%
    {stopifnot(identical(., target$duration))}

  info$preliminary_labels %$%
    tapply(METs, Primary_Index, sum, simplify = FALSE) %>%
    do.call(c, .) %>%
    {round(./60, 2)} %>%
    data.frame(
      index = as.integer(as.character(names(.))),
      current = .
    ) %>%
    merge(target, ., all = TRUE) %T>%
    {stopifnot(nrow(.) == nrow(info$original))} %>%
    within({current = ifelse(is.na(current), 0, current)}) %$%
    all.equal(target, current, 0.015, 1) %>%
    isTRUE(.) %>%
    stopifnot(.)

  info

}

#' Add energy expenditure information to minute-by-minute ACT24 data
#'
#' @param info info passed in from \code{\link{get_activity_info}} and
#'   \code{link{assign_primary_activities}}
#' @inheritParams act24_wrapper
#' @keywords internal
get_ee <- function(info, verbose) {

  if (verbose) cat("\n...fetching behavior classifications")

  info$preliminary_labels$BehaviorClassification <-
    info$preliminary_labels$Primary_Index %>%
    info$original$BehaviorClassification[.]

  if (verbose) cat("\n...fetching METs")

  info %<>% get_mets(.)

  pseudo_postures <-
    info$preliminary_labels$BehaviorClassification %>%
    {ifelse(. == "sleeping", "lie", .)} %>%
    {ifelse(. == "sedentary", "sit", .)} %>%
    {ifelse(
      !. %in% c("lie", "sit"), "other", .
    )}

  if (verbose) cat("\n...fetching intensities")

  info$preliminary_labels$Intensity <-
    info$preliminary_labels$METs %>%
    PAutilities::get_intensity(pseudo_postures) %>%
    as.character(.) %>%
    {ifelse(
      info$preliminary_labels$BehaviorClassification == "sleeping",
      "sleep", .
    )} %>%
    factor(c("sleep", "SB", "LPA", "MVPA"))

  check_met_hrs(info)

}