Merge pull request #65 from habitus-eu/issue62_palmsplusr_generic_loc…

…ations

Issue62 palmsplusr generic locations

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: HabitusGUI
 Title: R Shiny App for Processing Behavioural Data
 Description: Shiny app to ease processing behavioural data with research software such as GGIR, activityCounts, PALMSpy,and palmsplusr.
-Version: 0.1.4
-Date: 2022-07-26
+Version: 0.1.5
+Date: 2022-12-20
 Authors@R: 
     c(person(given = "Vincent",
            family = "van Hees",

R/hbt_build_days.R

@@ -16,10 +16,7 @@
 #' @param verbose Print progress to console. Default is \code{TRUE}.
 #' @param palmsplus_domains ...
 #' @param palmsplus_fields ...
-#' @param home home
-#' @param school school
-#' @param home_nbh home_nbh
-#' @param school_nbh school_nbh
+#' @param loca Nested list with location information
 #' @param participant_basis participant_basis
 #'
 #'
@@ -35,11 +32,19 @@
 hbt_build_days <- function(data = NULL, verbose = TRUE, 
                            palmsplus_domains = NULL,
                            palmsplus_fields = NULL,
-                           home = NULL,
-                           school = NULL,
-                           home_nbh = NULL,
-                           school_nbh = NULL,
+                           loca = NULL,
                            participant_basis = NULL) {
+
+  # Note:
+  # home, school, home_nbh, school_nbh (or similar) need to be present, 
+  # because the functions that are passed on assume that they exist
+  # So, now we need to create those objects from object loca
+  Nlocations = length(loca)
+  for (i in 1:Nlocations) {
+    txt = paste0(names(loca[[i]])[1], " = loca[[i]][[1]]")
+    eval(parse(text = txt))
+  }
+
   duration = datetime = name = domain_field = NULL
 
   domain_fields <- palmsplus_domains %>% filter(domain_field == TRUE)
@@ -59,15 +64,14 @@ hbt_build_days <- function(data = NULL, verbose = TRUE,
     mutate_if(is.logical, as.integer)
 
   fields <- palmsplus_fields %>% filter(domain_field == TRUE) %>% pull(name)
-
   data <- data %>%
     st_set_geometry(NULL) %>%
-    dplyr::select(identifier, datetime, domain_names, fields) %>%
+    dplyr::select(identifier, datetime, domain_names, all_of(fields)) %>%
     mutate(duration = 1) %>%
     mutate_at(vars(-identifier,-datetime), ~ . * palms_epoch(data) / 60) %>%
     group_by(identifier, date = as.Date(datetime)) %>%
     dplyr::select(-datetime)
-  
+
   x <- list()
   for (i in domain_names) {
     x[[i]] <- data %>%

R/hbt_build_multimodal.R

@@ -90,20 +90,20 @@ hbt_build_multimodal <- function(data = NULL,
       group_by(identifier) %>%
       mutate(mmt_number = data.table::rleid(mmt_number)) %>%
       ungroup() %>%
-      dplyr::select(-c(start_point, end_point, end_prev, mmt_criteria, time_diff, distance_diff))
+      dplyr::select(!any_of(c(start_point, end_point, end_prev, mmt_criteria, time_diff, distance_diff)))
 
     if(verbose) cat('done\nCalculating fields...')
 
     # Split varables into each mot
     mot_split <- data %>%
-      dplyr::select(c("mot", "mmt_number", "identifier", "geometry", multimodal_fields$name)) %>%
+      dplyr::select(any_of(c("mot", "mmt_number", "identifier", "geometry", multimodal_fields$name))) %>%
       mutate(mot = paste0("mot_", mot)) %>%
       gather(variable, value, -mmt_number, -mot, -identifier, -geometry) %>%
       unite(col, mot, variable) %>%
       spread(col, value) %>%
       arrange(identifier, mmt_number) %>%
       cbind(data) %>%
-      dplyr::select(-ends_with(".1"))
+      dplyr::select(!any_of(ends_with(".1")))
 
     # Calculate multimodal_fields
     df_fields <- list()
@@ -131,7 +131,7 @@ hbt_build_multimodal <- function(data = NULL,
     lookup <- palmsplus %>%
       filter(tripnumber > 0 & triptype %in% c(1, 4)) %>%
       as.data.frame() %>%
-      dplyr::select(c("identifier", "tripnumber", "triptype", all_of(names)))
+      dplyr::select(all_of(c("identifier", "tripnumber", "triptype", names)))
 
     # Helper function to lookup start and end locations from the lookup table
     lookup_locations <- function(identifier, start_trip, start_loc, end_trip, end_loc) {
@@ -161,7 +161,7 @@ hbt_build_multimodal <- function(data = NULL,
       rowwise() %>%
       mutate(!!!args_locations) %>%
       ungroup() %>%
-      dplyr::select(-c(start_trip, end_trip)) %>%
+      dplyr::select(!any_of(c(start_trip, end_trip))) %>%
       mutate_if(is.logical, as.integer)
 
     if (exists("df_fields")) {

R/hbt_build_palmsplus.R

@@ -7,10 +7,7 @@
 #' @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 palmsplus_fields fields defined in PALMSplusRshiny
-#' @param home home
-#' @param school school
-#' @param home_nbh home_nbh
-#' @param school_nbh school_nbh
+#' @param loca Nested list with location information
 #' @param participant_basis participant_basis
 #'
 #' @import dplyr
@@ -25,13 +22,21 @@
 #' 
 # Code modified from https://thets.github.io/palmsplusr/
 hbt_build_palmsplus <- function(data = NULL, verbose = TRUE, palmsplus_fields = NULL,
-                                home = NULL, school = NULL,
-                                home_nbh = NULL, school_nbh = NULL,
+                                loca = NULL,
                                 participant_basis = NULL) {
   # Note:
-  # home, school, home_nbh, school_nbh need to be present, 
+  # home, school, home_nbh, school_nbh (or similar) need to be present, 
   # because the functions that are passed on assume that they exist
+  # So, now we need to create those objects from object loca
+  Nlocations = length(loca)
+  for (i in 1:Nlocations) {
+    for (j in 1:2) {
+      txt = paste0(names(loca[[i]])[j], " = loca[[i]][[j]]")
+      eval(parse(text = txt))
+    }
+  }
 
+
   field_args <- setNames(palmsplus_fields$formula, palmsplus_fields$name) %>%
     lapply(parse_expr)
 

R/hbt_build_trajectories.R

@@ -23,7 +23,6 @@
 hbt_build_trajectories <- function(data = NULL, trajectory_fields = NULL, trajectory_locations = NULL) {
   name = after_conversion = tripnumber = NULL
 
-
   args <- trajectory_fields %>% filter(after_conversion == FALSE)
   args_after <- trajectory_fields %>% filter(after_conversion == TRUE)