Skip to content

Commit

Permalink
Style package with styler.equals::style_pkg()
Browse files Browse the repository at this point in the history
  • Loading branch information
Robinlovelace committed Aug 20, 2024
1 parent 3d3a211 commit 185bb31
Show file tree
Hide file tree
Showing 13 changed files with 120 additions and 113 deletions.
21 changes: 10 additions & 11 deletions R/aggregate.R
Original file line number Diff line number Diff line change
Expand Up @@ -61,7 +61,7 @@
#' subzones = od_data_zones_small
#' try(od_disaggregate(od, zones, subzones))
#' od_disag = od_disaggregate(od, zones, subzones, max_per_od = 500)
#' ncol(od_disag) -3 == ncol(od) # same number of columns, the same...
#' ncol(od_disag) - 3 == ncol(od) # same number of columns, the same...
#' # Except disag data gained geometry and new agg ids:
#' sum(od_disag[[3]]) == sum(od[[3]])
#' sum(od_disag[[4]]) == sum(od[[4]])
Expand All @@ -81,12 +81,11 @@ od_disaggregate = function(od,
population_column = 3,
max_per_od = 5,
keep_ids = TRUE,
integer_outputs = FALSE
) {
integer_outputs = FALSE) {
od$nrows = od_nrows(od, population_column, max_per_od)
azn = paste0(names(z)[1], code_append)
# is the input od data an sf object? tell the user and convert to df if so
if(methods::is(object = od, class2 = "sf")) {
if (methods::is(object = od, class2 = "sf")) {
message("Input object is sf, attempting to convert to a data frame")
od = sf::st_drop_geometry(od)
}
Expand Down Expand Up @@ -134,7 +133,7 @@ od_disaggregate = function(od,
max_n_od = ceiling(od[[population_column]][i] / max_per_od)
o_options = subpoints[[1]][subpoints[[azn]] == od[[1]][i]]
d_options = subpoints[[1]][subpoints[[azn]] == od[[2]][i]]
if(max_n_od > length(o_options) || max_n_od > length(d_options)) {
if (max_n_od > length(o_options) || max_n_od > length(d_options)) {
warning("Insufficient subzones/points to prevent duplicate desire lines")
message("Sampling may fail. Try again with larger max_per_od")
}
Expand All @@ -145,17 +144,17 @@ od_disaggregate = function(od,
odn_list = lapply(od[i, -c(1, 2)], function(x) x / nrow(od_new))
odns = as.data.frame(odn_list)[rep(1, nrow(od_new)), , drop = FALSE]
names(odns) = numeric_col_names
if(integer_outputs) {
if (integer_outputs) {
odns[] = apply(odns, 2, function(x) smart.round(x))
}
od_new = cbind(od_new, odns)
if(keep_ids) {
if (keep_ids) {
od_new$o_agg = od[[1]][i]
od_new$d_agg = od[[2]][i]
}
od_new_sf = od::od_to_sf(od_new, subpoints, silent = TRUE)
# Remove sampled points from 'universe' of available points
if(i < nrow(od)) {
if (i < nrow(od)) {
subpoints <<- subpoints[!subpoints[[1]] %in% c(o, d), ]
}
od_new_sf
Expand Down Expand Up @@ -225,7 +224,7 @@ od_split = od_disaggregate

smart.round = function(x) {
y = floor(x)
indices = utils::tail(order(x-y), round(sum(x)) - sum(y))
indices = utils::tail(order(x - y), round(sum(x)) - sum(y))
y[indices] = y[indices] + 1
y
}
Expand All @@ -240,7 +239,7 @@ smart.round = function(x) {
#' \dontrun{
#' u = "https://github.com/ITSLeeds/od/releases/download/v0.3.1/road_network_min.Rds"
#' f = basename(u)
#' if(!file.exists(f)) download.file(u, f)
#' if (!file.exists(f)) download.file(u, f)
#' road_network_min = readRDS(f)
#' od_sample_vertices(road_network_min)
#' }
Expand Down Expand Up @@ -292,7 +291,7 @@ od_sample_points = function(subpoints, subdf, z, per_zone, azn = "azn") {
subpoints_joined = sf::st_join(sf::st_sf(subpoints), z[1])
sel_list = lapply(1:nrow(per_zone), function(i) {
which_points = which(subpoints_joined[[1]] == per_zone[[1]][i])
if(length(which_points) == 0) {
if (length(which_points) == 0) {
return(NULL)
}
sample(which_points, size = per_zone[[2]][i])
Expand Down
54 changes: 28 additions & 26 deletions R/jitter.R
Original file line number Diff line number Diff line change
Expand Up @@ -67,30 +67,30 @@
#' # plot(dlr3[od$all > 200, 1])
#' # mapview::mapview(od_sf$geometry[od$all > 200])
od_jitter = function(
od,
z,
subpoints = NULL,
code_append = "_ag",
population_column = 3,
max_per_od = 100000,
keep_ids = TRUE,
integer_outputs = FALSE,
# od_jitter-specific arguments (and zd)
zd = NULL,
subpoints_o = NULL,
subpoints_d = NULL,
disag = FALSE
) {

od,
z,
subpoints = NULL,
code_append = "_ag",
population_column = 3,
max_per_od = 100000,
keep_ids = TRUE,
integer_outputs = FALSE,
# od_jitter-specific arguments (and zd)
zd = NULL,
subpoints_o = NULL,
subpoints_d = NULL,
disag = FALSE) {
if (!methods::is(od, "sf")) {
# the data structure to reproduce for matching OD pairs
od = od::od_to_sf(od, z = z, zd = zd)
}
disag = all(is.null(zd), is.null(subpoints_o), is.null(subpoints_d), disag)
if(disag) {
if (disag) {
message("Using od_disaggregate") # todo remove once tested
return(od_disaggregate(od, z, subpoints, code_append, population_column,
max_per_od, keep_ids, integer_outputs))
return(od_disaggregate(
od, z, subpoints, code_append, population_column,
max_per_od, keep_ids, integer_outputs
))
}
odc_new = odc_original = od::od_coordinates(od)
od = sf::st_drop_geometry(od)
Expand All @@ -101,7 +101,7 @@ od_jitter = function(
names(points_per_zone)[1] = names(z)[1]
points_per_zone_joined = merge(sf::st_drop_geometry(z), points_per_zone)
# unique_zone_codes = points_per_zone_joined[[1]]
zo = z[match(points_per_zone[[1]], z[[1]], nomatch = FALSE) ,]
zo = z[match(points_per_zone[[1]], z[[1]], nomatch = FALSE), ]
# browser()
if (is.null(subpoints_o)) {
subpoints_o = sf::st_sample(zo, size = points_per_zone_joined$Freq)
Expand All @@ -118,18 +118,19 @@ od_jitter = function(
for (i in unique_zones) {
# total number of origins and destinations
n_origins = sum(od[[1]] == i)
if (n_origins == 0)
if (n_origins == 0) {
next()
}
sel_sj = which(sj_df$geo_code == i)
if(n_origins > length(sel_sj)) {
if (n_origins > length(sel_sj)) {
sel_sj_o = sel_sj[sample(length(sel_sj), size = n_origins, replace = TRUE)]
} else {
sel_sj_o = sel_sj[sample(length(sel_sj), size = n_origins)]
}
odc_new[od[[1]] == i, "ox"] = sj_df$x[sel_sj_o]
odc_new[od[[1]] == i, "oy"] = sj_df$y[sel_sj_o]
# remove those random points from the list of options
sj_df = sj_df[-sel_sj_o,]
sj_df = sj_df[-sel_sj_o, ]
}

if (is.null(zd)) {
Expand All @@ -140,7 +141,7 @@ od_jitter = function(

id_destinations = od[[2]]
points_per_zone = data.frame(table(id_destinations))
zd = zd[match(points_per_zone[[1]], zd[[1]], nomatch = FALSE) ,]
zd = zd[match(points_per_zone[[1]], zd[[1]], nomatch = FALSE), ]
if (is.null(subpoints_d)) {
names(points_per_zone)[1] = names(zd)[1]
points_per_zone_joined_d = merge(sf::st_drop_geometry(zd), points_per_zone)
Expand All @@ -159,19 +160,20 @@ od_jitter = function(
i = unique_zones_d[1]
for (i in unique_zones_d) {
n_destinations = sum(od[[2]] == i)
if (n_destinations == 0)
if (n_destinations == 0) {
next()
}
# when there are subpoints
sel_sj = which(sj_df_d$geo_code == i)
if(n_destinations > length(sel_sj)) {
if (n_destinations > length(sel_sj)) {
sel_sj_d = sel_sj[sample(length(sel_sj), size = n_destinations, replace = TRUE)]
} else {
sel_sj_d = sel_sj[sample(length(sel_sj), size = n_destinations)]
}
odc_new[od[[2]] == i, "dx"] = sj_df_d$x[sel_sj_d]
odc_new[od[[2]] == i, "dy"] = sj_df_d$y[sel_sj_d]
# remove those random points from the list of options
sj_df = sj_df[-sel_sj_d,]
sj_df = sj_df[-sel_sj_d, ]
}
sf::st_sf(od, geometry = odc_to_sfc_sf(odc_new, crs = sf::st_crs(z)))
}
Expand Down
24 changes: 14 additions & 10 deletions R/network.R
Original file line number Diff line number Diff line change
Expand Up @@ -37,20 +37,24 @@ od_to_network = function(x, z, zd = NULL, silent = TRUE, package = "sf", crs = 4
# g[sample(nrow(g), size = uoid[i]), ]
# })
# i = 1
l_origin = lapply(seq(nrow(x)),
function(i) {
g = net_o[net_o[[z_nm]] == x[[1]][i], ]
g[sample(nrow(g), size = 1), ]
})
l_origin = lapply(
seq(nrow(x)),
function(i) {
g = net_o[net_o[[z_nm]] == x[[1]][i], ]
g[sample(nrow(g), size = 1), ]
}
)
d_origin = do.call(rbind, l_origin)
# d_origin$geo_code == x[[1]] TRUE
odc_origin = sf::st_coordinates(d_origin)

l_destination = lapply(seq(nrow(x)),
function(i) {
g = net_d[net_d[[z_nm]] == x[[2]][i], ]
g[sample(nrow(g), size = 1), ]
})
l_destination = lapply(
seq(nrow(x)),
function(i) {
g = net_d[net_d[[z_nm]] == x[[2]][i], ]
g[sample(nrow(g), size = 1), ]
}
)
d_destination = do.call(rbind, l_destination)
odc_destination = sf::st_coordinates(d_destination)

Expand Down
Loading

0 comments on commit 185bb31

Please sign in to comment.