Skip to content

Commit

Permalink
debugging remaining differences with test data #34
Browse files Browse the repository at this point in the history
  • Loading branch information
@vincentvanhees
vincentvanhees committed Jul 29, 2022
1 parent 7f985b7 commit 583cb9e
Show file tree
Hide file tree
Showing 8 changed files with 215 additions and 162 deletions.
9 changes: 3 additions & 6 deletions R/hbt_build_palmsplus.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,6 @@
#'
#' @param data The PALMS data obtained using \code{\link{read_palms}}.
#' @param verbose Print progress to console after each iteration. Default is \code{TRUE}.
#' @param config_file Path to the config file
#' @param palmsplus_fields fields defined in PALMSplusRshiny
#' @param home home
#' @param school school
Expand All @@ -25,19 +24,17 @@
#' @export
#'
# Code modified from https://thets.github.io/palmsplusr/
hbt_build_palmsplus <- function(data = NULL, config_file = NULL,
verbose = TRUE, palmsplus_fields = NULL,
hbt_build_palmsplus <- function(data = NULL, verbose = TRUE, palmsplus_fields = NULL,
home = NULL, school = NULL,
home_nbh = NULL, school_nbh = NULL,
participant_basis = NULL) {
# Note:
# home, school, home_nbh, school_nbh need to be present,
# because the functions that are passed on assume that they exist

config <- hbt_read_config(config_file) %>%
filter(context == 'palmsplus_field')
field_args <- setNames(config$formula, config$name) %>%
field_args <- setNames(palmsplus_fields$formula, palmsplus_fields$name) %>%
lapply(parse_expr)

x <- list()
j <- 1
len <- length(unique(data$identifier))
Expand Down
38 changes: 14 additions & 24 deletions R/hbt_build_trajectories.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,8 @@
#' and \code{\link{palms_add_trajectory_location}}.
#'
#' @param data The palmsplus data obtained from \code{\link{palms_build_palmsplus}}.
#' @param config_file Path to the config file
#' @param trajectory_fields trajectory_fields
#' @param trajectory_locations trajectory_locations
#'
#' @return A table of individual trips represented as \code{LINESTRING} geometry.
#'
Expand All @@ -19,35 +20,24 @@
#'
#' @export
# Code modified from https://thets.github.io/palmsplusr/
hbt_build_trajectories <- function(data = NULL, config_file = NULL) {
hbt_build_trajectories <- function(data = NULL, trajectory_fields = NULL, trajectory_locations = NULL) {
name = after_conversion = tripnumber = NULL

# Field
config <- hbt_read_config(config_file) %>%
filter(context == 'trajectory_field')

if (nrow(config) > 0) {
if (nrow(config) > 0) {
args <- config %>% filter(after_conversion == FALSE)
args_after <- config %>% filter(after_conversion == TRUE)

args <- setNames(args$formula, args$name) %>% lapply(parse_expr)
args_after <- setNames(args_after$formula, args_after$name) %>% lapply(parse_expr)
} else {
args <- list()
args_after <- list()
}
}
# Location
config <- hbt_read_config(config_file) %>%
filter(context == 'trajectory_location')
args <- trajectory_fields %>% filter(after_conversion == FALSE)
args_after <- trajectory_fields %>% filter(after_conversion == TRUE)

args <- setNames(args$formula, args$name) %>% lapply(parse_expr)
args_after <- setNames(args_after$formula, args_after$name) %>% lapply(parse_expr)

if (nrow(config) > 0) {
args_locations <- setNames(paste0("first(", config$start_criteria,
") & last(", config$end_criteria, ")"),
config$name) %>% lapply(parse_expr)
if (length(trajectory_locations) > 0) {
args_locations <- setNames(paste0("first(", trajectory_locations$start_criteria,
") & last(", trajectory_locations$end_criteria, ")"),
trajectory_locations$name) %>% lapply(parse_expr)
args_locations = args_locations[order(names(args_locations))]
args <- c(args, args_locations)
}

# Build data object
data <- data %>%
filter(tripnumber > 0) %>%
Expand Down
11 changes: 6 additions & 5 deletions R/hbt_check_missing_id.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,9 +19,9 @@ hbt_check_missing_id = function(participant_basis, palmsplus_folder, dataset_nam
missing = which(test_missing_value > 1)
participant_exclude_list = list(identifier = NULL, school_id = NULL)
if (length(missing) > 0) {
print("\nMissing ID values in participant_basis\n")
print(paste0("\nIgnoring identifier ", paste(participant_basis$identifier[missing], sep = " ")))
print(paste0("\nIgnoring schoolid ", paste(participant_basis$school_id[missing], sep = " ")))
cat("\nMissing ID values in participant_basis\n")
cat(paste0(" Ignoring identifier ", paste(participant_basis$identifier[missing], sep = " "), "\n"))
cat(paste0(" Ignoring schoolid ", paste(participant_basis$school_id[missing], sep = " "), "\n"))
participant_exclude_list$identifier = participant_basis$identifier[missing]
participant_exclude_list$school_id = participant_basis$school_id[missing]
participant_basis = participant_basis[test_missing_value == 0, ]
Expand All @@ -38,8 +38,9 @@ hbt_check_missing_id = function(participant_basis, palmsplus_folder, dataset_nam
participant_basis$identifier[which(participant_basis$identifier %in% palms$identifier == FALSE)]))

if (length(missing_identifiers) > 0) {
print("Removing missing identifiers related to palms")
print(missing_identifiers)
cat("\nRemoving missing identifiers related to palms: ")
cat(missing_identifiers)
cat("\n")
participant_basis = participant_basis[participant_basis$identifier %in% missing_identifiers == FALSE,]
palms = palms[palms$identifier %in% missing_identifiers == FALSE,]
}
Expand Down
153 changes: 85 additions & 68 deletions R/palmsplusr_shiny.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,11 +17,11 @@
#' @export

palmsplusr_shiny <- function(gisdir = "",
palmsdir = "",
gislinkfile = "",
outputdir = "",
dataset_name = "",
configfile = "") {
palmsdir = "",
gislinkfile = "",
outputdir = "",
dataset_name = "",
configfile = "") {
home = school = home_nbh = school_nbh = NULL
. = lon = identifier = palms = NULL
if (length(configfile) > 0) {
Expand All @@ -45,7 +45,7 @@ palmsplusr_shiny <- function(gisdir = "",
# If no configfile is provided fall back on default
config <- system.file("testfiles_palmsplusr/config_palmsplusr.csv", package = "HabitusGUI")[1]
}

palmsplus_folder = paste0(outputdir, "/PALMSplus_output")
if (!dir.exists(palmsplus_folder)) {
cat("\nCreating PALMSplusR output directory\n")
Expand Down Expand Up @@ -76,7 +76,7 @@ palmsplusr_shiny <- function(gisdir = "",

# Write to csv and read using read_palms to format the object as expected from the rest of the code
PALMS_reduced_file = paste0(palmsplus_folder, "/", stringr::str_interp("PALMS_${dataset_name}_reduced.csv"))
print(paste0("Check PALMS_reduced_file: ", PALMS_reduced_file))
cat(paste0("\nCheck PALMS_reduced_file: ", PALMS_reduced_file))
write.csv(palms_reduced_cleaned, PALMS_reduced_file)
palms = palmsplusr::read_palms(PALMS_reduced_file)

Expand Down Expand Up @@ -123,7 +123,7 @@ palmsplusr_shiny <- function(gisdir = "",
# involved super assignment operators which seem to be causing issues,
# defaults are now taken care of in the config file preparation


# #=============================
# adding fields
CONF = read.csv(config, sep = ",")
Expand All @@ -134,26 +134,25 @@ palmsplusr_shiny <- function(gisdir = "",

palmsplusr_domain_rows = which(CONF$context == "palmsplus_domain")
palmsplus_domains = tibble(name = CONF$name[palmsplusr_domain_rows],
formula = CONF$formula[palmsplusr_domain_rows],
domain_field = CONF$domain_field[palmsplusr_domain_rows])
formula = CONF$formula[palmsplusr_domain_rows],
domain_field = CONF$domain_field[palmsplusr_domain_rows])
# #=============================
# # trajectory_fields
# CONF = read.csv(config, sep = "\t")
# trajectory_field_rows = which(CONF$context == "trajectory_field")
# trajectory_field = tibble(name = CONF$name[trajectory_field_rows],
# formula = CONF$formula[trajectory_field_rows],
# after_conversions = CONF$after_conversions[trajectory_field_rows])
trajectory_field_rows = which(CONF$context == "trajectory_field")
trajectory_fields = tibble(name = CONF$name[trajectory_field_rows],
formula = CONF$formula[trajectory_field_rows],
after_conversion = CONF$after_conversion[trajectory_field_rows])
# #=============================
# # multimodal_fields
multimodal_fields_rows = which(CONF$context == "multimodal_field")
multimodal_fields = tibble(name = CONF$name[multimodal_fields_rows],
formula = CONF$formula[multimodal_fields_rows])
formula = CONF$formula[multimodal_fields_rows])
# #=============================
# # trajectory locations
trajectory_location_rows = which(CONF$context == "trajectory_location")
trajectory_locations = tibble(name = CONF$name[trajectory_location_rows],
start_criteria = CONF$start_criteria[trajectory_location_rows],
end_criteria = CONF$end_criteria[trajectory_location_rows])
start_criteria = CONF$start_criteria[trajectory_location_rows],
end_criteria = CONF$end_criteria[trajectory_location_rows])


# Run palmsplusr ----------------------------------------------------------
Expand All @@ -165,56 +164,74 @@ palmsplusr_shiny <- function(gisdir = "",
if (file.exists(fn)) file.remove(fn)
}

# save(palms, home, home_nbh, school_nbh,participant_basis, file = "~/projects/fontys/state_1_gui.RData")

cat("\n<<< building palmsplus... >>>\n")
palmsplus <- hbt_build_palmsplus(data = palms,
config_file = config,
palmsplus_fields = palmsplus_fields,
home = home,
school = school,
home_nbh = home_nbh,
school_nbh = school_nbh,
participant_basis = participant_basis)
write_csv(palmsplus, file = fns[1])

config_test <- hbt_read_config(config) %>%
filter(context == 'palmsplus_field')
# save(palmsplus, config_test, file = "~/projects/fontys/state_2_gui.RData")

cat("\n<<< building days... >>>\n")
days <- hbt_build_days(data = palmsplus,
palmsplus_domains = palmsplus_domains,
palmsplus_fields = palmsplus_fields,
home = home,
school = school,
home_nbh = home_nbh,
school_nbh = school_nbh,
participant_basis = participant_basis)
write_csv(days, file = fns[2])

# save(days, file = "~/projects/fontys/state_3_gui.RData")
# sf::st_write(palmsplus, dsn = paste0(palmsplus_folder, "/", dataset_name, "_palmsplus.shp"), append = FALSE)

cat("\n<<< building trajectories... >>>\n")
trajectories <- hbt_build_trajectories(palmsplus, config_file = config)
write_csv(trajectories, file = fns[3])
shp_file = paste0(palmsplus_folder, "/", dataset_name, "_trajecories.shp")
if (file.exists(shp_file)) file.remove(shp_file) # remove because st_write does not know how to overwrite
sf::st_write(obj = trajectories, dsn = shp_file)

# save(trajectories, multimodal_fields, trajectory_locations, file = "~/projects/fontys/state_4_gui.RData")

cat("\n<<< building multimodal... >>>\n")
multimodal <- hbt_build_multimodal(data = trajectories,
spatial_threshold = 200,
temporal_threshold = 10,
palmsplus = palmsplus,
multimodal_fields = multimodal_fields,
trajectory_locations = trajectory_locations)
if (length(multimodal) > 0) {
write_csv(multimodal, file = fns[4])
sf::st_write(multimodal, paste0(palmsplus_folder, "/", dataset_name, "_multimodal.shp"))
cat("\n<<< building palmsplus...\n")
if (length(palms) > 0 & length(palmsplus_fields) &
length(home) > 0 & length(school) > 0 & length(home_nbh) > 0 & length(school_nbh) > 0 &
length(participant_basis) > 0) {
palmsplus <- hbt_build_palmsplus(data = palms,
palmsplus_fields = palmsplus_fields,
home = home,
school = school,
home_nbh = home_nbh,
school_nbh = school_nbh,
participant_basis = participant_basis)
write_csv(palmsplus, file = fns[1])
cat("done>>>\n")
} else {
cat("skipped because insufficient input data>>>\n")
}

cat("\n<<< building days...")
if (length(palmsplus) > 0 & length(palmsplus_domains) > 0 & length(palmsplus_fields) &
length(home) > 0 & length(school) > 0 & length(home_nbh) > 0 & length(school_nbh) > 0 &
length(participant_basis) > 0) {
days <- hbt_build_days(data = palmsplus,
palmsplus_domains = palmsplus_domains,
palmsplus_fields = palmsplus_fields,
home = home,
school = school,
home_nbh = home_nbh,
school_nbh = school_nbh,
participant_basis = participant_basis)
write_csv(days, file = fns[2])
# sf::st_write(palmsplus, dsn = paste0(palmsplus_folder, "/", dataset_name, "_palmsplus.shp"), append = FALSE)
cat("done>>>\n")
} else {
cat("skipped because insufficient input data>>>\n")
}

trajectory_locations = trajectory_locations[order(trajectory_locations$name),]
cat("\n<<< building trajectories...")
if (length(palmsplus) > 0 & length(trajectory_fields) > 0) {
trajectories <- hbt_build_trajectories(data = palmsplus,
trajectory_fields = trajectory_fields,
trajectory_locations = trajectory_locations)

write_csv(trajectories, file = fns[3])
shp_file = paste0(palmsplus_folder, "/", dataset_name, "_trajecories.shp")
if (file.exists(shp_file)) file.remove(shp_file) # remove because st_write does not know how to overwrite
sf::st_write(obj = trajectories, dsn = shp_file)
cat("done>>>\n")
} else {
cat("skipped because insufficient input data>>>\n")
}
cat("\n<<< building multimodal...")
if (length(palmsplus) > 0 & length(multimodal_fields) > 0 & length(trajectory_locations) > 0) {
multimodal <- hbt_build_multimodal(data = trajectories,
spatial_threshold = 200,
temporal_threshold = 10,
palmsplus = palmsplus,
multimodal_fields = multimodal_fields,
trajectory_locations = trajectory_locations)
if (length(multimodal) > 0) {
write_csv(multimodal, file = fns[4])
shp_file = paste0(palmsplus_folder, "/", dataset_name, "_multimodal.shp")
if (file.exists(shp_file)) file.remove(shp_file) # remove because st_write does not know how to overwrite
sf::st_write(obj = multimodal, dsn = shp_file)
}
cat("done>>>\n")
} else {
cat("skipped because insufficient input data>>>\n")
}

return()
Expand Down
Loading

0 comments on commit 583cb9e

Please sign in to comment.