R/segments.R

In CraigMohn/rideReadGPS: Read GPS Track Files (fit or gpx)

#' generate stops statistics for a track
#'
#' \code{statsStops}  processes a gps track file to summarize start/stop data
#'
#' @param trackdf data frame or tibble with gps track data
#' @param segInitIdleAggSecs stops/restarts before this time has
#'    elapsed are discarded and the ride starts at the last start prior to this
#' @param segInitIdleAggMeters stops/restarts within this distance
#'    of the initial start are discarded as above
#' @param ... parameters for \code{\link{processSegments}},
#'    \code{\link{statsCadence}},
#'    \code{\link{statsPower}},
#'    \code{\link{statsHeartRate}},
#'    \code{\link{statsGearing}},
#'    \code{\link{statsGrade}},
#'    \code{\link{statsSession}}
#'
#' @return a list containing summary data
#'
#' @seealso \code{\link{read_ride}},
#'    \code{\link{processSegments}},
#'    \code{\link{statsCadence}},
#'    \code{\link{statsPower}},
#'    \code{\link{statsHeartRate}},
#'    \code{\link{statsGearing}},
#'    \code{\link{statsGrade}},
#'    \code{\link{statsSession}}
#'
#' @export
statsStops <- function(trackdf,
                       segInitIdleAggSecs=60,
                       segInitIdleAggMeters=20,
                       ...) {

  segstart <- trackdf$segment != lag_one(trackdf$segment)
  segstart[1] <- TRUE

  timesecs <- cumsum(trackdf$deltatime)
  #  moving <- trackdf$speed.m.s > 0
  moving <- !trackdf$stopped
  moving[!((lag_one(lag_one(moving))&lag_one(moving))|
             (lead_one(lead_one(moving))&lead_one(moving)))] <- FALSE
  movingtime <- timesecs*as.numeric(moving)
  lastmovetime <- lag_one(cummax(movingtime))
  stoplength <- (timesecs[segstart] - lastmovetime[segstart])[-1]

  startlinewait <- timesecs <= segInitIdleAggSecs &
    trackdf$distance.m <= segInitIdleAggMeters &
    trackdf$speed.m.s == 0
  startlineTime <- sum(trackdf$deltatime[startlinewait])
  stopsSubMinute <- sum(stoplength > 0 & stoplength < 60)
  stops1to10Minutes <- sum(stoplength >= 60 & stoplength < 600)
  stops10to30Minutes <- sum(stoplength >= 600 & stoplength < 1800)
  stopsLong <- sum(stoplength >= 1800)
  return(list(startlineTime=startlineTime,
              stopsSubMinute=stopsSubMinute,
              stops1to10Minutes=stops1to10Minutes,
              stops10to30Minutes=stops10to30Minutes,
              stopsLong=stopsLong))
}
#' clean up and add start/stop segments to a track tibble, add flag for stopped
#'
#' \code{processSegments}  processes a gps track file to correct or add
#'    start/stop segment information like that generated by gps autopause.
#'    The sequence of processing is: eliminate stops that are too short,
#'    split segments where time between observations is too large, split
#'    segments where stopped for longer than threshold, then merge segments
#'    which are too small.  Finally, all segment breaks too close to the
#'    start line are removed
#'
#' @param trackdf data frame or tibble with gps track data
#' @param segBreakTimeMin (seconds) segments separated by less time
#'    than this are joined
#' @param nonsegTimeGapMax (seconds) segemnts are split between datapoints
#'    separated by more time than this
#' @param segSplitTimeStop segments are split at points where
#' @param segMinObs segments smaller than this are joined to closest
#'    neighboring segment
#' @param segMinMeters segments shorter than this are joined with predecessor
#' @param segMinSecs (seconds) segments shorter than this are joined
#' @param segInitIdleAggSecs stops/restarts before this time has
#'    elapsed are discarded and the ride starts at the last start prior to this
#' @param segInitIdleAggMeters stops/restarts within this distance
#'    of the initial start are discarded as above
#' @param ignoreSegInfo wipe existing segment information and use
#'    \code{nonsegTimeGapMax} and \code{segSplitTimeStop} to
#'    reconstruct segments before merging short ones
#' @param loud display summary of actions
#' @param ... parameters for
#'    \code{\link{repairHR}},
#'    \code{\link{repairCadence}},
#'    \code{\link{statsCadence}},
#'    \code{\link{statsPower}},
#'    \code{\link{statsHeartRate}},
#'    \code{\link{statsGearing}},
#'    \code{\link{statsGrade}},
#'    \code{\link{statsSession}},
#'    \code{\link{statsStops}}
#'
#' @return a tibble containing track data with start/stop segment data
#'
#' @seealso \code{\link{read_ride}},
#'    \code{\link{repairHR}},
#'    \code{\link{repairCadence}},
#'    \code{\link{statsCadence}},
#'    \code{\link{statsPower}},
#'    \code{\link{statsHeartRate}},
#'    \code{\link{statsGearing}},
#'    \code{\link{statsGrade}},
#'    \code{\link{statsSession}},
#'    \code{\link{statsStops}}
#'
#' @export
processSegments <- function(trackdf,
                            segInitIdleAggSecs=60,
                            segInitIdleAggMeters=20,
                            segBreakTimeMin=3,
                            nonsegTimeGapMax=30,
                            segSplitTimeStop=3,
                            segMinObs=4,segMinMeters=20,segMinSecs=20,
                            ignoreSegInfo=FALSE,loud=FALSE,...) {
  #  demand some small amount of consistency
  segSplitTimeStop <- max(segSplitTimeStop,segBreakTimeMin)

  #   no observations will be deleted or added, so set up some useful stuff
  #
  timesecs <- cumsum(trackdf$deltatime)
  # usually will choose to set cadence to 0 if not moving, so will have no effect
  #  stopped <- trackdf$speed.m.s==0  &
  #                (is.na(trackdf$cadence.rpm) | trackdf$cadence.rpm==0)
  # try to catch random gps drift if sensors shut down at stop
  #   using filter on neightors, not a ts, remove that to hush dplyr warnings
  #   measured gps speed 0-0.2 mph indoors on window sill = 0.08 m/s
  #   (0.5-1.0 when warming up 10 feet inside window)
  temp <- as.vector(stats::filter(trackdf$speed.m.s, rep(1/5,5)))
  temp[is.na(temp)] <- trackdf$speed.m.s[is.na(temp)]
  stopped <- ((temp < 0.1 & trackdf$speed.m.s < 0.3) |
                trackdf$speed.m.s==0)     &
    ((is.na(trackdf$cadence.rpm) | trackdf$cadence.rpm==0))
  stopped[length(stopped)] <-TRUE
  starting <- !stopped & lag_one(stopped)
  starting[1] <- TRUE

  ###   now process segment and stop data
  #  wipe existing segment data from gps (auto)start/stop if requested
  #  otherwise make it a sequence of consecutive nondecreasing integers
  if (loud) {
    newseg <- trackdf$segment != lag_one(trackdf$segment)
    newseg[1] <- TRUE
    cat("starting out with ",1+sum(trackdf$segment!=lag_one(trackdf$segment)),
        " segments\n")
  }
  if (ignoreSegInfo) {
    if (loud) cat("wiping out existing segment data\n")
    trackdf$segment <- 1
  }
  newseg <- trackdf$segment != lag_one(trackdf$segment)
  newseg[1] <- TRUE
  # split really, really long intervals between points
  needsplit <- (trackdf$deltatime > nonsegTimeGapMax) & !newseg
  if (sum(needsplit) > 0) {
    if (loud) {
      cat("splitting ",sum(needsplit)," long intervals in same segment\n")
      # print(trackdf$timestamp.s[needsplit])
    }
    newseg <- newseg | needsplit
  }
  # join segment breaks which are too short
  needjoin <- (trackdf$deltatime < segBreakTimeMin) & newseg
  needjoin[1] <- FALSE
  if (sum(needjoin) > 0) {
    if (loud) {
      cat("joining ",sum(needjoin)," short breaks between segments\n")
      #print(trackdf$timestamp.s[needjoin])
    }
    newseg <- newseg & !needjoin
  }
  # split if time since last motion is too large
  lastmovedtime <- cummax(ifelse(stopped & !newseg,
                                 0,
                                 timesecs))
  stoptoolong <- c(FALSE,diff(lastmovedtime) >= segSplitTimeStop) &
    !stopped &
    lag_one(stopped)
  needsplit <- stoptoolong & !newseg
  if (sum(needsplit) > 0) {
    if (loud) {
      cat("splitting ",sum(needsplit)," segments with long stops\n")
      #print(trackdf$timestamp.s[needsplit])
    }
    newseg <- newseg | needsplit
  }

  ############################################################################
  # collapse too-short segments together  join them with previous segment
  #     (stops and start/stops occur at end of segment)
  #     build subsegment id to identify these for subsequent
  tempdf <-  trackdf %>% dplyr::select(timestamp.s,distance.m)
  newseg[1] <- TRUE  # do this before regenerate segment variable
  newsegBase <- newseg

  tempdf$segment <- cumsum(newseg)
  #  stack the last obs on bottom of newseg for diff'ing
  segobs <- newseg
  segobs[length(segobs)] <- TRUE
  segdf <- tempdf[segobs,]
  segmeters <- diff(segdf$distance.m)
  segsecs <- difftime(segdf$timestamp.s,
                      lag_one(segdf$timestamp.s),units="secs")[-1]
  segdf <- segdf[-nrow(segdf),]
  segdf$segmeters <- segmeters
  segdf$segsecs <- as.numeric(segsecs)

  tempdf <- tempdf %>%
    dplyr::group_by(segment) %>%
    dplyr::mutate(nobsinseg=n()) %>%
    dplyr::select(c("timestamp.s","nobsinseg","segment")) %>%
    dplyr::left_join(segdf,by=c("timestamp.s","segment"))
  tempdf[!newseg,"segmeters"] <- 0
  tempdf[!newseg,"segsecs"] <- 0
  needjoin <- (tempdf$nobsinseg < segMinObs) & newseg
  needjoin[1] <- FALSE
  if (sum(needjoin) > 0) {
    if (loud) {
      cat("joining ",sum(needjoin)," segments with fewer than ",
          segMinObs," obs\n")
      #print(trackdf$timestamp.s[needjoin])
    }
    newseg <- newseg & !needjoin
  }
  needjoin <- (tempdf$segmeters < segMinMeters) & newseg
  needjoin[1] <- FALSE
  if (sum(needjoin) > 0) {
    if (loud) {
      cat("joining ",sum(needjoin)," segments shorter than ",
          segMinMeters," meters\n")
      #print(trackdf$timestamp.s[needjoin])
    }
    newseg <- newseg & !needjoin
  }
  needjoin <- (tempdf$segsecs < segMinSecs) & newseg
  needjoin[1] <- FALSE
  if (sum(needjoin) > 0) {
    if (loud) {
      cat("joining ",sum(needjoin)," segments shorter than ",
          segMinSecs," seconds\n")
      #print(trackdf$timestamp.s[needjoin])
    }
    newseg <- newseg & !needjoin
  }
  newsegJoins <- newseg

  ###  now allow the first segment to include starts/stop issues at beginning
  insidefirstseg <- (cumsum(trackdf$deltatime) <= segInitIdleAggSecs)  |
    (trackdf$distance.m <= segInitIdleAggMeters)
  needjoin <- insidefirstseg & newseg
  needjoin[1] <- FALSE
  if (sum(needjoin) > 0) {
    if (loud) {
      cat("joining ",sum(needjoin)," segments at start\n")
      #print(trackdf$timestamp.s[needjoin])
    }
    newseg <- newseg & !needjoin
  }
  newsegStarted <- newseg

  #  these are only modifications to the track data tibble
  newseg[1] <- TRUE
  trackdf$segment <- cumsum(newseg)
  ###  flag "stop-py" parts of segment glued on the end
  ###   and "start-ty" parts of (first) segment
  ###   subseg > 1 is stop-py
  ###   subseg == 0 is start-ty
  trackdf$newsegBase=newsegBase
  trackdf <- trackdf %>%
    dplyr::mutate(joinseg=cumsum(newsegJoins)) %>%
    dplyr::group_by(joinseg) %>%
    dplyr::mutate(subsegment=cumsum(newsegBase)) %>%
    dplyr::ungroup() %>%
    dplyr::group_by(segment) %>%
    dplyr::mutate(starting = joinseg < max(joinseg) ) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(subsegment=if_else(starting, as.integer(0), subsegment)) %>%
    dplyr::select(-joinseg,-starting,-newsegBase)

  trackdf$stopped <- stopped
  trackdf$deltatimestart <- deltaTimeStart(trackdf$deltatime,trackdf$segment)
  if (loud) {
    cat("ending with ",sum(newseg)," segments\n")
  }

  return(trackdf)
}

deltaTimeStart <- function(deltatime,segment) {
  leaddeltatime <- c(deltatime[-1],0)
  dtime <- deltatime
  tdtime <- pmin(deltatime,leaddeltatime)
  dtime[segment != lag_one(segment)] <- tdtime[segment != lag_one(segment)]
  dtime
}