From eaa49e9c4d401ffdf617925dd061fb1797de55d3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Todor=20Kondi=C4=87?= <todor.kondic@uni.lu>
Date: Fri, 16 Sep 2022 12:57:04 +0200
Subject: [PATCH] shiny-state,shiny-ui-base: Fixed summ modification.
---
R/resources.R | 2 +-
R/shiny-state.R | 60 ++++++++++++++++++++++++++++++++------
R/shiny-ui-base.R | 74 ++++++++++++++++++-----------------------------
3 files changed, 80 insertions(+), 56 deletions(-)
diff --git a/R/resources.R b/R/resources.R
index 07b88c2..b4823f7 100644
--- a/R/resources.R
+++ b/R/resources.R
@@ -213,7 +213,7 @@ FIG_DEF_CONF <-list(grouping=list(group="adduct",
## Summary table properties.
-SUMM_COLS=c("set",BASE_KEY_MS2,"an","mz","ms1_rt", "ms1_int", "ms2_rt", "ms2_int",
+SUMM_COLS=c("set",BASE_KEY_MS2,"mz","ms1_rt", "ms1_int", "ms2_rt", "ms2_int",
"ms1_mean","ms2_sel",QA_FLAGS,"Name", "SMILES", "Formula", "known","Comments","file")
SUMM_KEY <- c("set","ID","adduct","tag","an")
diff --git a/R/shiny-state.R b/R/shiny-state.R
index 3119295..c262e21 100644
--- a/R/shiny-state.R
+++ b/R/shiny-state.R
@@ -351,6 +351,9 @@ pre_setup_val_block <- function(gui) {
T
}
+## SHINY HELPERS: COMPOUND INDEX
+
+
## Creating compound index table
##
## Take `summ', group first by set, adduct and id. Then, pick only the
@@ -358,6 +361,7 @@ pre_setup_val_block <- function(gui) {
## this as the group rt. This is, then, a row representing the group
## (of tags, CEs) in the index.
gen_cindex <- function(summ,sorder,cols = CINDEX_COLS,by. = CINDEX_BY) {
+ if (NROW(summ) == 0L) return(NULL)
allc <- c(by.,cols)
xsumm <- summ[,..allc]
setnames(xsumm,old="ms1_rt",new="rt",skip_absent=T)
@@ -390,14 +394,53 @@ gen_cindex <- function(summ,sorder,cols = CINDEX_COLS,by. = CINDEX_BY) {
}
+cindex_from_input <- function(clabs,sort_catg=character(4),summ) {
+ grp <- if (isTruthy(clabs)) setdiff(CINDEX_BY,clabs) else CINDEX_BY
+ sorder <- setdiff(sort_catg,clabs)
+ gen_cindex(summ,sorder=sorder,by=grp)
+}
+
+get_cindex_key <- function(cindex) {
+ ## Select only valid category names.
+ x <- which(CINDEX_BY %in% names(cindex))
+ CINDEX_BY[x]
+}
+
get_cindex_parents <- function(summ,ckey,kvals,labs) {
## Get kvals part of summ.
- tab <- get_data_from_key(summ,kvals)[,unique(.SD),.SDcols=labs,by=key]
+ tab <- summ[(kvals),on=names(kvals)][,unique(.SD),.SDcols=labs,by=ckey] #get_data_from_key(summ,kvals)
tab[,item:=do.call(paste,c(.SD,list(sep=";"))),.SDcol=labs]
keys <- names(tab)[names(tab)!="item"]
data.table::setkeyv(tab,keys)
tab
}
+
+get_cindex_kval <- function(cindex,row,key) {
+ rowtab <- cindex[(row),..key]
+ res <- lapply(rowtab,function (x) x[[1]])
+ names(res) <- key
+ res
+}
+
+get_summ_subset <- function(summ,ptab,paritem,kvals) {
+ select <- ptab[item==(paritem)]
+ tab <- get_data_from_key(summ,kvals)[select,nomatch=NULL,on=key(ptab)]
+ if ("an.1" %in% names(tab)) tab[,an.1:=NULL] #TODO: This is
+ #probably a lousy
+ #hack.
+ tab
+}
+
+get_ltab <- function(summ_subs,cols=c("an","ms2_rt")) {
+ tab <- summ_subs
+ if (NROW(tab)==1L && is.na(tab$an)) return(data.table::data.table(item=character()))
+ tab[is.na(ms2_sel),ms2_sel:=F] #TODO FIXME: Check why NAs exist at all?
+ tab[,passval:=fifelse(qa_pass==T,"OK","BAD")]
+ tab[ms2_sel==T,passval:="SELECTED"]
+ res <- tab[,item:=do.call(paste,c(.SD,list(sep=";"))),.SDcols=c(cols,"passval")]
+ data.table::setkey(res,"ms2_rt")
+ res
+}
update_on_commit_chg <- function(summ,input,ptab,ltab) {
n_ms1_rt = input$chg_ms1_rt
n_ms1_int = input$chg_ms1_int
@@ -410,15 +453,12 @@ update_on_commit_chg <- function(summ,input,ptab,ltab) {
sel_par <- input$sel_parent_trace
sel_spec <- input$sel_spec
-
- ptab <- req(rf_get_cindex_parents())
- ltab <- req(rf_fill_sel_spec())
pkvals <- ptab[item==(sel_par),.SD,.SDcols=intersect(SUMM_KEY,names(ptab))]
lkvals <- ltab[item==(sel_spec),.SD,.SDcols=intersect(SUMM_KEY,names(ltab))]
kvals <- c(as.list(pkvals),as.list(lkvals))
kvals <- kvals[unique(names(kvals))]
- if ('an' %in% names(kvals)) {
+ if ('an' %in% names(kvals) && n_ms2_sel) {
rkvals <- kvals[!(names(kvals) %in% 'an')]
rktab <- tabkey(summ,kvals=rkvals)
tabsel <- summ[rktab,.(an,ms2_sel)]
@@ -432,12 +472,14 @@ update_on_commit_chg <- function(summ,input,ptab,ltab) {
}
- ## TODO: CHECK IF THIS WORKS!!!!! ESPECIALLY THE ABOVE AN TREATMENT.
+
tgts <- c("ms1_rt","ms1_int",names(n_qa),"ms2_sel")
srcs <- c(list(n_ms1_rt,n_ms1_int),as.list(n_qa),as.list(n_ms2_sel))
-
- summ[tabkey(summ,kvals=kvals),(tgts):=..srcs]
+ the_row <- tabkey(summ,kvals=kvals)
+ summ[the_row,(tgts):=..srcs]
+ summ[,an.1:=NULL] #FIXME: an.1 pops up somewhere.
+ qflg <- QA_FLAGS[!(QA_FLAGS %in% "qa_pass")]
+ summ[the_row,qa_pass:=apply(.SD,1,all),.SDcols=qflg]
summ
-
}
diff --git a/R/shiny-ui-base.R b/R/shiny-ui-base.R
index 54c18cd..aae34a6 100644
--- a/R/shiny-ui-base.R
+++ b/R/shiny-ui-base.R
@@ -706,37 +706,20 @@ mk_shinyscreen_server <- function(projects,init) {
run(m=q,phases=c("setup","comptab"))
})
- rf_cindex_key <- reactive({
- if (isTruthy(input$cindex_group)) setdiff(CINDEX_BY,input$cindex_group) else CINDEX_BY
- })
+
## REACTIVE FUNCTIONS: COMPOUND INDEX
rf_get_cindex <- reactive({
+ input$cmt_changes_b
rvs$status$is_qa_stat
- grp <- rf_cindex_key()
s1 <- input$sort1
s2 <- input$sort2
s3 <- input$sort3
s4 <- input$sort4
- sorder <- setdiff(c(s1,s2,s3,s4),input$cindex_group)
- summ <- req(rvs$m$out$tab$summ)
- isolate({
- if (NROW(summ)>0L) {
- gen_cindex(summ,
- sorder=sorder,
- by.=grp)
- } else {
- NULL
- }
- })
- })
+ cindex_from_input(clabs=input$cindex_group,
+ sort_catg=c(s1,s2,s3,s4),
+ summ=req(rvs$m$out$tab$summ))
- rf_get_keyed_cindex <- reactive({
- cind <- req(rf_get_cindex())
- grp <- req(rf_cindex_key())
-
- data.table::setkeyv(cind,grp)
- cind
})
## Get current grouping categories (`cindex key').
@@ -745,9 +728,7 @@ mk_shinyscreen_server <- function(projects,init) {
cind <- rf_get_cindex()
req(NROW(cind)>0L)
- ## Select only valid category names.
- x <- which(CINDEX_BY %in% names(cind))
- CINDEX_BY[x]
+ get_cindex_key(cind)
})
## Get currently selected cindex values as a list.
@@ -756,10 +737,7 @@ mk_shinyscreen_server <- function(projects,init) {
key <- rf_get_cindex_key()
req(NROW(cind)>0L)
row <- req(input$cindex_row_last_clicked)
- rowtab <- cind[row][,..key]
- res <- lapply(rowtab,function (x) x[[1]])
- names(res) <- key
- res
+ get_cindex_kval(cind,row,key)
})
## Get the labels which will define plot curves in EIC MS1.
@@ -774,12 +752,12 @@ mk_shinyscreen_server <- function(projects,init) {
isolate({
ms1 <- rvs$m$extr$ms1
ms2 <- rvs$m$extr$ms2
- summ <- rvs$m$out$tab$summ
+ summ <- req(rvs$m$out$tab$summ)
})
- key <- rf_get_cindex_key()
+ key <- req(rf_get_cindex_key())
kvals <- req(rf_get_cindex_kval())
- labs <- rf_get_cindex_labs()
+ labs <- req(rf_get_cindex_labs())
get_cindex_parents(summ,key,kvals,labs)
})
@@ -790,21 +768,17 @@ mk_shinyscreen_server <- function(projects,init) {
parent <- req(input$sel_parent_trace)
kvals <- req(rf_get_cindex_kval())
ptab <- req(rf_get_cindex_parents())
- select <- ptab[item==(parent)]
- tab <- get_data_from_key(summ,kvals)[select,nomatch=NULL,on=key(ptab)]
- tab
+ get_summ_subset(summ=summ,
+ ptab=ptab,
+ paritem=parent,
+ kvals=kvals)
})
- rf_fill_sel_spec <- reactive({
+ rf_get_ltab <- reactive({
+ input$cmt_changes_b
cols <- c("an","ms2_rt")
tab <- req(rf_select_from_summ())
- if (NROW(tab)==1L && is.na(tab$an)) return(data.table::data.table(item=character()))
- tab[is.na(ms2_sel),ms2_sel:=F] #TODO FIXME: Check why NAs exist at all?
- tab[,passval:=fifelse(qa_pass==T,"OK","BAD")]
- tab[ms2_sel==T,passval:="SELECTED"]
- res <- tab[,item:=do.call(paste,c(.SD,list(sep=";"))),.SDcols=c(cols,"passval")]
- data.table::setkey(res,"ms2_rt")
- res
+ get_ltab(tab)
})
@@ -937,7 +911,7 @@ mk_shinyscreen_server <- function(projects,init) {
} else {
selMS2 <- req(input$sel_spec)
- xx <- rf_fill_sel_spec()
+ xx <- rf_get_ltab()
x1 <- list(rt=xx[item==(selMS2),ms1_rt],
int=xx[item==(selMS2),ms1_int])
x2 <- xx[item==(selMS2),.SD,.SDcols=patterns("qa_ms[12].*")]
@@ -1323,7 +1297,7 @@ mk_shinyscreen_server <- function(projects,init) {
}, label = "measure-props-parent")
observe({
- ctab <- rf_fill_sel_spec()
+ ctab <- rf_get_ltab()
disp <- if (any(ctab$ms2_sel==T)) ctab[ms2_sel==T,item] else ctab[1L,item]
updateSelectInput(session = session,
inputId = "sel_spec",
@@ -1354,6 +1328,14 @@ mk_shinyscreen_server <- function(projects,init) {
})
observeEvent(input$cmt_changes_b,{
+ summ <- req(rvs$m$out$tab$summ)
+
+ ptab <- req(rf_get_cindex_parents())
+ ltab <- req(rf_get_ltab())
+ rvs$m$out$tab$summ <- update_on_commit_chg(summ,
+ input=input,
+ ptab=ptab,
+ ltab=ltab)
})
@@ -1586,7 +1568,7 @@ mk_shinyscreen_server <- function(projects,init) {
output$print_spec_tab <- renderPrint({
notfound <- "No MS2 spectrum has been found for this entry."
- ms2tabsel <- req(rf_fill_sel_spec())
+ ms2tabsel <- req(rf_get_ltab())
selMS2 <- req(input$sel_spec)
if (NROW(ms2tabsel)!=0L) {
lval <- lapply(ms2tabsel[item==(selMS2)],function(x) x)
--
GitLab