Merge pull request #137 from openpharma/jt-99-review_by_row

Review by records instead of `subject_id` & `form_id` "rv_row"
openpharma · Dec 2, 2024 · 5845568 · 5845568
2 parents b2bd9bb + d8e24d4
commit 5845568
Show file tree

Hide file tree

Showing 18 changed files with 155 additions and 202 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: clinsight
 Title: ClinSight
-Version: 0.1.0.9010
+Version: 0.1.1.9011
 Authors@R: c(
     person("Leonard Daniël", "Samson", , "[email protected]", role = c("cre", "aut"),
            comment = c(ORCID = "0000-0002-6252-7639")),

diff --git a/NAMESPACE b/NAMESPACE
@@ -27,7 +27,6 @@ export(datatable_custom)
 export(date_cols_to_char)
 export(db_create)
 export(db_get_query)
-export(db_get_review)
 export(db_save)
 export(db_save_review)
 export(db_slice_rows)

diff --git a/NEWS.md b/NEWS.md
@@ -9,6 +9,7 @@
 - Added form type as a class to be used in `create_table()` to display tables.
 - Add a logging table to the DB for reviews.
 - Simplify pulling data from DB for reviews.
+- Review data by records IDs instead of subject & form
 
 ## Bug fixes
 

diff --git a/R/fct_SQLite.R b/R/fct_SQLite.R
@@ -319,63 +319,50 @@ db_upsert <- function(con, data, idx_cols) {
 #' New rows with the new/updated review data will be added to the applicable
 #' database tables.
 #'
-#' @param rv_row A data frame containing the row of the data that needs to be
+#' @param rv_records A data frame containing the rows of data that needs to be
 #'   checked.
 #' @param db_path Character vector. Path to the database.
-#' @param tables Character vector. Names of the tables within the database to
+#' @param table Character vector. Names of the table within the database to
 #'   save the review in.
-#' @param review_by A character vector, containing the key variables to perform
-#'   the review on. For example, the review can be performed on form level
-#'   (writing the same review to all items in a form), or on item level, with a
-#'   different review per item.
 #'
 #' @return Review information will be written in the database. No local objects
 #'   will be returned.
 #' @export
 #' 
 db_save_review <- function(
-    rv_row,
+    rv_records,
     db_path,
-    tables = c("all_review_data"),
-    review_by = c("subject_id", "item_group")
+    table = "all_review_data"
 ){
-  stopifnot(is.data.frame(rv_row))
-  if(nrow(rv_row) != 1){
-    warning("multiple rows detected to save in database. Only the first row will be selected.")
-    rv_row <- rv_row[1, ]
+  stopifnot(is.data.frame(rv_records))
+  stopifnot(is.character(table) && length(table) == 1)
+  if (any(duplicated(rv_records[["id"]]))) {
+    warning("duplicate records detected to save in database. Only the first will be selected.")
+    rv_records <- rv_records[!duplicated(rv_records[["id"]]),]
   }
-  
+
   cols_to_change <- c("reviewed", "comment", "reviewer", "timestamp", "status")
   db_con <- get_db_connection(db_path)
-  new_review_state <- rv_row$reviewed
-  cat("copy row ids into database\n ")
-  dplyr::copy_to(db_con, rv_row[review_by], "row_ids")
-  new_review_rows <-  dplyr::tbl(db_con, "all_review_data") |> 
-    dplyr::inner_join(dplyr::tbl(db_con, "row_ids"), by = review_by) |> 
-    # Filter below prevents unnecessarily overwriting the review status in forms   
-    # with mixed reviewed status (due to an edit by the investigators). 
-    dplyr::filter(reviewed != new_review_state) |> 
-    dplyr::collect()
-  if(nrow(new_review_rows) == 0){return(
+  if(nrow(rv_records) == 0){return(
     warning("Review state unaltered. No review will be saved.")
   )}
-  new_review_rows <- new_review_rows |> 
-    dplyr::select(-dplyr::all_of(cols_to_change)) |> 
-    dplyr::bind_cols(rv_row[cols_to_change]) # bind_cols does not work in a db connection.
+
   cat("write updated review data to database\n")
-  dplyr::copy_to(db_con, new_review_rows, "row_updates")
+  dplyr::copy_to(db_con, rv_records, "row_updates")
   rs <- DBI::dbSendStatement(db_con, paste(
     "UPDATE",
-    tables,
+    table,
     "SET",
     sprintf("%1$s = row_updates.%1$s", cols_to_change) |> paste(collapse = ", "),
     "FROM",
     "row_updates",
     "WHERE",
-    sprintf("%s.id = row_updates.id", tables)
+    sprintf("%s.id = row_updates.id", table),
+    "AND",
+    sprintf("%s.reviewed <> row_updates.reviewed", table)
   ))
   DBI::dbClearResult(rs)
-  cat("finished writing to the tables:", tables, "\n")
+  cat("finished writing to the table:", table, "\n")
 }
 
 #' Append database table
@@ -473,53 +460,46 @@ db_get_query <- function(
 #' with the given subject id (`subject`) and `form`.
 #'
 #' @param db_path Character vector. Needs to be a valid path to a database.
-#' @param subject Character vector with the subject identifier to select from
-#'   the database.
-#' @param form Character vector with the form identifier to select from the
-#'   database.
+#' @param ... Named arguments specifying which records to retrieve, see
+#'   examples. Note that `...` will be processed with `data.frame()` and thus
+#'   the arguments within `...` should be convertible to a data frame. This is
+#'   chosen so that filters of length one can be used with other filters since
+#'   they will be recycled (for example, when selecting multiple events of one
+#'   subject). 
+#' @param db_table Character string. Name of the table to collect. Will only be
+#'   used if `data` is a character string to a database.
 #'
-#' @inheritParams db_slice_rows
 #' @return A data frame.
-#' @export
-#'
-#' @examples
-#'
-#' local({
-#'   temp_path <- withr::local_tempfile(fileext = ".sqlite")
-#'   con <- get_db_connection(temp_path)
-#'   review_data <- data.frame(
-#'   subject_id = "Test_name",
-#'    event_name = "Visit 1",
-#'    item_group = "Test_group",
-#'    form_repeat = 1,
-#'    item_name = "Test_item",
-#'    edit_date_time = "2023-11-05 01:26:00",
-#'    timestamp = "2024-02-05 01:01:01"
-#'   ) |>
-#'    dplyr::as_tibble()
-#'   DBI::dbWriteTable(con, "all_review_data", review_data)
-#'   db_get_review(temp_path, subject = "Test_name", form = "Test_group")
-#' })
+#' @keywords internal
 #' 
 db_get_review <- function(
     db_path, 
-    subject = review_row$subject_id, 
-    form = review_row$item_group,
-    db_table = "all_review_data",
-    slice_vars = c("timestamp", "edit_date_time"),
-    group_vars = c("subject_id", "event_name", "item_group",
-                   "form_repeat", "item_name")
+    ...,
+    db_table = "all_review_data"
 ){
   stopifnot(file.exists(db_path))
-  stopifnot(is.character(subject))
-  stopifnot(is.character(form))
+  fields <- ...names()
+  if (is.null(fields)) {
+    if (...length() > 0) {
+      warning("Unnamed arguments passed in `...`. Returning full data table.")
+    } else {
+      warning("No arguments passed in `...`. Returning full data table.")
+    }
+    conditionals <- "true"
+  } else {
+    conditionals <- paste0(fields, " = $", fields, collapse = " AND ")
+    parameters <- data.frame(...)
+  }
+
   db_temp_connect(db_path, {
-    sql <- "SELECT * FROM ?db_table WHERE subject_id = ?id AND item_group = ?group;"
-    query <- DBI::sqlInterpolate(con, sql, db_table = db_table[1], 
-                                 id = subject[1], group = form[1])
-    DBI::dbGetQuery(con, query) |> 
-      db_slice_rows(slice_vars = slice_vars, group_vars = group_vars) |> 
+    sql <- paste("SELECT * FROM ?db_table WHERE", conditionals)
+    query <- DBI::sqlInterpolate(con, sql, db_table = db_table[1])
+    rs <- DBI::dbSendQuery(con, query)
+    if (!is.null(fields)) DBI::dbBind(rs, params = parameters)
+    df <- DBI::dbFetch(rs) |> 
       dplyr::as_tibble()
+    DBI::dbClearResult(rs)
+    df
   })
 }
 

diff --git a/R/mod_review_forms.R b/R/mod_review_forms.R
@@ -110,14 +110,9 @@ mod_review_forms_server <- function(
     ns <- session$ns
 
     review_data_active <- reactive({
-      df <- r$review_data |>
-        dplyr::filter(subject_id == r$subject_id, 
-                      item_group == active_form()) |> 
-        dplyr::distinct(subject_id, item_group, edit_date_time, reviewed, comment, status)
-      #!! below selects the latest edit_date_time; usually only one row will remain by then since there are no items displayed here.
-      if(nrow(df)== 0) return(df)
-      df |> 
-        dplyr::filter(edit_date_time == max(as.POSIXct(edit_date_time)))
+      with(r$review_data, r$review_data[
+        subject_id == r$subject_id & item_group == active_form(),
+        ])
     }) 
 
     observeEvent(c(active_form(), r$subject_id), {
@@ -136,8 +131,8 @@ mod_review_forms_server <- function(
         # it will give a warning. This would be rare since it would mean a datapoint with the same edit date-time was reviewed but another one was not. 
         # probably better to use defensive coding here to ensure the app does not crash in that case. However we need to define which review status we need to select
         # in this case get the reviewed = "No"
-        review_status  <- unique(review_data_active()$reviewed)
-        review_comment <- unique(review_data_active()$comment)
+        review_status <- with(review_data_active(), reviewed[edit_date_time == max(as.POSIXct(edit_date_time))]) |> unique()
+        review_comment <- with(review_data_active(), comment[edit_date_time == max(as.POSIXct(edit_date_time))]) |> unique()
         if(length(review_status) != 1) warning("multiple variables in review_status, namely: ", 
                                                review_status, "Verify data.")
       }
@@ -191,8 +186,8 @@ mod_review_forms_server <- function(
         ) 
       if(!enable_any_review()) return(FALSE)
       any(c(
-        unique(review_data_active()$reviewed) == "No"  & input$form_reviewed, 
-        unique(review_data_active()$reviewed) == "Yes" & !input$form_reviewed
+        unique(with(review_data_active(), reviewed[edit_date_time == max(as.POSIXct(edit_date_time))])) == "No"  & input$form_reviewed, 
+        unique(with(review_data_active(), reviewed[edit_date_time == max(as.POSIXct(edit_date_time))])) == "Yes" & !input$form_reviewed
       ))
     })
 
@@ -231,8 +226,12 @@ mod_review_forms_server <- function(
       review_save_error(FALSE)
       golem::cat_dev("Save review status reviewed:", input$form_reviewed, "\n")
 
-      review_row <- review_data_active() |> 
-        dplyr::distinct(subject_id, item_group) |> 
+      old_review_status <- if (!input$form_reviewed) "Yes" else "No"
+      review_records <- review_data_active()[
+        review_data_active()$reviewed == old_review_status,
+        "id", 
+        drop = FALSE
+        ] |> 
         dplyr::mutate(
           reviewed    = if(input$form_reviewed) "Yes" else "No",
           comment     = ifelse(is.null(input$review_comment), "", input$review_comment),
@@ -241,46 +240,34 @@ mod_review_forms_server <- function(
           status      = if(input$form_reviewed) "old" else "new"
         ) 
 
-      golem::cat_dev("review row to add:\n")
-      golem::print_dev(review_row)
+      golem::cat_dev("review records to add:\n")
+      golem::print_dev(review_records)
 
       cat("write review progress to database\n")
       db_save_review(
-        review_row, 
+        review_records, 
         db_path = db_path,
-        # More tables can be added here if needed, to track process of 
-        # individual reviewers in individual tables:
-        tables = "all_review_data" 
+        table = "all_review_data" 
       )
 
-      # Contains multiple rows, one for each item.
-      updated_rows_db <- db_get_review(
-        db_path, subject = review_row$subject_id, form = review_row$item_group
-        )[c(names(review_row), "event_name", "item_name", "form_repeat")]
-      # Within a form, only items with a changed review state are updated and 
-      # contain the new (current) time stamp. 
-      updated_rows_db <- updated_rows_db[
-        updated_rows_db$timestamp == review_row$timestamp[1], 
-        ]
+      review_records_db <- db_get_review(
+        db_path, id = review_records$id
+      )[, names(review_records)] 
 
-      review_row_db <- unique(updated_rows_db[names(review_row)])
-      if(identical(review_row_db, review_row)){
+      if (isTRUE(all.equal(review_records_db, review_records, check.attributes = FALSE))){
         cat("Update review data and status in app\n")
         r$review_data <- r$review_data |> 
-          dplyr::rows_update(
-            updated_rows_db, 
-            by = c("subject_id", "item_group", "event_name", "item_name", "form_repeat")
-          )
+          dplyr::rows_update(review_records, by = "id")
       }
 
-      updated_items_memory <- sort(with(r$review_data, item_name[
-        reviewer == review_row$reviewer[1] & timestamp == review_row$timestamp[1]
-      ]))
-      updated_items_db <- sort(updated_rows_db$item_name)
+      updated_records_memory <- r$review_data[
+        r$review_data$id %in% review_records$id,
+        names(review_records_db)
+      ]
 
       review_save_error(any(
-        !identical(review_row_db, review_row),
-        !identical(updated_items_db, updated_items_memory)
+        !isTRUE(all.equal(review_records_db, review_records, check.attributes = FALSE)),
+        !isTRUE(all.equal(updated_records_memory, review_records_db, check.attributes = FALSE))
       ))
 
       if(review_save_error()){
@@ -320,12 +307,15 @@ mod_review_forms_server <- function(
         "No user name found. Cannot save review"
       ))
       validate(need(
-        !review_data_active()$reviewed == "Yes",
+        !unique(with(review_data_active(), reviewed[edit_date_time == max(as.POSIXct(edit_date_time))])) == "Yes",
         "Form already reviewed"
       ))
       validate(need(input$form_reviewed, "Requires review"))
     })
 
+    shiny::exportTestValues(
+      review_save_error = review_save_error()
+    )
   })
 }
 

diff --git a/inst/golem-config.yml b/inst/golem-config.yml
@@ -1,6 +1,6 @@
 default:
   golem_name: clinsight
-  golem_version: 0.1.0.9010
+  golem_version: 0.1.1.9011
   app_prod: no
   user_identification: test_user
   study_data: !expr clinsight::clinsightful_data

diff --git a/man/db_get_review.Rd b/man/db_get_review.Rd