Merge branch 'master' of github.com:asiripanich/emdash

.github/workflows/R-CMD-check.yaml

@@ -45,7 +45,7 @@ jobs:
         if: runner.os == 'Linux'
         run: |
           docker run -d -p 27017:27017 -v $(pwd):/root --name emdash-test-db mongo:latest
-          unzip ./test-data/2015_2016_jul_aug_test_trips.zip
+          tar xzvf ./test-data/2015_2016_jul_aug_test_trips.tar.gz
           docker exec emdash-test-db sh -c 'cd ~ && mongorestore'
           rm -rf ./dump
 

DESCRIPTION

@@ -37,7 +37,7 @@ Imports:
     htmlwidgets
 Encoding: UTF-8
 LazyData: true
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 URL: https://github.com/asiripanich/emdash
 BugReports: https://github.com/asiripanich/emdash/issues
 Suggests: 

NAMESPACE

@@ -3,6 +3,7 @@
 export("%>%")
 export(COLLECTIONS)
 export(anonymize_uuid)
+export(combine_named_lists)
 export(connect_stage_collections)
 export(convert_columns_to_datetime)
 export(convert_datetime_string_to_datetime)

R/app_server.R

@@ -9,10 +9,11 @@ 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_r) %>% {
+    callModule(mod_load_trips_server, "load_trips_ui", cons, data_r) %>%
+    {
       callModule(mod_load_locations_server, "load_locations_ui", cons, .)
     }
-  
+
   # Side bar ----------------------------------------------------------------
 
   # Dashboard ---------------------------------------------------------------
@@ -110,7 +111,7 @@ app_server <- function(input, output, session) {
     if (input$tabs %in% names(data_r)) {
       data_esquisse$data <-
         data.table::copy(data_r[[input$tabs]]) %>%
-        dplyr::select(-dplyr::any_of('_id')) %>%
+        dplyr::select(-dplyr::any_of("_id")) %>%
         drop_list_columns()
 
       if (input$tabs == "participants") {
@@ -164,19 +165,15 @@ app_server <- function(input, output, session) {
       suppl_table <- data_r[[table_type]]
 
       # Set the options used by DT::renderDataTable within dtedit and mod_DT
-      datatable_options <- list(
-        scrollX = TRUE,
-        pageLength = 50,
-        dom = "Bfrtip",
-        buttons = c("copy", "csv", "excel", "pdf", "print", "colvis")
-      )
+
 
       # If the table has a timestamp, make a copy of the timestamp column called fmt_time
       if ("ts" %in% colnames(suppl_table)) {
         suppl_table[["fmt_time"]] <- suppl_table[["ts"]]
         fmt_time_index <- which(names(suppl_table) == "fmt_time")
 
         # Add columnDefs to datatable options to convert fmt_time to a Date
+        datatable_options <- list()
         datatable_options[["columnDefs"]] <- list(list(
           # target column indices start from 0.
           # However, DT adds a row number column to the display as the 0th column
@@ -191,20 +188,13 @@ app_server <- function(input, output, session) {
 
       suppl_table <- data_r[[table_type]]
 
-      # Set the options used by DT::renderDataTable within dtedit and mod_DT
-      datatable_options <- list(
-        scrollX = TRUE,
-        pageLength = 50,
-        dom = "Bfrtip",
-        buttons = c("copy", "csv", "excel", "pdf", "print", "colvis")
-      )
-
       # If the table has a timestamp, make a copy of the timestamp column called fmt_time
       if ("ts" %in% colnames(suppl_table)) {
         suppl_table[["fmt_time"]] <- suppl_table[["ts"]]
         fmt_time_index <- which(names(suppl_table) == "fmt_time")
 
         # Add columnDefs to datatable options to convert fmt_time to a Date
+        datatable_options <- list()
         datatable_options[["columnDefs"]] <- list(list(
           # target column indices start from 0.
           # However, DT adds a row number column to the display as the 0th column
@@ -278,10 +268,33 @@ app_server <- function(input, output, session) {
   })
 
   observeEvent(data_geogr$click, {
+    if ("inferred_labels" %in% colnames(data_geogr$trips)) {
+      message("Found inferred labels column, formatting")
+      inferred_label_index <- which(names(data_geogr$trips) == "inferred_labels")
+      message(inferred_label_index)
+      message(colnames(data_geogr$trips))
+
+      # Add columnDefs to datatable options to convert fmt_inferred_labels to a Date
+      datatable_options <- list()
+      datatable_options[["columnDefs"]] <- list(list(
+        # target column indices start from 0.
+        # However, DT adds a row number column to the display as the 0th column
+        # TODO: Calculate this based on which trip columns are currently hidden
+        # This is currently hard-coded based on the default
+        targets = 5,
+        render = htmlwidgets::JS(
+          "function(data, type, row) {",
+          "return JSON.stringify(data);",
+          "}"
+        )
+      ))
+    }
+
     callModule(mod_DT_server, "DT_ui_trips",
       data = data_geogr$trips %>%
         dplyr::select(-dplyr::any_of(getOption("emdash.cols_to_remove_from_trips_table"))) %>%
-        sf::st_drop_geometry()
+        sf::st_drop_geometry(),
+      DT_options = datatable_options
     )
   })
 
@@ -338,7 +351,6 @@ app_server <- function(input, output, session) {
   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')"
-
     callModule(
       mod_mapview_server,
       "mapview_trips",

R/mod_DT.R

@@ -25,16 +25,11 @@ mod_DT_server <- function(input, output, session, data, DT_options) {
   req(data)
 
   if (missing(DT_options)) {
-    DT_options <- list(
-      scrollX = TRUE,
-      pageLength = 50,
-      dom = "Bfrtip",
-      bPaginate = FALSE,
-      buttons = c("copy", "csv", "excel", "pdf", "print", "colvis")
-    )
+    DT_options <- default_DT_options
+  } else {
+    DT_options <- combine_named_lists(default_DT_options, DT_options)
   }
 
-  # button_list <- list(list(extend='colvis', columns=c()))
   output$DTtable <- DT::renderDataTable({
     DT::datatable(
       data,
@@ -46,6 +41,14 @@ mod_DT_server <- function(input, output, session, data, DT_options) {
   })
 }
 
+default_DT_options <- list(
+  scrollX = TRUE,
+  pageLength = 50,
+  dom = "Bfrtip",
+  bPaginate = FALSE,
+  buttons = c("copy", "csv", "excel", "pdf", "print", "colvis")
+)
+
 ## To be copied in the UI
 # mod_DT_ui("DT_ui_1")
 

R/mod_DTedit.R

@@ -31,15 +31,15 @@ mod_DTedit_server <- function(input, output, session, table_data, table_type,
   # Adjust the target indices.
   # Note that DTedit does not display a row number column like DT.
   # Target column indices start from 0 for columnDefs.
-  
+
   # "user_id"   "_id"       "status"    "bikeLabel" "ts"        "fmt_time"
   # fmt_time is column 6 in R, but without _id and with targets starting from 0,
   # it should be changed to target 4
-  
+
   if ("columnDefs" %in% names(DT_options)) {
     # Adjust for id and for fmt_time
     DT_options$columnDefs[[1]]$targets <- DT_options$columnDefs[[1]]$targets - 2
-  } 
+  }
 
   db_operations <- suppl_table_sublist[[table_type]]$editable$operations
   allow_delete <- "D" %in% db_operations
@@ -79,13 +79,13 @@ mod_DTedit_server <- function(input, output, session, table_data, table_type,
     return(data[-row, ])
   }
 
-  column_names <-  names(table_data)
+  column_names <- names(table_data)
   return_values <- callModule(
     DTedit::dteditmod,
     id = "DTedit_table",
     thedata = table_data,
     edit.cols = edit_columns,
-    view.cols = column_names[!column_names %in% '_id'], # view the table without the '_id' column
+    view.cols = column_names[!column_names %in% "_id"], # view the table without the '_id' column
     callback.update = update_callback, # db operations defined in utils_update_insert_delete.R
     callback.insert = insert_callback,
     callback.delete = delete_callback,

R/mod_load_data.R

@@ -33,26 +33,25 @@ mod_load_data_server <- function(input, output, session, cons) {
         tidy_participants(query_stage_profiles(cons), query_stage_uuids(cons)) %>%
         summarise_trips_without_trips(., cons) %>%
         summarise_server_calls(., cons)
-
-       if (getOption("emdash.remove_from_participants_file") != "" &&
-           checkmate::test_file_exists(getOption("emdash.remove_from_participants_file"), extension = "txt") &&
-          readLines(getOption("emdash.remove_from_participants_file")) != 0) {
-
+
+      if (getOption("emdash.remove_from_participants_file") != "" &&
+        checkmate::test_file_exists(getOption("emdash.remove_from_participants_file"), extension = "txt") &&
+        readLines(getOption("emdash.remove_from_participants_file")) != 0) {
         participants_to_remove <- readLines(getOption("emdash.remove_from_participants_file"))
         col_to_remove_participants <- getOption("emdash.remove_from_participants_col")
-        
+
         message(
           sprintf(
-            "Removing %s participants listed in %s", 
+            "Removing %s participants listed in %s",
             length(participants_to_remove),
             getOption("emdash.remove_from_participants_file")
           )
         )
-        
+
         data_r$participants <- data_r$participants %>%
           subset(!base::get(col_to_remove_participants) %in% participants_to_remove)
       }
-        
+
       message("Finished loading participants")
       message(sprintf("Participants size is: %s kb", format(object.size(data_r$participants), units = "kB", standard = "SI")))
 
@@ -64,19 +63,19 @@ mod_load_data_server <- function(input, output, session, cons) {
         table_title <- t[[table_type]]$tab_name
 
         message(paste("About to load", table_title))
-        if (table_type == 'Checkinout'){
+        if (table_type == "Checkinout") {
           # Get bike check in and include the object ID so we can use it instead of user_id for CUD
-          data_r[[table_type]] <- 
-            cons$Checkinout$find(query = '{}',
-                                 fields = '{}'  # get all fields, including objectId            
-                                ) %>% 
+          data_r[[table_type]] <-
+            cons$Checkinout$find(
+              query = "{}",
+              fields = "{}" # get all fields, including objectId
+            ) %>%
             as.data.table()
-
         } else {
           data_r[[table_type]] <- cons[[table_type]]$find("{}") %>%
             as.data.table()
         }
-        
+
         if ("user_id" %in% colnames(data_r[[table_type]])) {
           data_r[[table_type]] %>%
             normalise_uuid() %>%

R/mod_mapview.R

@@ -24,15 +24,14 @@ mod_mapview_server <- function(input, output, session, data_sf, mapview.map.type
 
   req(data_sf)
 
-  data_r <- reactiveValues(data = data_sf)
   output$map <- leaflet::renderLeaflet({
     if (nrow(data_sf) == 0) {
       m <- mapview::mapview(map.types = mapview.map.types)
     } else {
       m <-
         mapview::mapview(
-          data_sf,
-          zcol = getOption('emdash.map_trajectory_colors_variable'),
+          drop_list_columns(data_sf),
+          zcol = getOption("emdash.map_trajectory_colors_variable"),
           map.types = mapview.map.types
         )
     }

R/run_app.R

@@ -35,7 +35,7 @@ run_app <- function(mongo_url, config_file = getOption("emdash.config_file"), ..
 
 
 load_config_file <- function(config_file = NULL) {
-   # Get the global options found in the config file
+  # Get the global options found in the config file
   if (is.null(config_file)) {
     message("No config file given, the default config file will be used.")
     config_file <- app_sys("config-default.yml")

R/utils.R

@@ -0,0 +1,24 @@
+#' Combine two named lists
+#'
+#' @param x,y a named list. All the elements must be uniquely named.
+#' @param replace a logical value, default as TRUE. If TRUE, all
+#'  the `x` elements with names that exist in the `y` list will be
+#'  replaced with the values in `y`.
+#'
+#' @export
+#' @examples
+#' x <- list(x = 1, y = 2)
+#' y <- list(x = 2)
+#' combine_named_lists(x, y, FALSE)
+combine_named_lists <- function(x, y, replace = TRUE) {
+  checkmate::assert_list(x, names = "unique")
+  checkmate::assert_list(y, names = "unique")
+  checkmate::assert_flag(replace)
+
+  if (replace) {
+    non_overlapping_names <- names(x)[!names(x) %in% names(y)]
+    x <- x[non_overlapping_names]
+  }
+
+  checkmate::assert_list(c(x, y))
+}

R/utils_query_database.R

@@ -342,7 +342,7 @@ query_trip_dates <- function(cons, confirmed_user_input_column) {
               "data.end_local_dt":true,
               "data.end_fmt_time":true,
               "%s":true,
-              "user_id":true, 
+              "user_id":true,
               "_id":false}', confirmed_user_input_column)
   )
   return(small_trip_query)

R/utils_tidy_data.R

@@ -162,11 +162,11 @@ tidy_cleaned_trips_by_timestamp <- function(df) {
 }
 
 summarise_trips_without_trips <- function(participants, cons) {
-  confirmed_user_input_column <- getOption('emdash.confirmed_user_input_column')
+  confirmed_user_input_column <- getOption("emdash.confirmed_user_input_column")
   trip_query <- query_trip_dates(cons, confirmed_user_input_column) %>%
     as.data.table() %>%
     normalise_uuid()
-  
+
   # Generate intermediate columns to use for summarizing trips.
   helper_trip_cols <- trip_query %>%
     .[, .(
@@ -180,7 +180,7 @@ summarise_trips_without_trips <- function(participants, cons) {
       start_local_time = purrr::map2(start_fmt_time, trip_query$data.start_local_dt.timezone, ~ format(.x, tz = .y, usetz = TRUE)) %>%
         as.character() %>% as.POSIXct(), # format returns a list, but lubridate::as_datetime needs it as a character string
       end_local_time = purrr::map2(end_fmt_time, trip_query$data.end_local_dt.timezone, ~ format(.x, tz = .y, usetz = TRUE)) %>%
-      as.character() %>% as.POSIXct()
+        as.character() %>% as.POSIXct()
     )]
 
   # Write the trip summary columns
@@ -198,20 +198,19 @@ summarise_trips_without_trips <- function(participants, cons) {
       last_trip_local_datetime = max(end_local_time)
     ), by = user_id] %>%
     .[, n_days := round(as.numeric(difftime(last_trip_datetime, first_trip_datetime, units = "days")), 1)]
-  
+
   # Add the 'unconfirmed' column.
   unconfirmed_summ <- trip_query %>%
     .[is.na(trip_query[[confirmed_user_input_column]]), .(unconfirmed = .N), by = user_id]
-  
+
   # Count the number of trips per user
   n_trips <- count_total_trips(cons)
   summ_trips <- merge(n_trips, summ_trips, by = "user_id")
 
   message("merging trip summaries with participants")
-  merge(participants, summ_trips, by = "user_id", all.x = TRUE) %>% 
+  merge(participants, summ_trips, by = "user_id", all.x = TRUE) %>%
     merge(., unconfirmed_summ, by = "user_id", all.x = TRUE) %>%
     .[is.na(unconfirmed), unconfirmed := 0]
-
 }
 
 #' Create a summary of trips in data.table format.

R/utils_update_insert_delete.R

@@ -31,9 +31,8 @@ db_update <- function(cons, collection_name, df_row) {
 #' @param collection_name the collection to look in
 #' @param df_row the dataframe row to telling you which document to delete
 db_delete <- function(cons, collection_name, df_row) {
-
-    object_id_string <- sprintf('{\"_id\": {\"$oid\": \"%s\"}}', df_row$`_id`)
-    cons[[collection_name]]$remove(object_id_string, just_one = TRUE)
+  object_id_string <- sprintf('{\"_id\": {\"$oid\": \"%s\"}}', df_row$`_id`)
+  cons[[collection_name]]$remove(object_id_string, just_one = TRUE)
 }
 
 # cons <- connect_stage_collections(url = getOption('emdash.mongo_url'))