Add ability for overline to use grouping variables.

R/overline.R

@@ -75,10 +75,13 @@ lineLabels <- function(sldf, attrib){
 #' and converts these into a single route network.
 #'
 #' @param sldf A SpatialLinesDataFrame with overlapping elements
-#' @param attrib A text string corresponding to the variable in \code{sldf$} on
-#' which the function will operate.
-#' @param fun The function used to aggregate the grouped values (default: sum)
+#' @param attrib A character vector corresponding to the variables in
+#' \code{sldf$} on which the function(s) will operate.
+#' @param fun The function(s) used to aggregate the grouped values (default: sum).
+#' If length of \code{fun} is smaller than \code{attrib} then the functions are
+#' repeated for subsequent attributes.
 #' @param na.zero Sets whether aggregated values with a value of zero are removed.
+#' @param byvars Character vector containing the column names to use for grouping
 #'
 #' @author Barry Rowlingson
 #' @references
@@ -110,26 +113,94 @@ lineLabels <- function(sldf, attrib){
 #' flowlines_1way <- maptools::spRbind(flowlines_sub, flowlines_2way)
 #' overlaps <- over()
 #' nrow(overlaps)
+#' routes_fast$group = rep(1:3, length.out = nrow(routes_fast))
+#' rnet_grouped = overline(routes_fast, attrib = "length", byvars = "group")
 #' }
-overline <- function(sldf, attrib, fun = sum, na.zero = FALSE){
-  ## simplify down to SpatialLines
-  sl = as(sldf, "SpatialLines")
-  ## get the line sections that make the network
-  slu = gsection(sl)
-  ## overlay network with routes
-  overs = sp::over(slu, sl, returnList=TRUE)
-  ## overlay is true if end points overlay, so filter them out:
-  overs = lapply(1:length(overs), function(islu){
-    Filter(function(isl){
-      islines(sl[isl,],slu[islu,])
-    }, overs[[islu]])
-  })
-  ## now aggregate the required attribibute using fun():
-  aggs = sapply(overs, function(os){fun(sldf[[attrib]][os])})
+overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){
 
-  ## make a SLDF with the named attribibute:
-  sldf = sp::SpatialLinesDataFrame(slu, data.frame(Z=aggs))
-  names(sldf) = attrib
+  fun <- c(fun)
+  if (length(fun) < length(attrib)) {
+    fun <- rep(c(fun),length.out=length(attrib))
+  }
+
+  if (is.na(byvars[1]) == TRUE) {
+    ## simplify down to SpatialLines
+    sl = as(sldf, "SpatialLines")
+    ## get the line sections that make the network
+    slu = gsection(sl)
+    ## overlay network with routes
+    overs = sp::over(slu, sl, returnList=TRUE)
+    ## overlay is true if end points overlay, so filter them out:
+    overs = lapply(1:length(overs), function(islu){
+      Filter(function(isl){
+        islines(sl[isl,],slu[islu,])
+      }, overs[[islu]])
+    })
+    ## now aggregate the required attribibute using fun():
+    #aggs = sapply(overs, function(os){fun(sldf[[attrib]][os])})
+    aggs <- setNames(
+      as.data.frame(
+        lapply(1:length(attrib),
+               function(y, overs, attribs, aggfuns){
+                 sapply(overs, function(os,attrib,fun2){
+                   fun2(sldf[[attrib]][os])},
+                   attrib=attribs[y],
+                   fun2=aggfuns[[y]])
+                 },
+               overs,
+               attrib,
+               fun)),
+      attrib)
+
+    ## make a SLDF with the named attribibute:
+    sldf = sp::SpatialLinesDataFrame(slu, aggs)
+    #names(sldf) = attrib
+  } else {
+
+    splitlines <- lapply(
+      split(sldf, sldf@data[,byvars]),
+      function(x, attrib, gvar){
+        groupingcat <- unname(unlist(unique(x@data[,gvar])))
+        sl = as(x, "SpatialLines")
+        slu = gsection(sl)
+        overs = sp::over(slu, sl, returnList = TRUE)
+        overs = lapply(1:length(overs), function(islu) {
+          Filter(function(isl){islines(sl[isl,],slu[islu,])}, overs[[islu]])
+        })
+        #aggs = sapply(overs, function(os){fun(x[[attrib]][os])})
+        aggs <- setNames(
+          as.data.frame(
+            lapply(1:length(attrib),
+                   function(y, overs, attribs, aggfuns){
+                     sapply(overs, function(os,attrib,fun2){
+                       fun2(x[[attrib]][os])},
+                       attrib=attribs[y],
+                       fun2=aggfuns[[y]])
+                   },
+                   overs,
+                   attrib,
+                   fun)
+            ),
+          attrib)
+        sldf = sp::SpatialLinesDataFrame(slu, cbind(aggs,as.data.frame(matrix(groupingcat,nrow=1))))
+        names(sldf) = c(attrib,gvar)
+        sldf <- spChFIDs(sldf, paste(paste(groupingcat,collapse='.'),row.names(sldf@data),sep='.'))
+        sldf
+      },
+      attrib,
+      c(byvars)
+    )
+
+    splitlinesdf <- data.frame(data.table::rbindlist(lapply(splitlines, function(x){x@data})))
+    row.names(splitlinesdf) <- unname(unlist(lapply(splitlines, function(x){row.names(x@data)})))
+
+    sldf <- SpatialLinesDataFrame(
+      SpatialLines(unlist(lapply(splitlines, function(x){x@lines}), recursive = FALSE),
+                   proj4string = splitlines[[1]]@proj4string),
+      splitlinesdf
+    )
+
+  }
 
   ## remove lines with attribute values of zero
   if(na.zero == TRUE){