Merge pull request #149 from RE-QDA/dev

A bundle of backend/frontend changes and refactoring. Main point: - displayed segments are now calculated for each <p> so that we actually generate valid html for <b> tags (closing them within the encompassing paragraph) - new css styles and classes - new system observers for annotation screen - toggle for highlight/underline - toggle for two-column display of codes - incorporated small JS library for draggable column width in annotation screen - Quick Tag function using iframe setup for annotation screen plus necessary JS functions - fixes #120 - code editing functionality - fixes #37 - click on document name in analysis screen takes users to annotation screen with corresponding document - fixes #130
RE-QDA · Jan 5, 2025 · 609371f · 609371f
2 parents dee09b3 + ab02998
commit 609371f
Show file tree

Hide file tree

Showing 50 changed files with 1,887 additions and 281 deletions.
diff --git a/.gitignore b/.gitignore
@@ -14,3 +14,8 @@ requal_users.sqlite
 # gh-pages
 .quarto
 wiki/
+tests/test.requal
+
+# dev stuff
+test-iframe.R
+wip.R
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: requal
 Title: Shiny Application for Computer-Assisted Qualitative Data Analysis
-Version: 1.1.2.9003
+Version: 1.1.3.9000
 Authors@R:
     c(
      person(given = "Radim",

diff --git a/DEV-NOTES.md b/DEV-NOTES.md
@@ -30,6 +30,7 @@ Instruction for local development of `requal` server version.
 - [x] add code
 - [x] merge codes
 - [x] delete code
+- [x] edit code
 - [x] export codebook
 
 #### Categories

diff --git a/R/app_server.R b/R/app_server.R
@@ -87,6 +87,16 @@ app_server <- function(input, output, session) {
         shinyjs::show(selector = ".mfb-component--bl")
         }
   })
+
+  # observe screens
+    observeEvent(input$analyze_link,{
+      updateTabsetPanel(session, "tab_menu", input$analyze_link$tab_menu)
+      glob$analyze_link <- list(
+        doc_id = input$analyze_link$doc_id,
+        segment_start = input$analyze_link$segment_start
+        )
+  })
+
   # shared
   mod_download_csv_server("download_csv_ui_1", glob)
 

diff --git a/R/db_logging.R b/R/db_logging.R
@@ -80,6 +80,14 @@ log_merge_code_record <- function(con, project_id, from, to, user_id){
                data = list(merge_from = from, merge_to = to))
 }
 
