From 5633ea36c3c136aff0e28d6a8dd0d19e80c39742 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Todor=20Kondi=C4=87?= <kontrapunkt@uclmail.net>
Date: Mon, 27 Feb 2023 22:24:32 +0100
Subject: [PATCH] datatab_update_tags: Merge old and new tags correctly.
---
R/errors.R | 10 ++++
R/shiny-state.R | 64 +++++++++++++++++++++++++
R/shiny-ui-base.R | 62 ++++++++++++------------
tests/testthat/_snaps/shiny-state.md | 72 ++++++++++++++++++++++++++++
tests/testthat/test-shiny-state.R | 33 +++++++++++++
5 files changed, 209 insertions(+), 32 deletions(-)
diff --git a/R/errors.R b/R/errors.R
index cba3547..7764c45 100644
--- a/R/errors.R
+++ b/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")))
+ }
+}
diff --git a/R/shiny-state.R b/R/shiny-state.R
index c8c0bbc..902665f 100644
--- a/R/shiny-state.R
+++ b/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()
diff --git a/R/shiny-ui-base.R b/R/shiny-ui-base.R
index cac3579..932d2a9 100644
--- a/R/shiny-ui-base.R
+++ b/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
diff --git a/tests/testthat/_snaps/shiny-state.md b/tests/testthat/_snaps/shiny-state.md
index b0e8fa6..1587227 100644
--- a/tests/testthat/_snaps/shiny-state.md
+++ b/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"
+
+
diff --git a/tests/testthat/test-shiny-state.R b/tests/testthat/test-shiny-state.R
index 4cd0e28..a626254 100644
--- a/tests/testthat/test-shiny-state.R
+++ b/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)
+
+
+
+})
--
GitLab