Editable participants

R/app_server.R

@@ -110,6 +110,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')) %>%
         drop_list_columns()
 
       if (input$tabs == "participants") {
@@ -143,15 +144,27 @@ app_server <- function(input, output, session) {
   startup_load_supplementary <- reactiveVal(TRUE)
   tableList <- getOption("emdash.supplementary_tables")
 
+  # 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")
+  )
+
   observeEvent(data_r$click, {
-    callModule(mod_DT_server, "DT_ui_participants",
-      data = data_r$participants %>%
+    callModule(mod_DTedit_server, "DTedit_participants",
+      table_data = data_r$participants %>%
         dplyr::select(-dplyr::any_of(getOption("emdash.cols_to_remove_from_participts_table"))) %>%
         data.table::setnames(
           original_col_labels_for_participants,
           new_col_labels_for_participants,
           skip_absent = TRUE
-        )
+        ),
+      table_type = 'participants',
+      suppl_table_sublist = NULL,
+      DT_options = datatable_options,
+      cons
     )
 
     # For each supplementary table, append a new tabPanel and run the server function
@@ -162,42 +175,6 @@ 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[["columnDefs"]] <- list(list(
-          # target column indices start from 0.
-          # However, DT adds a row number column to the display as the 0th column
-          targets = fmt_time_index,
-          render = htmlwidgets::JS(
-            "function(data, type, row) {",
-            "return new Date(data*1000);",
-            "}"
-          )
-        ))
-      }
-
-      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"]]

R/app_ui.R

@@ -108,7 +108,7 @@ app_ui <- function(request) {
                   status = "primary",
                   title = "Participants",
                   value = "participants",
-                  mod_DT_ui("DT_ui_participants")
+                  mod_DTedit_ui("DTedit_participants"),  # use DTedit for participants
                 ),
                 tabPanel(
                   status = "primary",

R/mod_DTedit.R

@@ -28,57 +28,131 @@ mod_DTedit_server <- function(input, output, session, table_data, table_type,
   ns <- session$ns
   req(table_data)
 
-  # If we are rendering fmt_time, adjust the target indices because DTedit
-  # does not display a row number column
-  # Target column indices start from 0
+  # 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)) {
-    DT_options$columnDefs[[1]]$targets <- DT_options$columnDefs[[1]]$targets - 1
+    # Adjust for id and for fmt_time
+    DT_options$columnDefs[[1]]$targets <- DT_options$columnDefs[[1]]$targets - 2
   }
+
+  # If TABLE TYPE is 'participants'
+  if (table_type == 'participants') {
+
+    allow_update <- TRUE
+    allow_insert <- FALSE
+    allow_delete <- FALSE
+
+    if (!('recommendation' %in% names(table_data))) {
+      table_data[['recommendation']] <- rep('unknown',nrow(table_data))
+    }
+
+    # Get the list of recommendations that are already in the database
+    current_labels <- table_data[['recommendation']] %>% unique()
 
-  db_operations <- suppl_table_sublist[[table_type]]$editable$operations
-  allow_delete <- "D" %in% db_operations
-  allow_update <- "U" %in% db_operations
-  allow_insert <- FALSE #' C' %in% db_operations
-
-  # Make status a factor so you can use selectInput
-  table_data$status <- as.factor(table_data$status)
-
-  if ("edit_columns" %in% names(suppl_table_sublist[[table_type]]$editable)) {
-    edit_columns <- suppl_table_sublist[[table_type]]$editable$edit_columns
-  } else {
-    edit_columns <- "status"
-  }
-
-  #### NOTE: db insert, update, and delete are defined specifically for Checkinout
-
-  # Define the callback functions used by dtedit
-  # Insert a row. "Create"
-  # @param data the data including your inserted row
-  # @param row the row where you made the change
-  insert_callback <- function(data, row) {
-    db_insert(cons, table_type, data[row, ])
-    return(data)
-  }
-
-  # Update a row
-  # @param data the data including your updated row
-  update_callback <- function(data, olddata, row) {
-    db_update(cons, table_type, data[row, ])
-    data
-  }
-
-  # Delete a row
-  delete_callback <- function(data, row) {
-    db_delete(cons, table_type, data[row, ])
-    return(data[-row, ])
+    # Establish the possible recommendations and add any other recommendations that are in the database
+    recommendation_labels <- c(
+      'check always permission or app force kill',
+      'check always permission',
+      'check token',
+      'check aggressive power savings',
+      'unknown') %>% 
+      c(.,current_labels[!current_labels %in% c(.,NA)])  # also don't give NA as an option
+
+    table_data <- table_data %>%
+      dplyr::mutate(recommendation = dplyr::coalesce(recommendation, 'unknown'))
+
+    # if you get 'Not all edit.cols are in the data.', check column spellings
+    edit_columns <- c('recommendation')
+    input_types = c(recommendation = "selectizeInput")
+    input_choices = list(
+      recommendation = recommendation_labels
+    )
+
+
+    selectize_options <- list(create = TRUE, maxItems = 1)
+
+    # Update a row with the function 'db_update_participants'
+    # @param data the data including your updated row
+    update_callback <- function(data, olddata, row) {
+      browser()
+      db_update_participants(cons, collection_name = "Stage_Profiles",data[row,])
+      data
+    }
+
+    # Ignore the delete and insert callbacks
+    insert_callback <- NULL
+    delete_callback <- NULL
+  } 
+  else {
+    # if there is a supplementary table sublist, do this
+    #### NOTE: db insert, update, and delete are defined specifically for Checkinout
+
+    db_operations <- suppl_table_sublist[[table_type]]$editable$operations
+    allow_delete <- "D" %in% db_operations
+    allow_update <- "U" %in% db_operations
+    allow_insert <- FALSE #' C' %in% db_operations
+
+    # Make status a factor so you can use selectInput
+    table_data$status <- as.factor(table_data$status)
+
+    input_types = c(status = 'selectInput')
+    input_choices = list(
+      status = 
+        c(TRUE,FALSE)
+    )
+
+    selectize_options <- NULL
+
+    if ("edit_columns" %in% names(suppl_table_sublist[[table_type]]$editable)) {
+      edit_columns <- suppl_table_sublist[[table_type]]$editable$edit_columns
+    } else {
+      edit_columns <- "status"
+    }
+
+    # Define the callback functions used by dtedit
+    # Insert a row. "Create"
+    # @param data the data including your inserted row
+    # @param row the row where you made the change
+    insert_callback <- function(data, row) {
+      db_insert(cons, table_type, data[row, ])
+      return(data)
+    }
+
+    # Update a row
+    # @param data the data including your updated row
+    update_callback <- function(data, olddata, row) {
+      db_update(cons, table_type, data[row, ])
+      data
+    }
+
+    # Delete a row
+    delete_callback <- function(data, row) {
+      db_delete(cons, table_type, data[row, ])
+      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 = names(table_data),
+
+    edit.cols = edit_columns, 
+    input.types = input_types, 
+    input.choices = input_choices,
+    selectize = TRUE,
+    selectize.options = selectize_options,
+    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,
@@ -87,7 +161,10 @@ mod_DTedit_server <- function(input, output, session, table_data, table_type,
     show.delete = allow_delete,
     show.copy = FALSE,
     label.delete = "Delete Row",
-    datatable.options = DT_options
+
+    datatable.options = DT_options,
+    filter = list(position = "top", clear = FALSE),
+    extensions = "Buttons"
   )
 }
 

R/mod_load_data.R

@@ -44,8 +44,20 @@ 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("{}") %>%
-          as.data.table()
+
+        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
+                                 ) %>% 
+
+            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]] %>%

R/utils_query_database.R

@@ -439,7 +439,8 @@ query_stage_uuids <- function(cons) {
 #' @rdname query
 #' @export
 query_stage_profiles <- function(cons) {
-  cons$Stage_Profiles$find() %>%
+  cons$Stage_Profiles$find(query = '{}',
+                           fields = '{}') %>%
     as.data.table() %>%
     normalise_uuid(., keep_uuid = FALSE)
 }

R/utils_update_insert_delete.R

@@ -16,35 +16,52 @@ db_update <- function(cons, collection_name, df_row) {
   # db$collection$update('{"name":"jerry"}', '{"$set":{"age": 31}}')
   # Example user_id_string: {"user_id": "Extra_User", "bikeLabel": "WestTower"}
 
-  user_id_string <- paste0('{\"user_id\": \"', df_row$user_id, '\", ', '\"bikeLabel\": \"', df_row$bikeLabel, '\"}') # %>% cat
-  new_status <- isTRUE(df_row$status %>% as.character() %>% as.logical())
-  logic_string <- ifelse(new_status, "true", "false") # if status is TRUE, output 'true'
-
+  # user_id_string <- paste0('{\"user_id\": \"', df_row$user_id, '\", ', '\"bikeLabel\": \"', df_row$bikeLabel, '\"}') # %>% cat
+  # new_status <- isTRUE(df_row$status %>% as.character() %>% as.logical())
+  # logic_string <- ifelse(new_status, "true", "false") # if status is TRUE, output 'true'
+
+
+  object_id_string <- sprintf('{\"_id\": {\"$oid\": \"%s\"}}', df_row$`_id`)
   set_string <- paste0('{\"$set":{\"status\":', logic_string, "}}") # %>% cat
 
-  cons[[collection_name]]$update(user_id_string, set_string)
+  cons[[collection_name]]$update(object_id_string, set_string)
 }
 
+#' Updates a participant related document with the row 'df_row'
+#' @param cons connection to mongodb
+#' @param collection_name the collection to look in
+#' @param df_row the dataframe row to update with
+db_update_participants <- function(cons,collection_name,df_row){
+
+  # Make sure the object id is correct for the collection you are using.
+  # My plan is to use the collection, 'Stage_Profiles' to store recommendations.
+
+  object_id_string <- sprintf('{\"_id\": {\"$oid\": \"%s\"}}', df_row$`_id`)
+
+  set_string <- sprintf('{\"$set":{\"recommendation\": \"%s\"}}',df_row$recommendation)
+
+  cons[[collection_name]]$update(object_id_string,set_string)
+}
 
 #' Deletes a document from Checkinout corresponding to df_row
 #' @param cons connection to mongodb
 #' @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) {
-  if (df_row$user_id == "") {
-    # In case the entry has no user id
-    user_id_string <- paste0('{\"user_id\": {\"$exists\" : "false" }, ', '\"bikeLabel\": \"', df_row$bikeLabel, '\"}')
-    cons$Checkinout$remove(user_id_string, just_one = TRUE)
-  } else {
-    user_id_string <- paste0('{\"user_id\": \"', df_row$user_id, '\", ', '\"bikeLabel\": \"', df_row$bikeLabel, '\"}')
-    cons[[collection_name]]$remove(user_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)
+
 }
 
+
+### Below is meant for easy set up and testing of the db functions.
+
+
 # cons <- connect_stage_collections(url = getOption('emdash.mongo_url'))
 # t <- cons$Checkinout$find()
-## Example
-# Setting up extra entries to delete or edit.
+# # Example
+# # Setting up extra entries to delete or edit.
 # for (j in 1:60){
 #   user_id <- paste(j)
 #   status <- FALSE