Skip to content
Snippets Groups Projects
Commit eaa49e9c authored by Todor Kondic's avatar Todor Kondic
Browse files

shiny-state,shiny-ui-base: Fixed summ modification.

parent b8c24585
No related branches found
Tags v1.2.0
No related merge requests found
Hide whitespace changes
Inline Side-by-side
R/resources.R
+ 1
− 1
View file @ eaa49e9c
......@@ -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")
......
R/shiny-state.R
+ 51
− 9
View file @ eaa49e9c
......@@ -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
}
R/shiny-ui-base.R
+ 28
− 46
View file @ eaa49e9c
......@@ -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)
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment