datatab_update_tags: Merge old and new tags correctly.

R/errors.R

@@ -94,3 +94,13 @@ check_conf_absent <- function(cfgfile) {
     check_notastring(cfgfile,"envopts")
     if (!file.exists(cfgfile)) stop(errorCondition("The system configuration file does not exist. Please initialise shinyscreen by calling `shinyscreen::init' function.", class="envopts-file-absent"))
 }
+
+check_len_zero <- function(value,what) {
+    if (length(value)==0L) stop(errorCondition(paste0("The length of variable ",what," is zero."),class=paste0(what,"-len-zero")))
+}
+
+check_same_len <- function(value1,what1,value2,what2) {
+    if (length(value1)!=length(value2)) {
+        stop(errorCondition(paste0("The lengths of variables ", what1, " and ", what2," are not the same."), class=paste0(what1,"-",what2,"-lens-not-equal")))
+    }
+}

R/shiny-state.R

@@ -78,6 +78,70 @@ filetag_add_file <- function(filetag,file) {
     filetag
 }
 
+
+datatab_update_tags <- function(tab,tags,files) {
+    check_same_len(files,"files",tags,"tags")
+
+    nft = data.table(tag=tags,
+                     file=files,key="file")
+    oldt = data.table(tag=tab$tag,
+                      adduct=tab$adduct,
+                      set=tab$set,
+                      file=tab$file,key=c("file"))
+
+
+    ## Adapt existing tags.
+    res = merge(nft,oldt,by=c("file","tag"),all.x=T)
+    tab$tag = res$tag
+    tab$file= res$file
+    tab$set = res$set
+    tab$adduct = res$adduct
+    tab
+}
+
+datatab_add_files <- function(tab,sets,adducts,tags,files) {
+
+    check_same_len(files,tags)
+
+    nft = data.table(tag=tags,
+                     file=files,key="file")
+    oldt = data.table(tag=tab$tag,
+                      adduct=tab$adduct,
+                      set=tab$set,
+                      file=tab$file,key=c("file"))
+
+
+    ## Adapt existing tags.
+    oldt[nft,tag:=i.tag]
+
+    
+    if (length(files)>0 ||(length(sets)>0L || length(adducts)>0L)) {
+        ## We are adding new set/adduct entries.
+        check_len_zero(sets,"sets")
+        check_len_zero(adducts,"adducts")
+        check_len_zero(files,"files")
+        rows = prod(length(files),length(sets),length(adducts))
+        newt = data.table(tag=rep(tags,rows/length(tags)),
+                          adduct=rep(adducts,rows/length(adducts)),
+                          set=rep(sets,rows/length(sets)),
+                          file=rep(files,rows/length(files)))
+
+        if (length(files)>0L) {
+            ## Modifying files.
+
+            ## Add new set and adduct entries to the old table.
+            fullt = newt[oldt,on=c("set","adduct")]
+
+            ## Now, add/remove files as needed.
+            ## nft2 = newt[,..nft,by=c
+            ## res = fullt[nft,on=c("tag","adduct","set","file")]
+            
+        
+        }
+                                    
+    }
+}
+
 #' @export
 create_stub_gui <- function() {
     gui = list()

R/shiny-ui-base.R

@@ -1118,41 +1118,39 @@ mk_shinyscreen_server <- function(projects,init) {
             
         }, label = "datafiles-edit")
 
