Merge pull request #33 from Robinlovelace/master

Add buff_geo and other small changes

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: stplanr
 Type: Package
 Title: Sustainable Transport Planning
-Version: 0.0.2
+Version: 0.0.3
 Date: 2015-10-18
 Authors@R: c(
     person("Robin", "Lovelace", email = "rob00x@gmail.com", role = c("aut", "cre")),
@@ -36,7 +36,8 @@ Imports:
     readr,
     lubridate,
     downloader,
-    RCurl
+    RCurl,
+    geosphere
 Suggests:
     testthat,
     knitr,

NAMESPACE

@@ -3,6 +3,7 @@
 export(age_recat)
 export(age_recat2)
 export(bbox_scale)
+export(buff_geo)
 export(calc_catchment)
 export(calc_catchment_sum)
 export(calc_moving_catchment)

NEWS

@@ -0,0 +1,22 @@
+stplanr 0.0.3
+----------------------------------------------------------------
+
+NEW FEATURES
+
+* Functions for removing beginning and end of lines: `toptail` and
+  `toptailgs` (@richardellison). Helper functions `buff_geo`,
+  `crs_select_aeq` and `line2points` added.
+
+* Functionality for reading in the UK's stats19 data: `read_stats19_*`
+  functions download, unzip and re-categorise the data.
+
+* `read_table` functions added for reading Australian OD data
+  (@richardellison).
+
+* `decode_gl` added to decode Google polylines (@richardellison).
+  Towards osrm routing in R!
+
+stplanr 0.0.2
+----------------------------------------------------------------
+
+* Published on CRAN

R/od-funs.R

@@ -139,24 +139,28 @@ line2points <- function(l){
 #' lines(routes_slow[n,], col = "green")
 
 line2route <- function(ldf, ...){
-  if(class(ldf) == "SpatialLinesDataFrame") ldf <- line2df(ldf)
-  rf <- route_cyclestreet(from = ldf[1,1:2], to = ldf[1, 3:4])
-
-  for(i in 2:nrow(ldf)){
+  if (class(ldf) == "SpatialLinesDataFrame") ldf <- line2df(ldf)
+  for (i in 1:nrow(ldf)){
     tryCatch({
-      # if (i==7) stop("Urgh, the iphone is in the blender !") # testing tryCatch
-      rfnew <- route_cyclestreet(from = ldf[i,1:2], to = ldf[i, 3:4], ...)
+
+      rfnew <- route_cyclestreet(from = ldf[i, 1:2], to = ldf[i,
+                                                              3:4], ...)
       row.names(rfnew) <- as.character(i)
-      rf <- maptools::spRbind(rf, rfnew)
-    }, error = function(e){print(paste0("Fail for line number ", i))})
 
-    # Status bar
-    perc_temp <- i %% round(nrow(ldf) / 10)
-    if(!is.na(perc_temp) & perc_temp == 0){
-      print(paste0(round(100 * i/nrow(ldf)), " % out of ", nrow(ldf),
-        " distances calculated")) # print % of distances calculated
+      if(!exists("rf")){
+        rf <- rfnew
+      } else {
+        rf <- maptools::spRbind(rf, rfnew)
+      }
+
+    }, error = function(e) {
+      print(paste0("Fail for line number ", i))
+    })
+    perc_temp <- i%%round(nrow(ldf)/10)
+    if (!is.na(perc_temp) & perc_temp == 0) {
+      print(paste0(round(100 * i/nrow(ldf)), " % out of ",
+                   nrow(ldf), " distances calculated"))
     }
   }
   rf
-}
-
+}

R/toptail.R

@@ -3,32 +3,41 @@
 #' Takes lines and removes the start and end point, to a distance determined
 #' by the user.
 #'
+#' Note: \code{\link{toptailgs}} is around 10 times faster, but only works
+#' on data with geographic CRS's due to its reliance on the geosphere
+#' package.
+#'
 #' @param l A SpatialLines object
 #' @param toptail_dist The distance (in metres) to top and tail the line by
+#' @param ... Arguments passed to rgeos::gBuffer()
 #' @export
 #' @examples
 #' data("routes_fast")
 #' sp::proj4string(routes_fast) <- CRS("+init=epsg:4326")
 #' r_toptail <- toptail(routes_fast, toptail_dist = 300)
 #' plot(routes_fast, lwd = 3)
 #' plot(r_toptail, col = "red", add = TRUE)
-#' plot(cents, add = TRUE)
+#' plot(cents, col = "blue", add = TRUE, pch = 15)
 #' # Note the behaviour when the buffer size removes lines
 #' r_toptail <- toptail(routes_fast, toptail_dist = 1000)
 #' length(r_toptail) # note short routes have been removed
 #' length(routes_fast)
 #' plot(routes_fast, lwd = 3)
 #' plot(r_toptail, col = "red", add = TRUE)
-toptail <- function(l, toptail_dist){
-  old_proj <- CRS(proj4string(l))
-  new_proj <- crs_select_aeq(l)
-  l <- sp::spTransform(l, new_proj)
+toptail <- function(l, toptail_dist, ...){
   for(i in 1:length(l)){
     l1 <- l[i,]
     lpoints <- line2points(l1)
-    sel <- rgeos::gBuffer(lpoints, width = toptail_dist)
+
+    # Create buffer for geographic or projected crs
+    if(!is.projected(l)){
+      sel <- buff_geo(lpoints, width = toptail_dist, ...)
+    } else {
+      sel <- rgeos::gBuffer(lpoints, width = toptail_dist, ...)
+    }
+
     if(rgeos::gContainsProperly(sel, l1)){
-      print(paste0("Line ", i, " is completely removed by the clip and",
+      message(paste0("Line ", i, " is completely removed by the clip and",
                    " is omitted from the results"))
       next
     }
@@ -39,7 +48,39 @@ toptail <- function(l, toptail_dist){
       out <- tmap::sbind(out, l2)
     }
   }
-  sp::spTransform(out, old_proj)
+  out
+}
+
+#' Create a buffer of n metres for non-projected 'geographical' spatial data
+#'
+#' Solves the problem that buffers will not be circular when used on
+#' non-projected data.
+#'
+#' Returns a
+#'
+#' @param sp_obj A spatial object with a geographic CRS (WGS84)
+#' around which a buffer should be drawn
+#' @param width The distance (in metres) of the buffer
+#' @param ... Arguments passed to rgeos::gBuffer()
+#' @param silent A binary value for printing the CRS details (default: FALSE)
+#' @export
+#' @examples
+#' data("routes_fast")
+#' sp::proj4string(routes_fast) <- CRS("+init=epsg:4326")
+#' buff <- buff_geo(routes_fast, width = 100)
+#' plot(buff)
+#' plot(routes_fast, add = TRUE)
+buff_geo <- function(sp_obj, width, ..., silent = TRUE){
+  old_proj <- CRS(proj4string(sp_obj))
+  new_proj <- crs_select_aeq(sp_obj)
+  if(silent == FALSE){
+    message(paste0("The new Azimuthal equidistant projection",
+    "used to create the buffer was ", new_proj))
+    message(paste0("The original projection was ", old_proj))
+  }
+  sp_obj <- sp::spTransform(sp_obj, new_proj)
+  buff <- rgeos::gBuffer(sp_obj, width = width, ...)
+  sp::spTransform(buff, old_proj)
 }
 
 #' Clip the first and last n metres of SpatialLines
@@ -86,4 +127,4 @@ toptailgs <- function(l, toptail_dist) {
     i <- i + 1
   }
   return(l)
-}
+}