+log_edit_code_record <- function(con, project_id, changes, user_id){
+    log_action(con, 
+               user_id = user_id, 
+               project_id = project_id, 
+               action = "Edit code", 
+               data = changes)
+}
+
 log_add_segment_record <- function(con, project_id, segment, user_id){
     log_action(con, 
                user_id = user_id, 
@@ -206,4 +214,5 @@ log_change_user_permission <- function(con, project_id, permission_data, user_id
                project_id,
                action = "Change user permission", 
                data = permission_data)
-}
+}
+
diff --git a/R/db_startup.R b/R/db_startup.R
@@ -1,4 +1,4 @@
-utils::globalVariables(c("sql"))
+utils::globalVariables(c("sql", "is_new_quickcode"))
 
 db_call <- c(
 
@@ -555,11 +555,12 @@ add_cases_record <- function(pool, project_id, case_df, user_id) {
 }
 
 add_codes_record <- function(pool, project_id, codes_df, user_id) {
+
   res <- DBI::dbWriteTable(pool, "codes", codes_df, append = TRUE, row.names = FALSE)
   if (res) {
     written_code_id <- dplyr::tbl(pool, "codes") %>%
       dplyr::filter(.data$code_name == !!codes_df$code_name, 
-                    .data$project_id == !!as.numeric(project_id), 
+                    .data$project_id == !!as.integer(project_id), 
                     .data$user_id == !!user_id) %>%
       dplyr::pull(code_id)
 
@@ -574,6 +575,36 @@ add_codes_record <- function(pool, project_id, codes_df, user_id) {
   }
 }
 
+add_quickcode_record <- function(pool, project_id, codes_df, user_id) {
+
+      # Make sure column exists to identify new quickcode
+      db_helper_column(pool, "codes", "is_new_quickcode", "add")
+      # temporarily write into DB with original code_id
+      codes_df$is_new_quickcode <- 1
+
+  res <- DBI::dbWriteTable(pool, "codes", codes_df, append = TRUE, row.names = FALSE)
+  if (res) {
+    written_code_id <- dplyr::tbl(pool, "codes") %>%
+      dplyr::filter(.data$project_id == !!as.integer(project_id), 
+                    .data$user_id == !!as.integer(user_id),
+                    is_new_quickcode == 1) %>%
+      dplyr::pull(code_id)
+    # remove helper column from DB
+      db_helper_column(pool, "codes", "is_new_quickcode", "drop")
+    # just a check we are getting the latest id
+    written_code_id <- written_code_id[written_code_id == max(written_code_id)]
+    log_add_code_record(pool, project_id, codes_df %>%
+                          dplyr::mutate(
+                            is_new_quickcode = NULL,
+                            code_id = written_code_id), 
+                        user_id
+    )
+    return(written_code_id)
+  } else {
+    warning("code not added")
+  }
+}
+
 add_case_doc_record <- function(pool, project_id, case_doc_df, user_id) {
   res <- DBI::dbWriteTable(pool, "cases_documents_map", case_doc_df, append = TRUE, row.names = FALSE)
   if (res) {
@@ -627,4 +658,5 @@ make_globals <- quote({
       existing_projects <- data.frame()
     }
   }
-})
+})
+
diff --git a/R/import_rqda.R b/R/import_rqda.R
@@ -41,8 +41,8 @@ rql_import_rqda <- function(rqda_file, requal_file){
         RSQLite::SQLite(), 
         dbname = requal_file
     )
-    
-    message("Loading data from RQDA")
+
+    rql_message("Loading data from RQDA")
     # Load Data from RQDA
     project_df <- dplyr::tbl(rqda_con, "project") %>% 
         dplyr::collect() %>% 