-        ## observeEvent(input$datatab_cell_edit,{
-        ##     df = gen_dtab(rvs$gui$datatab,sets=rf_get_sets())
-        ##     z = DT::editData(df,
-        ##                       input$datatab_cell_edit,
-        ##                       rownames = F)
-
-        ##     rvs$gui$datatab$set = z$set
-        ##     rvs$gui$datatab$adduct = z$adduct
-        ## }, label = "datatab-edit")
-
         observe({
-            selected_adducts = input$tag_adducts_list
-            ## selected_adducts[selected_adducts == "NA"] = NA_character_
-            selected_sets = input$tag_sets_list
-            ## selected_sets[selected_sets == "NA"] = NA_character_
-            selected_rows = input$datafiles_rows_selected
-            if (isTruthy(selected_rows)) {
-                selected_tags = rvs$gui$datafiles$tag[selected_rows]
-                dt_rows = which(rvs$gui$datatab$tag %in% selected_tags)
-                if (isTruthy(selected_sets)) {
-                    rvs$gui$datatab$set[dt_rows] = selected_sets
-                    updateSelectInput(session=session,
-                                      inputId="tag_adducts_list",
-                                      selected=NULL)
-                }
+            tags = rvs$gui$filetag$tag
+            files = rvs$gui$filetag$file
+            rvs$gui$datatab = datatab_update_tags(rvs$gui$datatab,
+                                                  tags=tags,
+                                                  files=files)
+        }, label = "datafiles-update-tags")
 
-                if (isTruthy(selected_adducts)) {
-                    rvs$gui$datatab$adduct[dt_rows] = selected_adducts
-                    updateSelectInput(session=session,
-                                      inputId="tag_sets_list",
-                                      selected=NULL)
-                }
-            }
+        observe({
+            ## selected_adducts = input$tag_adducts_list
+            ## ## selected_adducts[selected_adducts == "NA"] = NA_character_
+            ## selected_sets = input$tag_sets_list
+            ## ## selected_sets[selected_sets == "NA"] = NA_character_
+            ## selected_rows = input$datafiles_rows_selected
+            ## if (isTruthy(selected_rows)) {
+            ##     selected_tags = rvs$gui$datafiles$tag[selected_rows]
+            ##     dt_rows = which(rvs$gui$datatab$tag %in% selected_tags)
+            ##     if (isTruthy(selected_sets)) {
+            ##         rvs$gui$datatab$set[dt_rows] = selected_sets
+            ##         updateSelectInput(session=session,
+            ##                           inputId="tag_adducts_list",
+            ##                           selected=NULL)
+            ##     }
+
+            ##     if (isTruthy(selected_adducts)) {
+            ##         rvs$gui$datatab$adduct[dt_rows] = selected_adducts
+            ##         updateSelectInput(session=session,
+            ##                           inputId="tag_sets_list",
+            ##                           selected=NULL)
+            ##     }
+            ## }
             
-        }, label = "datatab-set-associations")
+        }, label = "datatab-construct")
 
         ## OBSERVERS: CONFIGURATION AND EXTRACTION
         

tests/testthat/_snaps/shiny-state.md

@@ -34,3 +34,75 @@
       [1] "F1" "XY" "F3" "F4"
       
 
+# datatab_update_tags works properly
+
+    Code
+      out1
+    Output
+      $tag
+      character(0)
+      
+      $adduct
+      character(0)
+      
+      $set
+      character(0)
+      
+      $file
+      character(0)
+      
+
+---
+
+    Code
+      out2
+    Output
+      $tag
+      [1] "A" "B"
+      
+      $adduct
+      [1] NA NA
+      
+      $set
+      [1] NA NA
+      
+      $file
+      [1] "f1.f" "f2.f"
+      
+
+---
+
+    Code
+      out3
+    Output
+      $tag
+      [1] "X" "B"
+      
+      $adduct
+      [1] NA NA
+      
+      $set
+      [1] NA NA
+      
+      $file
+      [1] "f1.f" "f2.f"
+      
+
+---
+
+    Code
+      out4
+    Output
+      $tag
+      [1] "Y" "Z"
+      
+      $adduct
+      [1] NA NA
+      
+      $set
+      [1] NA NA
+      
+      $file
+      [1] "fx.f" "fy.f"
+      
+

tests/testthat/test-shiny-state.R

@@ -17,3 +17,36 @@ test_that("filetag_add_file works properly",{
     output3=filetag_add_file(input3,c("file2.mzML"))
     expect_snapshot(output3)
 })
+
+test_that("datatab_update_tags works properly",{
+    tab1=list(tag=character(0),
+              adduct=character(0),
+              set=character(0),
+              file=character(0))
+    out1 = datatab_update_tags(tab=tab1,
+                               tags=character(0),
+                               files=character(0))
+    expect_snapshot(out1)
+
+    out2 = datatab_update_tags(tab=tab1,
+                               tags=c("A","B"),
+                               files=c("f1.f","f2.f"))
+    
+    expect_snapshot(out2)
+
+    tab2 = out2
+    out3 = datatab_update_tags(tab=tab1,
+                               tags=c("X","B"),
+                               files=c("f1.f","f2.f"))
+    expect_snapshot(out3)
+
+
+    tab3 = out3
+    out4 = datatab_update_tags(tab=tab3,
+                               tags=c("Y","Z"),
+                               files=c("fx.f","fy.f"))
+    expect_snapshot(out4)
+
+    
+    
+})