Merge pull request #49 from allenmichael099/load_trips_based_on_ndocs

- Trip loading and location loading now depend on the number of (MongoDB) documents in the date range and the specified max documents per trip found in config-default.yml. See #49 for an explanation of this feature.

NAMESPACE

@@ -6,18 +6,22 @@ export(anonymize_uuid)
 export(connect_stage_collections)
 export(convert_columns_to_datetime)
 export(convert_datetime_string_to_datetime)
+export(downsample_cleaned_locations_by_timestamp)
 export(generate_trajectories)
-export(get_query_size)
+export(get_n_locations_in_query)
+export(get_n_trips_in_query)
 export(mod_mapview_ui)
 export(normalise_uuid)
 export(query_cleaned_locations)
 export(query_cleaned_locations_by_timestamp)
 export(query_cleaned_place)
 export(query_cleaned_section)
 export(query_cleaned_trips)
+export(query_cleaned_trips_by_timestamp)
 export(query_diary_summ)
 export(query_max_trip_timestamp)
 export(query_min_trip_timestamp)
+export(query_most_recent_n_trip_docs)
 export(query_raw_trips)
 export(query_server_calls)
 export(query_stage_profiles)

R/app_server.R

@@ -9,6 +9,7 @@ app_server <- function(input, output, session) {
   cons <- connect_stage_collections(url = getOption("emdash.mongo_url"))
   data_r <- callModule(mod_load_data_server, "load_data_ui", cons)
   data_geogr <- callModule(mod_load_trips_server, "load_trips_ui", cons)
+  data_geogr <- callModule(mod_load_locations_server, "load_locations_ui", cons, data_geogr)
 
   # Side bar ----------------------------------------------------------------
 
@@ -102,7 +103,9 @@ app_server <- function(input, output, session) {
         drop_list_columns() %>%
         data.table::setnames(originalColumnNames, new_column_names, skip_absent = TRUE)
     }
-    if (input$tabs == "trips") {
+
+    # Make sure trips exists before attempting to manipulate it
+    if (exists("data_geogr$trips") && input$tabs == "trips") {
       data_esquisse$data <-
         data_geogr$trips %>%
         drop_list_columns() %>%
@@ -267,6 +270,7 @@ app_server <- function(input, output, session) {
     )
   })
 
+
   # Maps --------------------------------------------------------------------
 
   # these lists of columns in trips_with_trajectories can inform
@@ -275,8 +279,22 @@ app_server <- function(input, output, session) {
 
   # data_geogr$trips_with_trajectories %>% colnames() %>% dput()
 
+  # Set the data used for the map.
+  # Use trips_with_trajectories when locations and trajectories are ready.
+  # This will update each time locations_ready, trips, or trips with trajectories updates
+  map_data <- reactive({
+    if (data_geogr$locations_ready() == TRUE) {
+      message("Adding trajectories to map.")
+      return(data_geogr$trips_with_trajectories)
+    } else {
+      message("Mapping without trajectories")
+      return(data_geogr$trips)
+    }
+  })
+
+  # This returns a list of column names
   cols_to_include_in_map_filter <- reactive({
-    data_geogr$trips_with_trajectories %>%
+    map_data() %>%
       colnames() %>%
       # specify columns to remove here
       setdiff(c(
@@ -287,21 +305,29 @@ app_server <- function(input, output, session) {
       ))
   })
 
-  filtered_trips <-
+  # Filter the trips data before passing to the map.
+  filtered_trips <- reactive({
+    # Do nothing if data_geogr$trips does not exist, which happens on startup
+    req(data_geogr$trips)
+
     callModule(
       module = esquisse::filterDF,
       id = "filtering",
-      data_table = reactive(anonymize_uuid_if_required(data_geogr$trips_with_trajectories)),
+      data_table = reactive(anonymize_uuid_if_required(map_data())),
       data_name = reactive("data"),
       data_vars = cols_to_include_in_map_filter, # the map filter uses start_fmt_time and end_fmt_time (UTC time)
       drop_ids = FALSE
     )
+  })
+
+  observeEvent(filtered_trips()$data_filtered(), {
+    # since filtered trips and data filtered are both reactive, need to include parentheses after each. otherwise you get:
+    # Error in UseMethod: no applicable method for 'select' applied to an object of class "c('reactiveExpr', 'reactive', 'function')"
 
-  observeEvent(filtered_trips$data_filtered(), {
     callModule(
       mod_mapview_server,
       "mapview_trips",
-      data_sf = filtered_trips$data_filtered() %>%
+      data_sf = filtered_trips()$data_filtered() %>%
         dplyr::select(-dplyr::any_of(getOption("emdash.cols_to_remove_from_map_popup")))
     )
   })

R/app_ui.R

@@ -123,6 +123,7 @@ app_ui <- function(request) {
           # Maps ----------------------
           tabItem(
             tabName = "maps",
+            mod_load_locations_ui("load_locations_ui"),
             fluidRow(
               column(
                 width = 3,

R/mod_DTedit.R

@@ -16,7 +16,7 @@ mod_DTedit_ui <- function(id) {
 }
 
 #' DTedit Server Function
-#' 
+#'
 #' @param input,output,session Internal parameters for {shiny}
 #' @param table_data data to place in the editable data table
 #' @param table_type Name of the mongo collection the data table is associated with

R/mod_load_data.R

@@ -10,7 +10,7 @@
 mod_load_data_ui <- function(id) {
   ns <- NS(id)
   tagList(
-    actionButton(ns("reload_data"), label = "Reload data"),
+    actionButton(ns("reload_data"), label = "Reload participants data"),
     textOutput(ns("last_load_datetime"))
   )
 }
@@ -34,6 +34,7 @@ mod_load_data_server <- function(input, output, session, cons) {
         summarise_trips_without_trips(., cons) %>%
         summarise_server_calls(., cons)
       message("Finished loading participants")
+      message(sprintf("Participants size is: %s kb", format(object.size(data_r$participants), units = "kB", standard = "SI")))
 
       table_list <- getOption("emdash.supplementary_tables")
 
@@ -43,7 +44,7 @@ mod_load_data_server <- function(input, output, session, cons) {
         table_title <- t[[table_type]]$tab_name
 
         message(paste("About to load", table_title))
-        data_r[[table_type]] <- cons[[table_type]]$find("{}") %>% 
+        data_r[[table_type]] <- cons[[table_type]]$find("{}") %>%
           as.data.table()
 
         if ("user_id" %in% colnames(data_r[[table_type]])) {

R/mod_load_locations.R

@@ -0,0 +1,139 @@
+#' load_locations UI Function
+#'
+#' @description A shiny Module.
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#'
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+mod_load_locations_ui <- function(id) {
+  ns <- NS(id)
+
+  fluidRow(
+    align = "center",
+    actionButton(inputId = ns("get_trajectories"), label = "Get Locations and Trajectories"),
+    htmlOutput(ns("locations_allowed_message"))
+  )
+}
+
+#' load_locations Server Function
+#' @param cons is the mongolite connection to the database
+#' @param data_geogr is a reactive dataframe with trips data and locations info
+#' @noRd
+mod_load_locations_server <- function(input, output, session, cons, data_geogr) {
+  ns <- session$ns
+
+  # Load Locations and generate trajectories if get_trajectories is clicked
+  # and locations_info()$allow_load is true.
+
+  # Use this to determine the message to show for locations allowed before trips is loaded.
+  use_startup_message <- reactiveVal(TRUE)
+  max_n_docs <- getOption("emdash.max_documents_for_mod_load_trips")
+  min_locations_per_trip <- getOption("emdash.min_locations_per_trip")
+
+  # Check the number of trips, the number of locations, and whether trips are ready.
+  # update messages and whether locations are allowed accordingly.
+  locations_info <- reactive({
+
+    # Handle the case of no trips, eg the user makes the first date a later date than the second date.
+    if (is.null(data_geogr$n_trips())) {
+      # Skip all other checks.
+      out <- list(allow_load = FALSE, sample_size = FALSE, message = "No trips in the selected date range.")
+    } else {
+      n_trips <- data_geogr$n_trips()
+      n_locations <- data_geogr$n_locations()
+
+      # trips + trajectories <= max_documents: get all locations
+      # else trips + min_locations_per_trip * trips <= max_documents: get sample
+      # else trips + min_locations_per_trip * trips > max_documents: warn user that we can't do this
+      # downsample will be either false or the number of locations to include
+
+      # Only downsample in case 2.
+      downsample <- FALSE
+
+      if (n_trips + n_locations <= max_n_docs) {
+        allow <- TRUE
+        loc_message <- "For the current date range, all location points can be used."
+      } else if (n_trips * (1 + min_locations_per_trip) <= max_n_docs) {
+        allow <- TRUE
+        downsample <- max_n_docs - n_trips # this will serve as our sample size.
+        loc_message <- sprintf(
+          "Will only use %s locations per trip. For more detailed trajectories, use a smaller date range.",
+          ceiling(downsample / n_trips)
+        )
+      } else if (n_trips * (1 + min_locations_per_trip) > max_n_docs) {
+        allow <- FALSE
+        loc_message <- "Cannot get trajectories. The selected date range has too many trips."
+      }
+
+      # if trips are ready, update allow and downsample
+      # Otherwise, add a second portion to the locations message and do not allow locations.
+      if (data_geogr$trips_ready() == TRUE) {
+        out <- list(allow_load = allow, sample_size = downsample, message = loc_message)
+      } else {
+        extra_message <- ifelse(use_startup_message(),
+          "Need to load trips first.",
+          "To get trajectories again, load trips first."
+        )
+        loc_message <- paste(extra_message, loc_message, sep = "<br/>")
+        out <- list(allow_load = FALSE, sample_size = FALSE, message = loc_message)
+      }
+    }
+    return(out)
+  })
+
+  # Initialize locations_ready as FALSE
+  data_geogr$locations_ready <- reactiveVal(FALSE)
+
+  # Tell the user the status of what Get Locations and Trajectories will do.
+  output$locations_allowed_message <- renderUI({
+    HTML(locations_info()$message)
+  })
+
+  # Observe for when get_trajectories gets clicked.
+  observeEvent(input$get_trajectories, {
+    if (locations_info()$allow_load == TRUE) {
+      message("About to load locations")
+
+      # if sample_size is not false, use it to limit the number of locations queried.
+      if (locations_info()$sample_size != FALSE) {
+        data_geogr$locations <- downsample_cleaned_locations_by_timestamp(
+          cons, data_geogr$dates(),
+          locations_info()$sample_size
+        ) %>%
+          tidy_cleaned_locations()
+      } else {
+        data_geogr$locations <- tidy_cleaned_locations(query_cleaned_locations_by_timestamp(cons, data_geogr$dates()))
+      }
+      message("Finished loading locations")
+      message(sprintf("Locations size is: %s", format(object.size(data_geogr$locations), units = "kB", standard = "SI")))
+
+      message("About to create trajectories within trips")
+      data_geogr$trips_with_trajectories <- generate_trajectories(data_geogr$trips,
+        data_geogr$locations,
+        project_crs = get_golem_config("project_crs")
+      )
+      message("Finished creating trajectories within trips")
+      message(sprintf("Trips with trajectories size is: %s", format(object.size(data_geogr$trips_with_trajectories), units = "kB", standard = "SI")))
+
+      # Now that get_trajectories has been clicked and locations_info()$allow_load is TRUE,
+      # update data_geogr$locations_ready() to TRUE.
+      # map_data will notice the change in data_geogr$locations_ready() and the map will be updated accordingly
+      data_geogr$locations_ready(TRUE)
+
+      # Prevent user from loading locations again until after trips has been reloaded.
+      data_geogr$trips_ready(FALSE)
+
+      # Now that locations and trajectories have been loaded once, change how you tell user to load trips.
+      use_startup_message(FALSE)
+    }
+  })
+
+  # observeEvent(data_geogr$click, {
+  #   data_geogr$locations_ready(FALSE)
+  #   shinyjs::show('get_trajectories', asis = TRUE)
+  # })
+
+  return(data_geogr)
+}