R/methods-ts.R

In GHI-UW/HOT: The Health-Oriented Transportation (HOT) Model

#' The Subset TravelSurvey Method
#'
#' This method subsets a TravelSurvey object by given age, sex, year, or location. Note that all arguments must be of type character (in line with TravelSurvey class object definition).
#'
#'
#' @rdname subset
#' @param x A TravelSurvey object
#' @param i A character object representing the age, sex, year, or location on which to subset
#' @param ... Additional arguments of type character on which to subset
#'
#' @export
# Define subset method for one argument, using multi-argument definition below
setMethod("[", signature(x = "TravelSurvey", i = "character"), definition = function(x, i){ x <- x[i,i] })
# Define subset method for multiple arguments
setMethod("[",
          signature(x = "TravelSurvey", i = "character", j = "character"),
          definition = function(x, i, j, ...){

            # Initialize TS slots
            person <- x@person
            trip <- x@trip
            house <- x@house
            location <- x@location

            # Iterate through all character arguments provided
            for( index in c(i, j, ...) ){

              # Account for NA scenario (no way to distinguish age/sex/year metric)
              if( is.na(index) ){ stop("NA argument provided -- please only provide character objects for subsetting TravelSurvey objects.") }

              # Determine which metric (age, sex, year, location) on which to subset
              if( index %in% x@person$age ){ # Subset on age
                if( identical(index, unique(x@person$age)) ){} # Check TS if already subsetted by provided argument
                else{
                  # Subset 'person' slot
                  person <- person[as.character(person$age) %in% index,]

                  # Subset remaining slots to reflect subsetted 'person'
                  house <- house %>% dplyr::filter(houseID %in% person$houseID)
                  trip <- trip %>% dplyr::filter(subjectID %in% person$subjectID)
                }
              }else if( index %in% x@person$sex ){ # Subset on sex
                if( identical(index, unique(x@person$sex)) ){} # Check TS if already subsetted by provided argument
                else{
                  # Subset 'person' slot
                  person <- person[as.character(person$sex) %in% index,]

                  # Subset remaining slots to reflect subsetted 'person'
                  house <- house %>% dplyr::filter(houseID %in% person$houseID)
                  trip <- trip %>% dplyr::filter(subjectID %in% person$subjectID)
                }
              }else if( index %in% x@house$year ){ # Subset on year
                if( identical(index, unique(x@house$year)) ){} # Check TS if already subsetted by provided argument
                else{
                  # Subset 'house' slot
                  house <- house[as.character(house$year) %in% index,]

                  # Subset remaining slots to reflect subsetted 'house'
                  person <- person %>% dplyr::filter(houseID %in% house$houseID)
                  trip <- trip %>% dplyr::filter(houseID %in% house$houseID)
                }
              }else if( index %in% x@location$location ){ # Subset on location
                if( identical(index, unique(x@location$location)) ){} # Check TS if already subsetted by provided argument
                else{
                  # Subset 'location' and 'house' slots
                  location <- location[as.character(location$location) %in% index,]
                  house <- house[as.character(house$location) %in% index,]

                  # Subset remaining slots to reflect subsetted 'house'
                  person <- person %>% dplyr::filter(houseID %in% house$houseID)
                  trip <- trip %>% dplyr::filter(houseID %in% house$houseID)
                }
              }else{ stop("Error in provided character object argument. See help text for details.") } # Error case
            }
              house <- within(house, location <- factor(location, levels = unique(house$location)))
              location <- within(location, location <- factor(location, levels = unique(house$location)))
            # Re-initialize TravelSurvey object 'x'
            initialize(x, person = person, house = house, trip = trip, location = location)
          })
#' The Summary TravelSurvey Method
#'
#' This method provides summary statistics of a given TravelSurvey object.
#'
#' Returns a printed description of the following: number households, humber participants, sample distribution by sex, sample distribution by age, sub-locations, mean participation, mean duration of trip by mode.
#'
#' @rdname summary
#' @param object A TravelSurvey object
#' @export
setMethod("summary",
          signature(object = "TravelSurvey"),
          definition = function(object){

            locationData <- object@location %>% dplyr::filter(!is.na(participation))
            locationsNumber <- locationData %>% count(location) %>% count()
            popBySex <- suppressWarnings(as.data.frame(object@person %>% select(sex) %>% count(sex), optional = TRUE))
            totalSexDf <- data.frame(sex = "total", n = sum(popBySex$n))
            popBySex <- rbind(popBySex, totalSexDf)
            popByAge <- suppressWarnings(as.data.frame(object@person %>% select(age) %>% count(age), optional = TRUE))
            totalAgeDf <- data.frame( age = "total", n = sum(popByAge$n))
            popByAge <- rbind(popByAge, totalAgeDf)

            totalPop <- length(unique(object@person$subjectID))

            totalTripsTime <- suppressWarnings(object@trip %>% dplyr::filter(duration > 0) %>% group_by(mode) %>% tally(duration))
            totalTripsMode <- suppressWarnings(object@trip %>% dplyr::filter(duration > 0) %>% group_by(mode) %>% count(mode))
            totalTripsTime$n <- totalTripsTime$n/totalTripsMode$n
            tripSummary <- as.data.frame(totalTripsTime)

            cat("Travel Survey data summary: \n\n")
            cat("Number of households: ", length(unique(object@person$houseID)), "\n\n")
            cat( "Number of persons: ", totalPop, "\n\n")
            cat("Sample population by sex: \n")
            print(popBySex)
            cat("\n")
            cat("Sample population by age: \n")
            print(popByAge)
            cat("\n")
            cat("Number of sub-locations: ", locationsNumber$n,"\n")
            cat("\n")
            cat("Average participation: ", locationData$participation %>% mean(), "\n\n")
            cat("Average time of trip by mode: \n")
            print(tripSummary)

          })