@@ -117,7 +117,7 @@ rql_import_rqda <- function(rqda_file, requal_file){
         dplyr::filter(!is.na(code_id))
 
     # Create requal schema
-    message("Creating Requal scheme")
+    rql_message("Creating Requal scheme")
     create_db_schema(requal_pool)
 
     # Import to requal
@@ -129,23 +129,23 @@ rql_import_rqda <- function(rqda_file, requal_file){
         dplyr::pull(project_id) %>% 
         utils::tail(1)
 
-    message("Importing documents")
+    rql_message("Importing documents")
     documents_df <- rqda_documents %>% 
         dplyr::mutate(project_id = requal_project_id)
     purrr::walk(seq_len(nrow(documents_df)), function(x) {
         add_documents_record(requal_pool, requal_project_id, documents_df[x, ], 
                              user_id = USER_ID)
     })
 
-    message("Importing cases")
+    rql_message("Importing cases")
     cases_df <- rqda_cases %>% 
         dplyr::mutate(project_id = requal_project_id)
     purrr::walk(seq_len(nrow(cases_df)), function(x) {
         add_cases_record(requal_pool, requal_project_id, cases_df[x, ], 
                          user_id = USER_ID)
     })
 
-    message("Importing case document map")
+    rql_message("Importing case document map")
     case_doc_map <- rqda_case_doc_map %>% 
         dplyr::mutate(project_id = requal_project_id)
     purrr::walk(seq_len(nrow(case_doc_map)), function(x) {
@@ -157,7 +157,7 @@ rql_import_rqda <- function(rqda_file, requal_file){
         dplyr::filter(is.na(code_color)) %>% 
         nrow()
 
-    message("Importing codes")
+    rql_message("Importing codes")
     codes_df <- rqda_codes %>% 
         dplyr::mutate(project_id = requal_project_id, 
                       code_color = ifelse(is.na(code_color), 
@@ -168,7 +168,7 @@ rql_import_rqda <- function(rqda_file, requal_file){
                          user_id = USER_ID)    
     })
 
-    message("Importing categories")
+    rql_message("Importing categories")
     categories_df <- rqda_categories %>% 
         dplyr::mutate(project_id = requal_project_id)
     purrr::walk(seq_len(nrow(categories_df)), function(x) {
@@ -177,7 +177,7 @@ rql_import_rqda <- function(rqda_file, requal_file){
                             user_id = USER_ID)
     })
 
-    message("Importing category code mapping")
+    rql_message("Importing category code mapping")
     category_code_map <- rqda_category_code_map %>% 
         dplyr::mutate(project_id = requal_project_id)
     purrr::walk(seq_len(nrow(category_code_map)), function(x) {
@@ -186,7 +186,7 @@ rql_import_rqda <- function(rqda_file, requal_file){
                                  user_id = USER_ID)
     })
 
-    message("Importing segments")
+    rql_message("Importing segments")
     segments_df <- rqda_segments %>% 
         dplyr::mutate(project_id = requal_project_id, 
                       segment_text = purrr::pmap_chr(
@@ -204,7 +204,7 @@ rql_import_rqda <- function(rqda_file, requal_file){
                                user_id = USER_ID)    
     })
 
-    message("Importing memos")
+    rql_message("Importing memos")
     if(!all(is.na(rqda_segments$memo))){
         DBI::dbWriteTable(requal_pool, "memos", memos_df %>% dplyr::select(memo_id, text), 
                           append = TRUE, row.names = FALSE)

diff --git a/R/mod_analysis.R b/R/mod_analysis.R
@@ -200,16 +200,20 @@ mod_rql_button_server(
       if (nrow(loc$segments_df) > 0) {
         loc$segments_taglist <- purrr::pmap(
           list(
+            loc$segments_df$segment_start,
             loc$segments_df$segment_text,
+            loc$segments_df$doc_id,
             loc$segments_df$doc_name,
             loc$segments_df$code_name,
             loc$segments_df$code_color
           ),
           ~ format_segments(
-            segment_text = ..1,
-            segment_document = ..2,
-            segment_code = ..3,
-            segment_color = ..4
+            segment_start = ..1,
+            segment_text = ..2,
+            segment_document_id = ..3,
+            segment_document_name = ..4,
+            segment_code = ..5,
+            segment_color = ..6
           )
         )
       }

diff --git a/R/mod_analysis_utils_analysis.R b/R/mod_analysis_utils_analysis.R
@@ -50,7 +50,7 @@ load_segments_analysis <- function(pool,
 
 
 
-format_segments <- function(segment_text, segment_document, segment_code, segment_color) {
+format_segments <- function(segment_start, segment_text, segment_document_id, segment_document_name, segment_code, segment_color) {
 
 
   tags$div(
@@ -59,8 +59,11 @@ format_segments <- function(segment_text, segment_document, segment_code, segmen
     tags$blockquote(class = "quote", style =  paste0("border-left: 5px solid ", segment_color, "; margin-bottom: 0px !important;")),
 
 tags$div(
-    segment_document %>%
-      tags$div(class = "segment_badge"),
+  tags$div(class = "segment_badge",
+       actionLink(paste0("segment_start-", segment_start), label = segment_document_name, 
+       onclick =  paste0("Shiny.setInputValue('analyze_link', {tab_menu: 'Annotate', doc_id: ", segment_document_id,", segment_start: ", segment_start, "}, {priority: 'event'});")
+      )
+       ),
 
     segment_code %>%
       tags$div(class = "segment_badge", style = paste0("background-color: ", segment_color, " !important;")),

diff --git a/R/mod_browser.R b/R/mod_browser.R
@@ -170,7 +170,7 @@ mod_browser_server <- function(id, glob){
             tibble::tibble(
               position_start = 0,
               position_type = "segment_start",
-              tag_start = "<article><p class='docpar'>"
+              tag_start = "<article id='article'><p class='docpar'>"
             ),
 
             # content

diff --git a/R/mod_categories.R b/R/mod_categories.R
@@ -95,7 +95,8 @@ mod_categories_server <- function(id, glob) {
     })
 
     # Relist categories on codebook changes ---------------
-    observeEvent(glob$codebook, {
+    observeEvent(c(glob$codebook, 
+                  glob$codebook_observer), {
       output$categories_ui <- renderUI({
         render_categories(
           id = id,