Merge pull request #21 from pbsag/feature/vmt

Feature/vmt

.Rbuildignore

@@ -0,0 +1,2 @@
+^.*\.Rproj$
+^\.Rproj\.user$

DESCRIPTION

@@ -10,8 +10,11 @@ Description: We commonly look at the same tables and reports from travel demand
 License: file LICENSE
 LazyData: TRUE
 RoxygenNote: 5.0.1.9000
-Depends: R (>= 3.2.2)
-Imports: dplyr (>= 0.4.3),
+Depends:
+    R (>= 3.2.2)
+Imports:
+    dplyr (>= 0.4.3),
     ggplot2 (>= 2.1.0),
     lazyeval (>= 0.1.10)
-Suggests: knitr
+Suggests:
+    knitr

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 export(cut_volumes)
+export(link_measures_table)
 export(link_stats_table)
 export(link_targets)
 export(numerify)
@@ -12,3 +13,4 @@ export(rmse)
 import(dplyr)
 import(ggplot2)
 import(lazyeval)
+importFrom(lazyeval,interp)

R/assignment_tables.R

@@ -21,6 +21,8 @@
 #' link_stats_table(links, "volume", "count", group_field = "facility_group", type = "flow")
 #'
 #'
+#'
+#'
 #' @export
 link_stats_table <- function(links, volume, count, group_field = NULL,
                              volume_breaks = c(0, 5, 10, 15, 20, 40, 60, Inf),
@@ -103,6 +105,116 @@ link_stats_table <- function(links, volume, count, group_field = NULL,
 }
 
 
+#' Link Measures Table
+#'
+#' @inheritParams plot_validation
+#' @param group_field Character string identifying variable to
+#'   group observations by, for example facility type. If set to same value
+#'   as \code{volume}, will cut into bins.
+#' @param volume_breaks Numeric vector passed on to \code{cut()} identifying the
+#'   breakpoints in the volume groups. Number in thousands, i.e.: 10, 20
+#' @param type Which type of table to print. Currently supports VMT, VHT, VHD and VOC.
+#'
+#' @param distance Character string identifying the distance in the link table.
+#'
+#' @param speed Character string identifying the modeled speed in the link table.
+#'
+#' @param ffspeed Character string identifying the free-flow speed in the link table.
+#'
+#' @param capacity Character string identifying the capacity in the link table.
+#'
+#' @return A \code{data_frame} with the link summary table.
+#'
+#' @import dplyr
+#' @importFrom lazyeval interp
+#'
+#' @examples
+#' link_measures_table(links, "volume", distance = "distance",
+#'   group_field = "area_name", type = "vmt")
+#' link_measures_table(links, "volume", distance = "distance",
+#'   group_field = "facility_group", type = "vmt")
+#' link_measures_table(links, "volume", distance = "distance", speed = "speed",
+#'   group_field = "area_name", type = "vht")
+#' link_measures_table(links, "volume", distance = "distance", speed = "speed",
+#'   group_field = "facility_group", type = "vht")
+#' link_measures_table(links, "volume", distance = "distance", speed = "speed",
+#'   ffspeed = "ffspeed",  group_field = "area_name", type = "vhd")
+#' link_measures_table(links, "volume", distance = "distance", speed = "speed",
+#'   ffspeed = "ffspeed",  group_field = "facility_group", type = "vhd")
+#' link_measures_table(links, "volume", capacity = "capacity",
+#'   group_field = "area_name", type = "voc")
+#' link_measures_table(links, "volume", capacity = "capacity",
+#'   group_field = "facility_group", type = "voc")
+#'
+#'
+#' @export
+link_measures_table <- function(links, volume, distance = NULL,
+                                speed = NULL, ffspeed = NULL,
+                                capacity = NULL, group_field = NULL,
+                             volume_breaks = c(0, 5, 10, 15, 20, 40, 60, Inf),
+                             type = c("vmt", "vht", "vhd", "voc")){
+
+  # must supply group_field
+  if(is.null(group_field)){
+    stop("Must supply grouping variable")
+  }
+
+
+  # If group and volume are the same, cut into a pretty vector,
+  # if they are different, make sure that the variable is factored.
+  if(group_field == volume){
+    links <- volume_levels(links, group_field, volume_breaks)
+    group_field <- "Volume_Group"
+  } else {
+    links <- refactor_levels(links, group_field)
+  }
+
+  if(type == "vmt"){
+    # vehicle miles traveled
+    fn_agg <- lazyeval::interp(
+      ~sum(x*y), x = as.name(volume), y = as.name(distance))
+  } else if(type == "vht"){
+    # vehicle hours traveled
+    fn_agg <- lazyeval::interp(
+      ~sum(x*y/z), x = as.name(volume), y = as.name(distance),
+      z = as.name(speed))
+  } else if(type == "vhd"){
+    # vehicle hours of delay
+    fn_agg <- lazyeval::interp(
+      ~sum(x*(y/a-y/b)), x = as.name(volume), y = as.name(distance),
+      a = as.name(speed), b = as.name(ffspeed))
+  } else if(type == "voc"){
+    # volume-to-capacity ratio
+    fn_agg <- lazyeval::interp(
+      ~sum(x/y), x = as.name(volume), y = as.name(capacity))
+  }
+
+
+  # build grouping table
+  dots <- list( lazyeval::interp(~n()), fn_agg)
+
+  lt <- links %>%
+    group_by_(group_field) %>%
+    summarise_(.dots = setNames(dots, c("Number of Links", toupper(type))))
+
+  #totals row
+  dots[[3]] <- lazyeval::interp(~as.character(x), x = "Total")
+
+  tot <- links %>%
+    ungroup() %>%
+    summarise_(.dots = setNames(
+      dots,  c("Number of Links", toupper(type), as.character(group_field))
+    ))
+
+  suppressWarnings(
+    # this will complain because we are joining a factor to a
+    # character. don't need to worry
+    bind_rows(lt, tot)
+  )
+
+
+
+}
 
 #' Refactor a variable so that it prints properly.
 #'

R/data.R

@@ -31,6 +31,11 @@ NULL
 #'   \item{volume}{Modeled link volume}
 #'   \item{screenline}{The screenline that the links belong to}
 #'   \item{count}{The calibration year count value}
+#'   \item{distance}{The distance value in miles}
+#'   \item{capacity}{The capacity value of the links}
+#'   \item{ffspeed}{The free-flow speed of the links in mph}
+#'   \item{speed}{The speed of the links in mph}
+#'
 #' }
 #'
 "links"