From 5d7d0608d3b1ecccd87673f3b418a625afc87857 Mon Sep 17 00:00:00 2001 From: Richard Ellison Date: Sun, 21 Aug 2016 19:56:15 +1000 Subject: [PATCH 1/6] Add ability for overline to using grouping variables. --- R/overline.R | 71 +++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 53 insertions(+), 18 deletions(-) diff --git a/R/overline.R b/R/overline.R index 1f51674d..272499cf 100644 --- a/R/overline.R +++ b/R/overline.R @@ -79,6 +79,7 @@ lineLabels <- function(sldf, attrib){ #' which the function will operate. #' @param fun The function used to aggregate the grouped values (default: sum) #' @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 @@ -111,25 +112,59 @@ lineLabels <- function(sldf, attrib){ #' overlaps <- over() #' nrow(overlaps) #' } -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 + 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])}) + + ## make a SLDF with the named attribibute: + sldf = sp::SpatialLinesDataFrame(slu, data.frame(Z=aggs)) + names(sldf) = attrib + } else { + + splitlines <- lapply( + split(sldf, sldf@data[,c('ts_typ_cd','route_var_id')]), + 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(sldf[[attrib]][os])}) + sldf = sp::SpatialLinesDataFrame(slu, cbind(data.frame(Z=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('ts_typ_cd','route_var_id') + ) + + 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){ From ac74e4bdcdabff5d121b3386848f64e6d2fb3bf7 Mon Sep 17 00:00:00 2001 From: Richard Ellison Date: Tue, 23 Aug 2016 07:56:25 +1000 Subject: [PATCH 2/6] Build documentation and correct errors in initial commit. --- R/overline.R | 4 ++-- man/overline.Rd | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/R/overline.R b/R/overline.R index 272499cf..4a9b953b 100644 --- a/R/overline.R +++ b/R/overline.R @@ -136,7 +136,7 @@ overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ } else { splitlines <- lapply( - split(sldf, sldf@data[,c('ts_typ_cd','route_var_id')]), + split(sldf, sldf@data[,byvars]), function(x, attrib, gvar){ groupingcat <- unname(unlist(unique(x@data[,gvar]))) sl = as(x, "SpatialLines") @@ -152,7 +152,7 @@ overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ sldf }, attrib, - c('ts_typ_cd','route_var_id') + c(byvars) ) splitlinesdf <- data.frame(data.table::rbindlist(lapply(splitlines, function(x){x@data}))) diff --git a/man/overline.Rd b/man/overline.Rd index 5525af28..9e8f6bab 100644 --- a/man/overline.Rd +++ b/man/overline.Rd @@ -4,7 +4,7 @@ \alias{overline} \title{Convert series of overlapping lines into a route network} \usage{ -overline(sldf, attrib, fun = sum, na.zero = FALSE) +overline(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA) } \arguments{ \item{sldf}{A SpatialLinesDataFrame with overlapping elements} @@ -15,6 +15,8 @@ which the function will operate.} \item{fun}{The function used to aggregate the grouped values (default: sum)} \item{na.zero}{Sets whether aggregated values with a value of zero are removed.} + +\item{byvars}{Character vector containing the column names to use for grouping} } \description{ This function takes a series of Lines stored in a From a8b574b32219504d56317a6c317bdfc29d8f92d1 Mon Sep 17 00:00:00 2001 From: Richard Ellison Date: Tue, 23 Aug 2016 07:59:20 +1000 Subject: [PATCH 3/6] Add example for grouped overline. --- R/overline.R | 2 ++ man/overline.Rd | 2 ++ 2 files changed, 4 insertions(+) diff --git a/R/overline.R b/R/overline.R index 4a9b953b..8bb5a2c3 100644 --- a/R/overline.R +++ b/R/overline.R @@ -111,6 +111,8 @@ 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, byvars = NA){ diff --git a/man/overline.Rd b/man/overline.Rd index 9e8f6bab..0debcd98 100644 --- a/man/overline.Rd +++ b/man/overline.Rd @@ -47,6 +47,8 @@ flowlines_2way <- spChFIDs(flowlines_2way, as.character(100001:(nrow(flowlines_2 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") } } \author{ From 08ca976ba85fb15e652336bd37228559184bda31 Mon Sep 17 00:00:00 2001 From: Richard Ellison Date: Tue, 23 Aug 2016 16:33:33 +1000 Subject: [PATCH 4/6] Fix aggregation error on grouped overline. --- R/overline.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/overline.R b/R/overline.R index 8bb5a2c3..986bf1b2 100644 --- a/R/overline.R +++ b/R/overline.R @@ -147,7 +147,7 @@ overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ overs = lapply(1:length(overs), function(islu) { Filter(function(isl){islines(sl[isl,],slu[islu,])}, overs[[islu]]) }) - aggs = sapply(overs, function(os){fun(sldf[[attrib]][os])}) + aggs = sapply(overs, function(os){fun(x[[attrib]][os])}) sldf = sp::SpatialLinesDataFrame(slu, cbind(data.frame(Z=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='.')) From 4f100059d5a1b3f046e94d0e5879c82893206082 Mon Sep 17 00:00:00 2001 From: Richard Ellison Date: Tue, 23 Aug 2016 18:46:51 +1000 Subject: [PATCH 5/6] Update overline to allow aggregation on multiple variables and functions. --- R/overline.R | 49 +++++++++++++++++++++++++++++++++++++++++-------- man/overline.Rd | 8 +++++--- 2 files changed, 46 insertions(+), 11 deletions(-) diff --git a/R/overline.R b/R/overline.R index 986bf1b2..d65dcb7a 100644 --- a/R/overline.R +++ b/R/overline.R @@ -75,9 +75,11 @@ 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 #' @@ -116,6 +118,10 @@ lineLabels <- function(sldf, attrib){ #' } overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ + 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") @@ -130,11 +136,24 @@ overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ }, overs[[islu]]) }) ## now aggregate the required attribibute using fun(): - aggs = sapply(overs, function(os){fun(sldf[[attrib]][os])}) + #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, data.frame(Z=aggs)) - names(sldf) = attrib + sldf = sp::SpatialLinesDataFrame(slu, aggs) + #names(sldf) = attrib } else { splitlines <- lapply( @@ -147,8 +166,22 @@ overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ 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])}) - sldf = sp::SpatialLinesDataFrame(slu, cbind(data.frame(Z=aggs),as.data.frame(matrix(groupingcat,nrow=1)))) + #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 diff --git a/man/overline.Rd b/man/overline.Rd index 0debcd98..293b725a 100644 --- a/man/overline.Rd +++ b/man/overline.Rd @@ -9,10 +9,12 @@ overline(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA) \arguments{ \item{sldf}{A SpatialLinesDataFrame with overlapping elements} -\item{attrib}{A text string corresponding to the variable in \code{sldf$} on -which the function will operate.} +\item{attrib}{A character vector corresponding to the variables in +\code{sldf$} on which the function(s) will operate.} -\item{fun}{The function used to aggregate the grouped values (default: sum)} +\item{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.} \item{na.zero}{Sets whether aggregated values with a value of zero are removed.} From 9d66240664c26d30511e8a75f19f68e03a39f566 Mon Sep 17 00:00:00 2001 From: Richard Ellison Date: Tue, 23 Aug 2016 22:52:35 +1000 Subject: [PATCH 6/6] Make sure fun in overline is always a vector that can be subset. --- R/overline.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/overline.R b/R/overline.R index d65dcb7a..e59b7efd 100644 --- a/R/overline.R +++ b/R/overline.R @@ -118,6 +118,7 @@ lineLabels <- function(sldf, attrib){ #' } overline <- function(sldf, attrib, fun = sum, na.zero = FALSE, byvars = NA){ + fun <- c(fun) if (length(fun) < length(attrib)) { fun <- rep(c(fun),length.out=length(attrib)) }