Nothing
R/qaReport.R
In QUALIFIER: Quality Control of Gated Flow Cytometry Experiments
Defines functions
qaWrite.list
qaWrite.summary
qaWrite.task
.writeHead
#'create quality assessment report
#'
#'create quality assessment report in HTML format, which contains the annotated
#'svg summary plot for each QA task.
#'
#'QA results need to be calculated by calling \code{\link{qaCheck}} method
#'before using this function to generate meaningful report. It also reads the
#'meta information of each QA task and generate the summary tables and svg
#'plots. Svg plots provide tooltips containing the detail information about
#'each sample and hyperlinks of densityplot for each individual FCS file.
#'
#'@name qaReport
#'@aliases qaReport qaReport-methods qaReport,qaTask-method
#'qaReport,list-method
#'@docType methods
#'@param obj A \code{qaTask} or a list of \code{qaTask} objects
#'@param outDir A character scalar giving the output path of QA report.
#'
#'@param plotAll A logical scalar passed down to the
#'\code{\link[QUALIFIER:plot]{plot}} method.
#'
#'@param gsid an \code{integer} that uniquely identifies a gating set object.
#'if missing, the latest added gating set is selected.
#'
#'@param subset A logical expression as a filter that is passed to
#'\code{\link{plot}}. see \code{\link{qaCheck}} for more details.
#'
#' @param ... other arguments:
#'
#'splash: A logical scalar indicating whether the QUALIFIER package splash tag
#''generated by \dots{}' should be written right after the report title.
#'
#'title: A character scalar indicating the title of the report
#'
#'subTitle: A character scalar indicating the subtitle of the report
#'
#'@author Mike Jiang,Greg Finak
#'
#'Maintainer: Mike Jiang <wjiang2@@fhcrc.org>
#'@seealso \code{\link{qaCheck}},\code{\link[QUALIFIER:plot]{plot}}
#'@keywords methods
#'@examples
#'
#'\dontrun{
#'data("ITNQASTUDY")#load stats from disk
#'checkListFile<-file.path(system.file("data",package="QUALIFIER"),"qaCheckList.csv.gz")
#'qaTask.list<-read.qaTask(db,checkListFile)
#'qaReport(qaTask.list[[1]],outDir="~/output")
#'qaReport(qaTask.list[2:3],outDir="~/output")
#'}
#'
#' @export
setMethod("qaReport", signature=c(obj="list"),
function(obj,outDir,plotAll=FALSE,gsid=NULL,subset,...){
if(missing(outDir))
stop("outDir has to be specified!")
p<-.writeHead(outDir,...)
if(missing(subset))
qaWrite.list(x=obj,page=p,outDir=outDir,plotAll=plotAll,gsid=gsid)
else
qaWrite.list(x=obj,page=p,outDir=outDir,plotAll=plotAll,gsid=gsid,Subset=substitute(subset))
})
##generate report for single qaTask
setMethod("qaReport", signature=c(obj="qaTask"),
function(obj,...){
# browser()
taskList <- list(obj)
names(taskList) <- as.vector(QUALIFIER:::getName(obj))
qaReport(taskList, ...)
})
qaWrite.list<-function(x,page,...){
db<-getData(x[[1]])
db$objcount<-0
qaWrite.summary(x,page,...)
tasksBylevel<-split(x,unlist(lapply(x,qaLevel)))
lapply(tasksBylevel,function(curTaskGroup){
#
hwrite(paste(qaLevel(curTaskGroup[[1]]),"Level"),page,heading=1)
# browser()
lapply(curTaskGroup,qaWrite.task,page,...)
})
message("report generated!")
closePage(page, splash=FALSE)
}
# @importFrom reshape cast melt
qaWrite.summary <- function(x,p,gsid=NULL,...){
# browser()
idColName <- qa.par.get("idCol")
hwrite("Summary",p,heading=1)
taskTbl<-do.call(rbind,lapply(names(x),function(y)data.frame(qaTask=y,qaID=qaID(x[[y]]))))
db<-getData(x[[1]])
if(is.null(gsid))
gsid<-max(db$gstbl$gsid)
curGS<-db$gs[[gsid]]
anno<-pData(curGS)
# db$outlierResult
m.outResult <- merge(db$outlierResult,db$stats,by = "sid")
m.outResult <- merge(m.outResult,taskTbl,by="qaID")
m.outResult <- merge(m.outResult,anno[,c(idColName,"name")],by = idColName)
if(nrow(m.outResult) > 0){
castResult <- cast(m.outResult, formula = name~qaTask)
castResult<-as.data.frame(castResult)
castResult$subTotal<-rowSums(castResult[,-1,drop=FALSE])
castResult<-castResult[order(castResult$subTotal,decreasing=T),]
castResult$name<-as.character(castResult$name)
castResult<-rbind(castResult,c(name="Total",colSums(castResult[,-1])))
rownames(castResult)<-NULL#1:nrow(castResult)
hwrite(
paste(hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
hwrite(castResult#output table
,row.class="firstline"
,col.class=list("name"="firstcolumn",'subTotal'="lastcolumn")
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
,p
# ,div=TRUE
# ,style="display: none;"
# ,id=paste("section",db$objcount,sep="_")
)
}
#
}
#TODO:multi-gs is not fully supported in qaReport yet
#' @importFrom hwriter closePage hwrite openPage
qaWrite.task<-function(x,p,outDir,plotAll,gsid,Subset=NULL){
# browser()
idColName <- qa.par.get("idCol")
imageDir<-file.path(outDir,"image")
db<-getData(x)
if(is.null(gsid))
gsid<-max(db$gstbl$gsid)
curGS<-db$gs[[gsid]]
anno<-pData(curGS)
curQaID<-qaID(x)
# browser()
outResult <- base::subset(db$outlierResult,qaID==curQaID)
outResult <- merge(outResult, db$stats[,c("sid",idColName,"channel"), with = FALSE], by = "sid")
outResult <- merge(outResult,anno, by = idColName)
outResult <- rename(outResult, c("name" = "fcsFile"))
if(nrow(outResult) > 0)
outResult$qaTask <- getName(x)
gOutResult <- base::subset(db$GroupOutlierResult,qaID==curQaID)
gOutResult <- merge(gOutResult,db$stats, by = "sid")
gOutResult <- merge(gOutResult,anno, by = idColName)
nFscFailed <- length(unique(outResult$fcsFile))
if(nrow(gOutResult) > 0)
gOutResult$qaTask <- getName(x)
hwrite(paste(description(x)
# ,hwrite(nrow(outResult),class='count')
)
,p
,heading=3)
# browser()
# nFscFailed<-length(unique(outResult$fcsFile))
nGroupFailed<-0
formula1<-getFormula(x)
formuRes<-flowWorkspace:::.formulaParser(formula1)
xTerm<-formuRes$xTerm
statsType<-matchStatType(db,formuRes)
groupField<-NULL
if(plotType(x)=="bwplot")
{
if(qpar(x)$horiz)
groupField<-as.character(formuRes$yTerm)
else
groupField<-as.character(formuRes$xTerm)
nGroupFailed<-length(unique(
eval(substitute(gOutResult$v
,list(v=groupField)
)
)
)
)
}
# browser()
if(nFscFailed>0||nGroupFailed>0||htmlReport(x))
{
db$objcount<-db$objcount+1
hwrite(paste(
hwrite("+",div=TRUE
,id=paste("detTriggerIn",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: block;")
,hwrite("–",div=TRUE
,id=paste("detTriggerOut",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: none;")
,ifelse(nFscFailed>0
,paste(
hwrite(nFscFailed,class='count')
," FCS files "
)
,"")
,ifelse(nGroupFailed>0
,paste(
hwrite(nGroupFailed,class='count')
,groupField
)
,"")
," failed the check"
)
,heading=4
,p
)
#the conditioning section may contain multiple variables
#the first one is only used for grouped outlier detection
#here is used to plot a subgroup
#the second conditioning variable is used for the plot
# browser()
if(length(formuRes$groupBy)>1)
{
##individual outlier
groupBy<-as.character(formuRes$groupBy[1])
groupByStr<-paste("outResult$",groupBy,sep="")
formula1[[3]][[3]]<-as.symbol(paste(formuRes$groupBy[-1],collapse="*"))
if(nFscFailed>0)
{
if(getName(x)=="spike")
{
f1<-as.formula(paste("fcsFile","channel",sep="~"))
}else
{
f1<-as.formula(paste("fcsFile",groupBy,sep="~"))
}
m.outResult<-melt(outResult,measure.vars="qaTask")
castResult<-cast(m.outResult,f1
,fun.aggregate=length)
castResult<-as.data.frame(castResult)
# browser()
castResult$subTotal<-rowSums(castResult[,-1,drop=FALSE])
castResult<-castResult[order(castResult$subTotal,decreasing=T),]
castResult$fcsFile<-as.character(castResult$fcsFile)
castResult<-rbind(castResult,c(fcsFile="Total",colSums(castResult[,-1])))
rownames(castResult)<-NULL#1:nrow(castResult)
hwrite(
paste(hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
hwrite(castResult#output table
,row.class="firstline"
,col.class=list("fcsFile"="firstcolumn",'subTotal'="lastcolumn")
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
# browser()
}
##group outlier
if(nGroupFailed>0)
{
if(getName(x)=="spike")
{
f1<-paste(groupField,"channel",sep="~")
}else
{
f1<-paste(groupField,groupBy,sep="~")
}
f1<-as.formula(f1)
m.outResult<-melt(gOutResult,measure.vars="qaTask")
castResult<-cast(m.outResult,f1
,fun.aggregate=length)
castResult<-as.data.frame(castResult)
castResult$subTotal<-rowSums(castResult[,-1,drop=FALSE])
castResult<-castResult[order(castResult$subTotal,decreasing=T),]
eval(substitute(
castResult$v<-as.character(castResult$v)
,list(v=groupField)
)
)
castResult<-rbind(castResult,c("Total",colSums(castResult[,-1])))
rownames(castResult)<-NULL#1:nrow(castResult)
hwrite(
paste(hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
hwrite(castResult
,row.class="firstline"
,col.class=eval(parse(text=paste("list('"
,groupField
,"'='firstcolumn','subTotal'='lastcolumn')"
,sep="")
)
)
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
}
yy<-.queryStats(db,statsType=statsType,pop=getPop(x)
,gsid=gsid, type = x@type)
factors<-lapply(groupBy,function(x){
eval(substitute(yy$v,list(v=x)))
})
# browser()
by(yy,factors,function(sub2,x,groupBy,Subset){
# browser()
#find the outliers of the current pannael
#matching sid
curOut<-outResult[outResult$sid%in%sub2$sid,]
curgOut<-gOutResult[gOutResult$sid%in%sub2$sid,]
curGroup<-unique(eval(parse(text=paste("sub2$",groupBy,sep=""))))
#
db<-getData(x)
db$objcount<-db$objcount+1
# browser()
##heading
hwrite(paste(
hwrite("+",div=TRUE
,id=paste("detTriggerIn",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: block;")
,hwrite("–",div=TRUE
,id=paste("detTriggerOut",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: none;")
,curGroup
# ,hwrite(length(unique(sub2$name)),class='count')
,ifelse(nrow(curOut)>0
,paste(
hwrite(length(unique(curOut[,idColName])),class='count')
," FCS files "
)
,"")
,ifelse(nrow(curgOut)>0
,paste(
hwrite(length(unique(eval(substitute(curgOut$v
,list(v=groupField)
))
))
,class='count')
,groupField
)
,"")
)
,heading=4
,p
)
# ##table+image
#
# browser()
plotCallStr<-quote(plot(x
,formula1
,dest=imageDir
,plotAll=plotAll
,subset=groupBy==curGroup
)
)
plotCallStr$subset[[2]]<-as.symbol(eval(plotCallStr$subset[[2]]))
plotCallStr$subset[[3]]<-as.character(eval(plotCallStr$subset[[3]]))
# browser()
if(!is.null(Subset))
plotCallStr$subset<-as.call(list(as.symbol("&"),plotCallStr$subset,Subset))
imageName<-eval(plotCallStr)
# imageName<-eval(parse(text=plotCallStr))
rownames(curOut)<-NULL#1:nrow(sub2)
rownames(curgOut)<-NULL#1:nrow(sub2)
#section
hwrite(paste(
##tables+toggler
paste( #toggler
hwrite("hide/show table"
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
#encapsulate tables into div in order to have an id
,hwrite(
paste(
ifelse(nrow(curOut)>0
,hwrite(curOut[,c("fcsFile","channel")]
,row.class="firstline"
,col.class=list("fcsFile"="firstcolumn",'subTotal'="lastcolumn")
)
,"")
,ifelse(nrow(curgOut)>0
,hwrite(unique(curgOut[,c(groupField,"channel")])
,row.class="firstline"
,col.class=eval(parse(text=paste("list('"
,groupField
,"'='firstcolumn','subTotal'='lastcolumn')"
,sep="")
)
)
)
,"")
,sep=""
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
##image
,hwrite(paste("<embed src='"
,file.path(basename(imageDir),imageName)
,"' type='image/svg+xml' width=1000 height=800/>"
,sep=""
)
,div=TRUE
)
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
}
,x
,groupBy
,Subset
)
}else
{
#if only one conditioning variable
#simply order by it and output the fcsfile list
if(length(formuRes$groupBy) == 0)
{
castResult<-eval(substitute(unique(u[,c(w),drop=FALSE])
,list(u=as.symbol("outResult"),w="fcsFile")
)
)
gcastResult<-eval(substitute(unique(u[,c(w),drop=FALSE])
,list(u=as.symbol("gOutResult"),w=groupField)
)
)
}else
{
groupBy <- formuRes$groupBy
castResult <- eval(substitute(u[order(u$v),c(w,v)]
,list(u=as.symbol("outResult"),v=groupBy,w="fcsFile")
)
)
gcastResult <- eval(substitute(u[order(u$v),c(w,v)]
,list(u=as.symbol("gOutResult"),v=groupBy,w=groupField)
)
)
}
# browser()
##make sure the w and h pass to plot and large enough to display strip text
thisCall<- quote(
plot(x
,y = getFormula(x)
,plotAll = plotAll
,dest = imageDir
,width = 27, height = 13
)
)
if(!is.null(Subset))
thisCall$subset<-Subset
imageName<-eval(thisCall)
rownames(castResult)<-NULL#1:nrow(castResult)
#section
hwrite(paste(
paste(
hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
paste(
ifelse(nrow(outResult)>0
,hwrite(castResult
,row.class="firstline"
,col.class=list("fcsFile"="firstcolumn",'subTotal'="lastcolumn")
)
,"")
,ifelse(nrow(gOutResult)>0
,hwrite(gcastResult
,row.class="firstline"
,col.class=eval(parse(text=paste("list('"
,groupField
,"'='firstcolumn','subTotal'='lastcolumn')"
,sep="")
)
)
)
,"")
,sep=""
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
##table
##image
,hwrite(paste("<embed src='"
,file.path(basename(imageDir),imageName) ,"' type='image/svg+xml' width=1000 height=800/>"
,sep=""
)
,div=TRUE
)
,sep=""
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
}
}
}
.writeHead<-function(outDir,title="Flow Data Quality Accessment Report",subTitle="",splash=TRUE)
{
options(warn=0)
imageDir<-file.path(outDir,"image")
#init the image folder
dir.create(imageDir,recursive=TRUE,showWarnings=F)
# file.remove(list.files(imageDir,full=TRUE))
from<-list.files(system.file("htmlTemplates",package="QUALIFIER"),pattern="qaReport",full.names=TRUE)
file.copy(from=from,to=imageDir)
p <- openPage(dirname=outDir
,filename="index.html"
,link.css=file.path(basename(imageDir),"qaReport.css")
,link.javascript=file.path(basename(imageDir),"qaReport.js")
,title = "qa report"
)
# browser()
hwrite(title,p,class="ReportTitle",div=TRUE,br=TRUE)
hwrite(subTitle,p,class="ReportSubTitle",div=TRUE,br=TRUE)
if(splash)
hwrite(paste("Generated on"
,date()
, "by QUALIFIER 0.99.1"
)
,div=TRUE
,class="splash"
,p
)
p
}
Try the QUALIFIER package in your browser
Any scripts or data that you put into this service are public.
QUALIFIER documentation built on Oct. 31, 2019, 3:24 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions qaWrite.list qaWrite.summary qaWrite.task .writeHead
#'create quality assessment report
#'
#'create quality assessment report in HTML format, which contains the annotated
#'svg summary plot for each QA task.
#'
#'QA results need to be calculated by calling \code{\link{qaCheck}} method
#'before using this function to generate meaningful report. It also reads the
#'meta information of each QA task and generate the summary tables and svg
#'plots. Svg plots provide tooltips containing the detail information about
#'each sample and hyperlinks of densityplot for each individual FCS file.
#'
#'@name qaReport
#'@aliases qaReport qaReport-methods qaReport,qaTask-method
#'qaReport,list-method
#'@docType methods
#'@param obj A \code{qaTask} or a list of \code{qaTask} objects
#'@param outDir A character scalar giving the output path of QA report.
#'
#'@param plotAll A logical scalar passed down to the
#'\code{\link[QUALIFIER:plot]{plot}} method.
#'
#'@param gsid an \code{integer} that uniquely identifies a gating set object.
#'if missing, the latest added gating set is selected.
#'
#'@param subset A logical expression as a filter that is passed to
#'\code{\link{plot}}. see \code{\link{qaCheck}} for more details.
#'
#' @param ... other arguments:
#'
#'splash: A logical scalar indicating whether the QUALIFIER package splash tag
#''generated by \dots{}' should be written right after the report title.
#'
#'title: A character scalar indicating the title of the report
#'
#'subTitle: A character scalar indicating the subtitle of the report
#'
#'@author Mike Jiang,Greg Finak
#'
#'Maintainer: Mike Jiang <wjiang2@@fhcrc.org>
#'@seealso \code{\link{qaCheck}},\code{\link[QUALIFIER:plot]{plot}}
#'@keywords methods
#'@examples
#'
#'\dontrun{
#'data("ITNQASTUDY")#load stats from disk
#'checkListFile<-file.path(system.file("data",package="QUALIFIER"),"qaCheckList.csv.gz")
#'qaTask.list<-read.qaTask(db,checkListFile)
#'qaReport(qaTask.list[[1]],outDir="~/output")
#'qaReport(qaTask.list[2:3],outDir="~/output")
#'}
#'
#' @export
setMethod("qaReport", signature=c(obj="list"),
function(obj,outDir,plotAll=FALSE,gsid=NULL,subset,...){
if(missing(outDir))
stop("outDir has to be specified!")
p<-.writeHead(outDir,...)
if(missing(subset))
qaWrite.list(x=obj,page=p,outDir=outDir,plotAll=plotAll,gsid=gsid)
else
qaWrite.list(x=obj,page=p,outDir=outDir,plotAll=plotAll,gsid=gsid,Subset=substitute(subset))
})
##generate report for single qaTask
setMethod("qaReport", signature=c(obj="qaTask"),
function(obj,...){
# browser()
taskList <- list(obj)
names(taskList) <- as.vector(QUALIFIER:::getName(obj))
qaReport(taskList, ...)
})
qaWrite.list<-function(x,page,...){
db<-getData(x[[1]])
db$objcount<-0
qaWrite.summary(x,page,...)
tasksBylevel<-split(x,unlist(lapply(x,qaLevel)))
lapply(tasksBylevel,function(curTaskGroup){
#
hwrite(paste(qaLevel(curTaskGroup[[1]]),"Level"),page,heading=1)
# browser()
lapply(curTaskGroup,qaWrite.task,page,...)
})
message("report generated!")
closePage(page, splash=FALSE)
}
# @importFrom reshape cast melt
qaWrite.summary <- function(x,p,gsid=NULL,...){
# browser()
idColName <- qa.par.get("idCol")
hwrite("Summary",p,heading=1)
taskTbl<-do.call(rbind,lapply(names(x),function(y)data.frame(qaTask=y,qaID=qaID(x[[y]]))))
db<-getData(x[[1]])
if(is.null(gsid))
gsid<-max(db$gstbl$gsid)
curGS<-db$gs[[gsid]]
anno<-pData(curGS)
# db$outlierResult
m.outResult <- merge(db$outlierResult,db$stats,by = "sid")
m.outResult <- merge(m.outResult,taskTbl,by="qaID")
m.outResult <- merge(m.outResult,anno[,c(idColName,"name")],by = idColName)
if(nrow(m.outResult) > 0){
castResult <- cast(m.outResult, formula = name~qaTask)
castResult<-as.data.frame(castResult)
castResult$subTotal<-rowSums(castResult[,-1,drop=FALSE])
castResult<-castResult[order(castResult$subTotal,decreasing=T),]
castResult$name<-as.character(castResult$name)
castResult<-rbind(castResult,c(name="Total",colSums(castResult[,-1])))
rownames(castResult)<-NULL#1:nrow(castResult)
hwrite(
paste(hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
hwrite(castResult#output table
,row.class="firstline"
,col.class=list("name"="firstcolumn",'subTotal'="lastcolumn")
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
,p
# ,div=TRUE
# ,style="display: none;"
# ,id=paste("section",db$objcount,sep="_")
)
}
#
}
#TODO:multi-gs is not fully supported in qaReport yet
#' @importFrom hwriter closePage hwrite openPage
qaWrite.task<-function(x,p,outDir,plotAll,gsid,Subset=NULL){
# browser()
idColName <- qa.par.get("idCol")
imageDir<-file.path(outDir,"image")
db<-getData(x)
if(is.null(gsid))
gsid<-max(db$gstbl$gsid)
curGS<-db$gs[[gsid]]
anno<-pData(curGS)
curQaID<-qaID(x)
# browser()
outResult <- base::subset(db$outlierResult,qaID==curQaID)
outResult <- merge(outResult, db$stats[,c("sid",idColName,"channel"), with = FALSE], by = "sid")
outResult <- merge(outResult,anno, by = idColName)
outResult <- rename(outResult, c("name" = "fcsFile"))
if(nrow(outResult) > 0)
outResult$qaTask <- getName(x)
gOutResult <- base::subset(db$GroupOutlierResult,qaID==curQaID)
gOutResult <- merge(gOutResult,db$stats, by = "sid")
gOutResult <- merge(gOutResult,anno, by = idColName)
nFscFailed <- length(unique(outResult$fcsFile))
if(nrow(gOutResult) > 0)
gOutResult$qaTask <- getName(x)
hwrite(paste(description(x)
# ,hwrite(nrow(outResult),class='count')
)
,p
,heading=3)
# browser()
# nFscFailed<-length(unique(outResult$fcsFile))
nGroupFailed<-0
formula1<-getFormula(x)
formuRes<-flowWorkspace:::.formulaParser(formula1)
xTerm<-formuRes$xTerm
statsType<-matchStatType(db,formuRes)
groupField<-NULL
if(plotType(x)=="bwplot")
{
if(qpar(x)$horiz)
groupField<-as.character(formuRes$yTerm)
else
groupField<-as.character(formuRes$xTerm)
nGroupFailed<-length(unique(
eval(substitute(gOutResult$v
,list(v=groupField)
)
)
)
)
}
# browser()
if(nFscFailed>0||nGroupFailed>0||htmlReport(x))
{
db$objcount<-db$objcount+1
hwrite(paste(
hwrite("+",div=TRUE
,id=paste("detTriggerIn",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: block;")
,hwrite("–",div=TRUE
,id=paste("detTriggerOut",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: none;")
,ifelse(nFscFailed>0
,paste(
hwrite(nFscFailed,class='count')
," FCS files "
)
,"")
,ifelse(nGroupFailed>0
,paste(
hwrite(nGroupFailed,class='count')
,groupField
)
,"")
," failed the check"
)
,heading=4
,p
)
#the conditioning section may contain multiple variables
#the first one is only used for grouped outlier detection
#here is used to plot a subgroup
#the second conditioning variable is used for the plot
# browser()
if(length(formuRes$groupBy)>1)
{
##individual outlier
groupBy<-as.character(formuRes$groupBy[1])
groupByStr<-paste("outResult$",groupBy,sep="")
formula1[[3]][[3]]<-as.symbol(paste(formuRes$groupBy[-1],collapse="*"))
if(nFscFailed>0)
{
if(getName(x)=="spike")
{
f1<-as.formula(paste("fcsFile","channel",sep="~"))
}else
{
f1<-as.formula(paste("fcsFile",groupBy,sep="~"))
}
m.outResult<-melt(outResult,measure.vars="qaTask")
castResult<-cast(m.outResult,f1
,fun.aggregate=length)
castResult<-as.data.frame(castResult)
# browser()
castResult$subTotal<-rowSums(castResult[,-1,drop=FALSE])
castResult<-castResult[order(castResult$subTotal,decreasing=T),]
castResult$fcsFile<-as.character(castResult$fcsFile)
castResult<-rbind(castResult,c(fcsFile="Total",colSums(castResult[,-1])))
rownames(castResult)<-NULL#1:nrow(castResult)
hwrite(
paste(hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
hwrite(castResult#output table
,row.class="firstline"
,col.class=list("fcsFile"="firstcolumn",'subTotal'="lastcolumn")
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
# browser()
}
##group outlier
if(nGroupFailed>0)
{
if(getName(x)=="spike")
{
f1<-paste(groupField,"channel",sep="~")
}else
{
f1<-paste(groupField,groupBy,sep="~")
}
f1<-as.formula(f1)
m.outResult<-melt(gOutResult,measure.vars="qaTask")
castResult<-cast(m.outResult,f1
,fun.aggregate=length)
castResult<-as.data.frame(castResult)
castResult$subTotal<-rowSums(castResult[,-1,drop=FALSE])
castResult<-castResult[order(castResult$subTotal,decreasing=T),]
eval(substitute(
castResult$v<-as.character(castResult$v)
,list(v=groupField)
)
)
castResult<-rbind(castResult,c("Total",colSums(castResult[,-1])))
rownames(castResult)<-NULL#1:nrow(castResult)
hwrite(
paste(hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
hwrite(castResult
,row.class="firstline"
,col.class=eval(parse(text=paste("list('"
,groupField
,"'='firstcolumn','subTotal'='lastcolumn')"
,sep="")
)
)
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
}
yy<-.queryStats(db,statsType=statsType,pop=getPop(x)
,gsid=gsid, type = x@type)
factors<-lapply(groupBy,function(x){
eval(substitute(yy$v,list(v=x)))
})
# browser()
by(yy,factors,function(sub2,x,groupBy,Subset){
# browser()
#find the outliers of the current pannael
#matching sid
curOut<-outResult[outResult$sid%in%sub2$sid,]
curgOut<-gOutResult[gOutResult$sid%in%sub2$sid,]
curGroup<-unique(eval(parse(text=paste("sub2$",groupBy,sep=""))))
#
db<-getData(x)
db$objcount<-db$objcount+1
# browser()
##heading
hwrite(paste(
hwrite("+",div=TRUE
,id=paste("detTriggerIn",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: block;")
,hwrite("–",div=TRUE
,id=paste("detTriggerOut",db$objcount,sep="_")
,class="QADetTrigger"
,onclick=paste("toggleSection(",db$objcount,")",sep="")
,style="display: none;")
,curGroup
# ,hwrite(length(unique(sub2$name)),class='count')
,ifelse(nrow(curOut)>0
,paste(
hwrite(length(unique(curOut[,idColName])),class='count')
," FCS files "
)
,"")
,ifelse(nrow(curgOut)>0
,paste(
hwrite(length(unique(eval(substitute(curgOut$v
,list(v=groupField)
))
))
,class='count')
,groupField
)
,"")
)
,heading=4
,p
)
# ##table+image
#
# browser()
plotCallStr<-quote(plot(x
,formula1
,dest=imageDir
,plotAll=plotAll
,subset=groupBy==curGroup
)
)
plotCallStr$subset[[2]]<-as.symbol(eval(plotCallStr$subset[[2]]))
plotCallStr$subset[[3]]<-as.character(eval(plotCallStr$subset[[3]]))
# browser()
if(!is.null(Subset))
plotCallStr$subset<-as.call(list(as.symbol("&"),plotCallStr$subset,Subset))
imageName<-eval(plotCallStr)
# imageName<-eval(parse(text=plotCallStr))
rownames(curOut)<-NULL#1:nrow(sub2)
rownames(curgOut)<-NULL#1:nrow(sub2)
#section
hwrite(paste(
##tables+toggler
paste( #toggler
hwrite("hide/show table"
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
#encapsulate tables into div in order to have an id
,hwrite(
paste(
ifelse(nrow(curOut)>0
,hwrite(curOut[,c("fcsFile","channel")]
,row.class="firstline"
,col.class=list("fcsFile"="firstcolumn",'subTotal'="lastcolumn")
)
,"")
,ifelse(nrow(curgOut)>0
,hwrite(unique(curgOut[,c(groupField,"channel")])
,row.class="firstline"
,col.class=eval(parse(text=paste("list('"
,groupField
,"'='firstcolumn','subTotal'='lastcolumn')"
,sep="")
)
)
)
,"")
,sep=""
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
##image
,hwrite(paste("<embed src='"
,file.path(basename(imageDir),imageName)
,"' type='image/svg+xml' width=1000 height=800/>"
,sep=""
)
,div=TRUE
)
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
}
,x
,groupBy
,Subset
)
}else
{
#if only one conditioning variable
#simply order by it and output the fcsfile list
if(length(formuRes$groupBy) == 0)
{
castResult<-eval(substitute(unique(u[,c(w),drop=FALSE])
,list(u=as.symbol("outResult"),w="fcsFile")
)
)
gcastResult<-eval(substitute(unique(u[,c(w),drop=FALSE])
,list(u=as.symbol("gOutResult"),w=groupField)
)
)
}else
{
groupBy <- formuRes$groupBy
castResult <- eval(substitute(u[order(u$v),c(w,v)]
,list(u=as.symbol("outResult"),v=groupBy,w="fcsFile")
)
)
gcastResult <- eval(substitute(u[order(u$v),c(w,v)]
,list(u=as.symbol("gOutResult"),v=groupBy,w=groupField)
)
)
}
# browser()
##make sure the w and h pass to plot and large enough to display strip text
thisCall<- quote(
plot(x
,y = getFormula(x)
,plotAll = plotAll
,dest = imageDir
,width = 27, height = 13
)
)
if(!is.null(Subset))
thisCall$subset<-Subset
imageName<-eval(thisCall)
rownames(castResult)<-NULL#1:nrow(castResult)
#section
hwrite(paste(
paste(
hwrite("hide/show table"#add toggle word
,onclick=paste("toggleTable(",db$objcount,")",sep="")
,link="#"
,class="showtable"
)
,hwrite(#encapsulate into div in order to have an id
paste(
ifelse(nrow(outResult)>0
,hwrite(castResult
,row.class="firstline"
,col.class=list("fcsFile"="firstcolumn",'subTotal'="lastcolumn")
)
,"")
,ifelse(nrow(gOutResult)>0
,hwrite(gcastResult
,row.class="firstline"
,col.class=eval(parse(text=paste("list('"
,groupField
,"'='firstcolumn','subTotal'='lastcolumn')"
,sep="")
)
)
)
,"")
,sep=""
)
,div=TRUE
,style="display: none;"
,id=paste("table",db$objcount,sep="_")
)
,sep=""
)
##table
##image
,hwrite(paste("<embed src='"
,file.path(basename(imageDir),imageName) ,"' type='image/svg+xml' width=1000 height=800/>"
,sep=""
)
,div=TRUE
)
,sep=""
)
,p
,div=TRUE
,style="display: none;"
,id=paste("section",db$objcount,sep="_")
)
}
}
}
.writeHead<-function(outDir,title="Flow Data Quality Accessment Report",subTitle="",splash=TRUE)
{
options(warn=0)
imageDir<-file.path(outDir,"image")
#init the image folder
dir.create(imageDir,recursive=TRUE,showWarnings=F)
# file.remove(list.files(imageDir,full=TRUE))
from<-list.files(system.file("htmlTemplates",package="QUALIFIER"),pattern="qaReport",full.names=TRUE)
file.copy(from=from,to=imageDir)
p <- openPage(dirname=outDir
,filename="index.html"
,link.css=file.path(basename(imageDir),"qaReport.css")
,link.javascript=file.path(basename(imageDir),"qaReport.js")
,title = "qa report"
)
# browser()
hwrite(title,p,class="ReportTitle",div=TRUE,br=TRUE)
hwrite(subTitle,p,class="ReportSubTitle",div=TRUE,br=TRUE)
if(splash)
hwrite(paste("Generated on"
,date()
, "by QUALIFIER 0.99.1"
)
,div=TRUE
,class="splash"
,p
)
p
}
Try the QUALIFIER package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.