R/act24_assign_primary_activities.R

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

#' Determine which of several possible activities is the primary activity, using
#' the Gale-Shapley algorithm
#' @param info input from obtained from \code{\link{get_activity_info}}
#' @param missing_info output from \code{\link{get_missing_info}}
#' @inheritParams act24_wrapper
#' @keywords internal
assign_primary_activities <- function(info, missing_info, verbose) {

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

  if (verbose) {

    cat(
      "\n...trying Gale-Shapley to fill in the last",
      length(info$incomplete), "gap(s) for",
      info$preliminary_labels$id[1]
    )

    warning(
      "...trying Gale-Shapley to fill in the last ",
      length(info$incomplete), " gap(s) for ",
      info$preliminary_labels$id[1], call. = FALSE
    )

  }

  bkgd <- pairing_background(info)
  apps <-
    get_applications(missing_info, bkgd) %>%
    get_preferences(info, bkgd)

  pairs <-
    apps %$%
    matchingMarkets::hri(
      nSlots = quotas, s.prefs = s.prefs, c.prefs = c.prefs
    )

  pairs <-
    pairs$matchings %$%
    .[.$sOptimal == 1, c("college", "student")] %>%
    within({
      college = as.integer(as.character(college))
      index = match(student, .strf_mins)
    })

  stopifnot(
    nrow(pairs) == length(info$incomplete),
    length(
      intersect(info$incomplete, pairs$index)
    ) == length(
      union(info$incomplete, pairs$index)
    )
  )

  info$incomplete %>%
  match(pairs$index) %>%
  lapply(function(x) pairs$college[x]) %>%
  update_info(info, verbose) %>%
  summarize_missing(verbose) %>%
  .$info

}