Merge pull request #216 from r-transit/dev/partial_matching

Fix partial matching issues

R/dates.R

@@ -27,12 +27,12 @@ set_dates_services <- function(gtfs_obj) {
 
   feed_dates = list()
   if(has_calendar) {
-    feed_dates$calendar <- c(gtfs_obj$calendar$start_date, gtfs_obj$calendar$end_date)
+    feed_dates[["calendar"]] <- c(gtfs_obj$calendar$start_date, gtfs_obj$calendar$end_date)
   }
   if(has_calendar_dates) {
-    feed_dates$calendar_dates <- gtfs_obj$calendar_dates$date[which(gtfs_obj$calendar_dates$exception_type != 2)]
+    feed_dates[["calendar_dates"]] <- gtfs_obj$calendar_dates$date[which(gtfs_obj$calendar_dates$exception_type != 2)]
   }
-  if(length(feed_dates$calendar) == 0 && length(feed_dates$calendar_dates) == 0) {
+  if(length(feed_dates[["calendar"]]) == 0 && length(feed_dates[["calendar_dates"]]) == 0) {
     warning("No valid dates defined in feed")
     return(gtfs_obj)
   }
@@ -45,8 +45,8 @@ set_dates_services <- function(gtfs_obj) {
         "saturday")[as.POSIXlt(date)$wday + 1]
     }
 
-    min_date = min(feed_dates$calendar, na.rm = TRUE)
-    max_date = max(feed_dates$calendar, na.rm = TRUE)
+    min_date = min(feed_dates[["calendar"]], na.rm = TRUE)
+    max_date = max(feed_dates[["calendar"]], na.rm = TRUE)
     # get first and last date of a feed
     dates <- dplyr::tibble(
       date = seq(min_date, max_date, 1),
@@ -56,8 +56,8 @@ set_dates_services <- function(gtfs_obj) {
     # gather services by weekdays
     .availability = NULL
     .days = c("monday", "tuesday", "wednesday", "thursday", "friday", "saturday", "sunday") 
-    .cns_nondays = colnames(gtfs_obj$calendar)[which(!colnames(gtfs_obj$calendar) %in% .days)]
-    service_ids_weekdays = gtfs_obj$calendar %>% 
+    .cns_nondays = colnames(gtfs_obj[["calendar"]])[which(!colnames(gtfs_obj[["calendar"]]) %in% .days)]
+    service_ids_weekdays = gtfs_obj[["calendar"]] %>% 
       reshape(gc, direction = "long", idvar = .cns_nondays, varying = .days, 
               v.names = ".availability", timevar = "weekday_num") %>% 
       left_join(data.frame(weekday_num = 1:7, weekday = .days), "weekday_num") %>% 
@@ -74,7 +74,7 @@ set_dates_services <- function(gtfs_obj) {
     # addtions and exceptions
     if(has_calendar_dates) {
       # add calendar_dates additions (1)
-      additions = gtfs_obj$calendar_dates %>% 
+      additions = gtfs_obj[["calendar_dates"]] %>% 
         filter(exception_type == 1) %>% 
         dplyr::select(-exception_type)
       if(nrow(additions) > 0) {
@@ -84,7 +84,7 @@ set_dates_services <- function(gtfs_obj) {
       }
 
       # remove calendar_dates exceptions (2) 
-      exceptions = gtfs_obj$calendar_dates %>% 
+      exceptions = gtfs_obj[["calendar_dates"]] %>% 
         dplyr::filter(exception_type == 2) %>% 
         dplyr::select(-exception_type)
       if(nrow(exceptions) > 0) {
@@ -94,7 +94,7 @@ set_dates_services <- function(gtfs_obj) {
       }
     }
   } else if(has_calendar_dates) { # only calendar_dates.txt
-    date_service_df = gtfs_obj$calendar_dates[gtfs_obj$calendar_dates$exception_type != 2, c("date", "service_id")]
+    date_service_df = gtfs_obj[["calendar_dates"]][gtfs_obj$calendar_dates$exception_type != 2, c("date", "service_id")]
     date_service_df <- dplyr::as_tibble(date_service_df)
   }
 

R/service.R

@@ -34,21 +34,21 @@ set_servicepattern <- function(gtfs_obj, id_prefix = "s_", hash_algo = "md5", ha
 
   # find servicepattern_ids for all services
   servicepattern_id <- NULL # prevents CMD chek note on non-visible binding
-  service_pattern <- gtfs_obj$.$dates_services %>% 
+  service_patterns <- gtfs_obj$.$dates_services %>% 
     group_by(service_id) %>%
     summarise(
       servicepattern_id = get_servicepattern_id(.data$date)
     ) %>% ungroup()
 
-  # find dates for servicepattern
+  # find dates for servicepatterns
   dates_servicepatterns <- gtfs_obj$.$dates_services %>% 
-    left_join(service_pattern, by = "service_id") %>% 
+    left_join(service_patterns, by = "service_id") %>% 
     group_by(date, servicepattern_id) %>% 
     summarise() %>% ungroup()
 
   # assign to gtfs_obj
-  gtfs_obj$.$servicepatterns <- service_pattern
-  gtfs_obj$.$dates_servicepatterns <- dates_servicepatterns
+  gtfs_obj$.[["servicepatterns"]] <- service_patterns
+  gtfs_obj$.[["dates_servicepatterns"]] <- dates_servicepatterns
 
   return(gtfs_obj)
 }

tests/testthat/test-frequencies.R

@@ -23,15 +23,15 @@ test_that("Route frequencies (headways)", {
 
 test_that("Route frequencies (headways) w/ service id", {
   # TODO rewrite with synthesized sample data
-  routes_frequency <- get_route_frequency(gtfs_duke, service_id = "c_883_b_21967_d_31")
+  routes_frequency <- get_route_frequency(gtfs_duke, service_ids = "c_883_b_21967_d_31")
   expect_equal(routes_frequency[routes_frequency$route_id == 1680, ]$median_headways, (53+1/3)*60)
 
-  expect_error(get_route_frequency(gtfs_duke, service_id = "unknown"), 
+  expect_error(get_route_frequency(gtfs_duke, service_ids = "unknown"), 
                  "Failed to calculate frequency, no departures found")
 
   gtfs_duke2 = gtfs_duke
   gtfs_duke2$frequencies[1,] <- list("t_674449_b_19828_tn_21", "00:00:00", "23:00:00", 60, 0)
-  expect_message(get_route_frequency(gtfs_duke2, service_id = "c_883_b_21967_d_31"), 
+  expect_message(get_route_frequency(gtfs_duke2, service_ids = "c_883_b_21967_d_31"), 
                  "A pre-calculated frequencies dataframe exists for this feed already, consider using that.")
 
 })

tests/testthat/test-raptor.R

@@ -101,11 +101,11 @@ test_that("parameters are checked", {
 
 test_that("pick transfers from attributes", {
   fst = filter_stop_times(gtfs_routing, "2018-10-01", 7*3600)
-  r1 = raptor(fst, stop_id = "stop5")
-  r2 = raptor(gtfs_routing$stop_times, gtfs_routing$transfers, stop_id = "stop5")
+  r1 = raptor(fst, stop_ids = "stop5")
+  r2 = raptor(gtfs_routing$stop_times, gtfs_routing$transfers, stop_ids = "stop5")
   expect_equal(r1, r2)
-  expect_error(raptor(gtfs_routing$stop_times, stop_id = "stop5"), 'argument "transfers" is missing, with no default')
-  expect_error(raptor(gtfs_routing, stop_id = "stop5"), 'Travel times cannot be calculated with a tidygtfs object')
+  expect_error(raptor(gtfs_routing$stop_times, stop_ids = "stop5"), 'argument "transfers" is missing, with no default')
+  expect_error(raptor(gtfs_routing, stop_ids = "stop5"), 'Travel times cannot be calculated with a tidygtfs object')
 })
 
 test_that("earliest arrival times", {

tests/testthat/test-travel_times.R

@@ -104,7 +104,7 @@ test_that("travel_times with arrival=TRUE stop_name", {
 test_that("catch invalid params", {
   expect_error(travel_times(gtfs_routing, stop_name = "One"), "Travel times cannot be calculated with an unfiltered tidygtfs object. Use filter_feed_by_date().")
   fst = filter_stop_times(gtfs_routing, "2018-10-01", 7*3600, 24*3600)
-  expect_error(raptor(fst, attributes(fst)$transfers, stop_id = "stop1a", max_transfers = -1), "max_transfers is less than 0")
+  expect_error(raptor(fst, attributes(fst)$transfers, stop_ids = "stop1a", max_transfers = -1), "max_transfers is less than 0")
   expect_error(travel_times(fst, stop_name = "One", max_transfers = -1), "max_transfers is less than 0")
 })
 

vignettes/frequency.Rmd

@@ -132,7 +132,7 @@ We'll use that pattern below to pull out the service_ids that we need to use to
 trips in the GTFS feed for which we want to summarise service. 
 
 ```{r}
-service_ids <- gtfs$.$servicepattern %>% 
+service_ids <- gtfs$.$servicepatterns %>% 
   filter(servicepattern_id == 's_e25d6ca') %>% 
   pull(service_id)
 

vignettes/servicepatterns.Rmd

@@ -239,7 +239,7 @@ We can plot the number of trips for each day as a calendar heat map.
 
 ```{r fig.height=4, fig.width=7}
 trips_servicepattern = left_join(select(gtfs$trips, trip_id, service_id), gtfs$.$servicepatterns, by = "service_id")
-trip_dates = left_join(gtfs$.$dates_servicepatterns, trips_servicepattern, by = "servicepattern_id")
+trip_dates = left_join(gtfs$.$dates_servicepatterns, trips_servicepattern, by = "servicepattern_id", relationship = "many-to-many")
 
 trip_dates_count = trip_dates %>% group_by(date) %>% summarise(count = dplyr::n()) 
 trip_dates_count$weekday <- lubridate::wday(trip_dates_count$date, label = T, abbr = T, week_start = 7)

vignettes/timetable.Rmd

@@ -202,7 +202,7 @@ stop_ids. The following plot shows all departures for stop_ids 127N and 127S fro
 ```{r fig.width=6, fig.height=6}
 departures_180823_sub_7to8 <- departures_180823 %>% 
   filter(stop_id %in% c("127N", "127S")) %>% 
-  filter(departure_time >= hms::hms(hours = 7) & departure_time <= hms::hms(hour = 8))
+  filter(departure_time >= hms::hms(hours = 7) & departure_time <= hms::hms(hours = 8))
 
 ggplot(departures_180823_sub_7to8) + theme_bw() +
   geom_point(aes(y=trip_headsign, x=departure_time, color = route_short_name), size = 1) +