#' Now lets create the function to put premade groups into a binary collumns
#' @export
col_binner<-function(dat,cells){
cell.names<-select.list(names(cells),multiple=T)
cells<-cells[cell.names]
for(i in 1:length(cell.names)){
dat$bin[cell.names[i]]<-0
dat$bin[ cells[[i]], cell.names[i] ]<-1
}
return(dat)
}
#' Create Binary Classes of cells
#' dat IS THE rd. INPUT
#' LEVS, IS AN OPTIONAL ARGUEMENT, IF LEFT BLACK THE FUNCTION WILL LOOK IN THE BIN DATA.FRAME COLLUMN ANMES
#' TO ALLOW TO MANUALLY SECT THE COLLUMNS YOU WANT TO COMBINE
#' @export
combinner<-function(dat, levs=NA, bin_it=T){
tmp<-dat$bin
if(is.na(levs)){
levs<-select.list(names(dat$bin), multiple=T)
}
pf <- apply(tmp[,levs], 1, paste, collapse="")
pf.sum <- sort(summary(as.factor(pf), maxsum=1500), TRUE)
# Now name the pf.sum correctly
origNames <- names(pf.sum)
pf.sumNewName <- sapply(names(pf.sum), function(x){
nameLogic <- as.logical(as.numeric(strsplit(x, split="")[[1]]))
x <- paste(levs[nameLogic], collapse = "__")
if(x == ""){x <- "NULL"}
return(x)
})
names(pf.sum) <- pf.sumNewName
# Add it to the bin dataFrame
for(i in 1:length(origNames)){
logic <- pf == origNames[i]
dat$bin[pf.sumNewName[i]] <- 0
dat$bin[names(pf[logic]), pf.sumNewName[i]] <- 1
}
cat(paste(names(pf.sum), ":\n ", pf.sum), sep="\n" )
dev.new(width = 10, height = 8)
par(mar=c(15,4,4,2))
bpDim <- barplot(
pf.sum,
border = NA,
xaxt = "n"
)
par(xpd=T)
text(
bpDim,
par('usr')[1] - xinch(.3),
names(pf.sum),
srt = 60,
adj = 1,
cex = .8
)
text(
bpDim,
pf.sum + yinch(.2),
pf.sum,
srt = 60,
adj = 0,
cex = .8
)
return(dat)
}
#tmpRD <- combinner(RD.200915.153.m.m3.e1.Lung)
#' Create Binary Classes of cells
#' @export
pf.function<-function(dat, levs){
tmp<-dat
pf<-apply(tmp[,levs],1,paste, collapse="")
pf.sum<-summary(as.factor(pf), maxsum=1500)
pf.sum<-pf.sum[order(pf.sum, decreasing=T)]
pf.ord<-pf.sum
pf.ord[]<-seq(1,length(pf.sum))
tmp["pf"]<-as.factor(pf)
tmp["pf.sum"]<-pf.sum[pf]
tmp["pf.ord"]<-pf.ord[pf]
return(tmp)
}
#' @export
bin_to_group<-function(dat){
bin<-dat$bin
cat("
Select the collumns you would like to collect the rows that are scored as 1's.\n")
cols_sel<-select.list(names(dat$bin), multiple=T)
cell_group<-list()
for(i in 1:length(cols_sel)){
cell_group[[ cols_sel[i] ]]<-row.names(which(dat$bin[ cols_sel[i] ]==1,arr.ind=T))
}
return(cell_group)
}
#' This takes a pf and allows you to create a binarry table based on the barcode
#' Created in pf.function
#' @export
pf_summary<-function(dat, response_classes = NULL, pf_col = NULL){
if(is.null(pf_col)){
pf_col <- menu( colnames(dat$scp) )
}else{ pf_col <- pf_col }
if(is.null(response_classes)){
response_classes <- unique(dat$scp[,pf_col])
}else{}
for(i in 1:length(response_classes)){
response.types<-row.names(
which(
dat$scp[pf_col] == as.character(response_classes[i])
, arr.ind=T)
)
dat$bin[ as.character(response_classes[i]) ]<-0
dat$bin[ response.types, as.character(response_classes[i]) ]<-1
}
cat("I Have added new rows to your bin dataframe based off of this \nresponse combination","\n\n")
cat(colnames(dat$scp)[pf_col], sep="\n")
cat(as.character(response_classes), sep='\n')
return(dat)
}
#' Function to select rows based on collumn parameters
#' dat can be either a raw RD object or an RD dataframe
#' ex dat -or- dat$bin
#' @export
cellzand<-function(dat,collumn=NULL, parameter=1,cells=NULL){
bob<-list()
if(is.null(cells)){cells<-dat$c.dat$id}else{cells<-cells}
if(class(dat)=="list"){
dat.select<-select.list(names(dat), title="Select DataFrame")
dat<-dat[[dat.select]]
if(is.null(cells)){cells<-row.names(dat)}else{cells<-cells}
}else{
dat<-dat
if(is.null(cells)){cells<-row.names(dat)}else{cells<-cells}
}
if(is.null(collumn)){
collumn<-select.list(names(dat), multiple=T, title="Select Collumn")
}else(collumn<-collumn)
if(is.null(parameter)){
parameter<-1
}else(parameter<-parameter)
for(i in collumn){
bob[[i]]<-row.names(dat)[dat[,i]>=parameter]
}
bob<-Reduce(union, bob)
#bob<-intersect(bob, cells)
bob<-intersect(bob,cells)
return(bob)
}
#' @export
cellzor<-function(dat,collumn=NULL, parameter=1,cells=NULL){
bob<-list()
if(is.null(cells)){cells<-dat$c.dat$id}else{cells<-cells}
if(class(dat)=="list"){
dat.select<-select.list(names(dat), title="Select DataFrame")
dat<-dat[[dat.select]]
if(is.null(cells)){cells<-row.names(dat)}else{cells<-cells}
}else{
dat<-dat
if(is.null(cells)){cells<-row.names(dat)}else{cells<-cells}
}
if(is.null(collumn)){
collumn<-select.list(names(dat), multiple=T, title="Select Collumn")
}else(collumn<-collumn)
if(is.null(parameter)){
parameter<-1
}else(parameter<-parameter)
for(i in collumn){
bob[[i]]<-row.names(dat)[dat[,i]>=parameter]
}
bob<-Reduce(intersect, bob)
#bob<-intersect(bob, cells)
bob<-intersect(bob,cells)
return(bob)
}
#' given a list of file names collect and merge all bin scp and c.dat data
#' @export
CollectMulti <- function(f.names,rd.names=NULL){
if(is.null(rd.names))
{
rd.names <- sub("\\.rdata$","",sub(".*\\/","",f.names),ignore.case=T)
for(i in f.names){load(i)}
}
b.names <- NULL
s.names <- NULL
cnames <- NULL
for(i in rd.names)
{
tmp <- get(i)
names(tmp$bin) <- make.names(names(tmp$bin))
names(tmp$scp) <- make.names(names(tmp$scp))
names(tmp$c.dat) <- make.names(names(tmp$c.dat))
b.names <- union(b.names,names(tmp$bin))
s.names <- union(s.names,names(tmp$scp))
cnames <- union(cnames,names(tmp$c.dat))
}
cnames <- setdiff(cnames,b.names)
s.names <- setdiff(s.names,b.names)
cnames <- setdiff(cnames,s.names)
tot.names <- c(b.names,s.names,cnames,"rd.name","trace.id")
ret.dat <- data.frame(matrix(rep(1,length(tot.names)),ncol=length(tot.names)))
names(ret.dat) <- tot.names
for(i in rd.names)
{
tmp <- get(i)
names(tmp$bin) <- make.names(names(tmp$bin))
names(tmp$scp) <- make.names(names(tmp$scp))
names(tmp$c.dat) <- make.names(names(tmp$c.dat))
ret.tmp <- data.frame(cbind(tmp$bin,tmp$scp,tmp$c.dat))
ret.tmp["rd.name"] <- i
ret.tmp["trace.id"] <- row.names(tmp$bin)
# ret.dat <- merge(ret.dat,ret.tmp)
i.names <- setdiff(tot.names,names(ret.tmp))
for(j in i.names)
{
ret.tmp[j] <- NA
}
ret.add <- ret.tmp[,tot.names]
ret.dat <- rbind(ret.dat,ret.add)
}
ret.dat <- ret.dat[-1,]
return(ret.dat)
}
#' function to obtained sorted cell names based off
#' collumn names from c.dat and bin
#' @export
c.sort<-function(dat,char=NULL){
char<-select.list(names(dat))
sort.dir<-select.list(c("TRUE", "FALSE"), title="Decreasing?")
bob<-row.names(dat[order(dat[,char], decreasing=sort.dir),])
return(bob)
}
#' Function to smart sort
#' @export
c.sort.2<-function(dat,cells=NULL,collumn=NULL){
if(class(dat)=="list"){
dat.selector<-select.list(intersect(names(dat), c("c.dat","bin", "scp")), title="Select DataFrame")
dat<-dat[[dat.selector]]
}else{dat<-dat}
if(is.null(collumn)){
collumn<-select.list(names(dat), title="Select Variable to Sort")
}else{collumn=collumn}
sort.dir<-select.list(c("TRUE", "FALSE"), title="Decreasing?")
bob<-row.names(dat[order(dat[,collumn], decreasing=sort.dir),])
if(!is.null(cells)){bob<-intersect(bob,cells)}
return(bob)
}
#' function to build a table with defined cell types, and selected collumns
#' @export
TableBrewer<-function(dat, ct.names=NULL, save=T, xlsx=F){
dat.name<-deparse(substitute(dat))
pulse<-select.list(names(dat$bin), multiple=T, title="select variables for table")
ct.sum<-data.frame()
if(is.null(ct.names)){
#F7: Load cell Types into the groups to pick with 'P'
cellTypeId <- grep('^cell([_]|[.])types$', names(dat), value=T)
if(length(cellTypeId)>0){
if(length(cellTypeId)>1){
tryCatch(bringToTop(-1), error=function(e)NULL)
cat('\n Select the cell type to load in \n')
cellTypeId <- select.list(cellTypeId, title="Select Cell Type")
}
}
cell.type.names <- names(dat[[cellTypeId]])
cell.types <- dat[[cellTypeId]]
}else{
cell.type.names <- names(ct.names)
cell.types <- ct.names
}
for(z in 1:length(pulse)){
for(x in 1:length(cell.type.names)){
#first count the number of cells in the cell type group
ct.sum[as.character(dat.name),cell.type.names[x]]<-length(cell.types[[ cell.type.names[x] ]])
#sum the collumn with only the cell.types defined rows based on the current selected collumn
ct.sum[pulse[z],cell.type.names[x]]<-sum(dat$bin[cell.types[[ cell.type.names[x] ]],pulse[z]])
}
}
if(save){
print('Enter you file name without spaces')
save.names <- scan(n=1, what='character')
print(paste(save.names,'xlsx',sep=''))
if(xlsx){
require(xlsx)
tryCatch(
write.xlsx(ct.sum, file=paste(save.names,'.xlsx',sep='')),
error=function(e) print("You Forgot to input cells.")
)
}else{
write.csv(ct.sum, file=paste(save.names,'.csv',sep=''))
}
}
return(ct.sum)
}
#' I have a series of pdf files
#' @export
gif_maker<-function(dense=200, fps=2, file.name=NULL, type='png'){
require(magick)
#select the reader for
if(type=='pdf'){
reader <- get( paste0('image_read_', "pdf") )
}
if(type=='png'){
reader <- get('image_read')
}
#MAKE FILE NAME
if(is.null(file.name)){
cat("\nThis function will create a gif for either png's or pdfs.\nPlease Enter the name of the file you want to create.\nex. pdfs_in_gif.png\n")
file.name<-scan(n=1,what="character")
}
#ASKING AND ANSWERING QUESTIONS
cat("\nLets create a gif with this data, below are all",type,"s in your experiment \n")
cat(list.files(pattern=type),sep="\n")
pdf_imgs<-list.files(pattern=type)
cat("How many images would you like in your gif? \n")
imgs_for_gif<-scan(n=1)
#SELECT EACH PDF FOR
pdfs_for_gif<-c()
for(i in 1:imgs_for_gif){
img_selection<-menu(list.files(pattern=type),title=paste("Select image ",i))
pdfs_for_gif[i]<-pdf_imgs[as.numeric(img_selection)]
cat("These are the selected images \n")
cat(pdfs_for_gif,sep="\n")
}
#BEGIN MAKING PDFs, FIRST HAS RED BORDER
gif<-reader(pdfs_for_gif[1],density=dense)
gif<-image_border(gif,"red","10x10")
for(i in 2:length(pdfs_for_gif)){
gifz<-reader(pdfs_for_gif[i],density=dense)
gifz<-image_border(gifz,"black","10x10")
gif<-c(gif,gifz)
}
animation<-image_animate(gif,fps=fps)
image_write(animation,paste0(file.name,'.gif'))
}
#' I have a series of pdf files
#' @export
gif_png_maker<-function(dense=200,fps=2,file.name=NULL){
require(magick)
if(is.null(file.name)){
cat("Write the name fo the file you would like the ned image to be \n")
file.name<-scan(n=1,what="character")
file.name <- paste0(file.name,'.gif')
}
cat("Lets create a gif with this data, below are all pngs in your experiment \n")
cat(list.files(pattern="[pP][nN][gG]"),sep="\n")
imgs<-list.files(pattern="[pP][nN][gG]")
cat("How many images would you like in your gif? \n")
imgs_to_add <-scan(n=1)
imgs_for_gif<-c()
for(i in 1:imgs_to_add){
img_selection <- menu(list.files(pattern="[pP][nN][gG]"),title=paste("Select image ",i))
imgs_for_gif[i] <- imgs[as.numeric(img_selection)]
cat("These are the selected images \n")
cat(imgs_for_gif,sep="\n")
}
#dense<-200
gif<-image_read(imgs_for_gif[1], density=dense)
gif<-image_border(gif, "red", "10x10")
for(i in 2:length(imgs_for_gif)){
gifz<-image_read(imgs_for_gif[i], density=dense)
gifz<-image_border(gifz,"black","10x10")
gif<-c(gif,gifz)
}
#fps=2
animation<-image_animate(gif,fps=fps)
image_write(animation,file.name)
}
#' Funciton to save the work along with create a unique savehistory
#' This function can now take a tmp.rd tmpRD or tmp as input. From there the
#' function looks for a RD.experiemnt in the global environemnt. If it finds
#' one, it will save the RD.experiment as RD.experiment not tmp
#' If more than one RD.exepriment are in the work space it will stop and not save
#' @export
saveRD <- function(dat){
cat("\nDO NOT CLOSE UNTIL I SAY YOU CAN!\nWait for the sound...")
flush.console()
tryCatch(bringToTop(-1), error=function(e)NULL)
Sys.sleep(1)
#History Saver
experimentorsName <- strsplit(getwd(),'/')[[1]][2]
historyName <- paste(experimentorsName, Sys.time(), 'History.r')
historyName <- gsub(":", '_',historyName)
tryCatch(
savehistory(historyName),
error = function(e) cat("\nUnable to save the History. BUY A PC\n")
)
#Exp Saver
expName <- deparse(substitute(dat))
if(any(expName %in% c("tmp.rd", "tmpRD","tmp"))){
expName <- ls(pattern = "^RD[.]", envir = .GlobalEnv)
if(length(expName) > 1){
stop("There are too many RD.experiments open")
}
}
#expToSave <- get(expName, envir = .GlobalEnv)
assign(expName, dat)
save(list=expName, file=paste0(expName,".Rdata") )
alarm()
cat('\nYou can now close. Please consider cleaning up the file,\n',historyName,'\n')
}
#' @export
census_viewer <- function(dat){
cat(
"This function will essecially return cells from a specified cell\nin the census table
\n1. Select all of cells from a specific cell class.
\n1a. If you click cancel all cells will be returned.
\n2. bin >> collumn >> cell class cells scored as one.
\n3. returns a vector of cell names ex c(X.3, X.30)
"
)
(cell_list_name <- grep("^cell([_]|[.])types$", names(dat), value=T))[1]
(cell_types <- names( dat[[ cell_list_name ]] ))
(cell_type_name <- select.list( cell_types, title="Select the cell_type" ))
#Tool to return all cells if cancel is selected.
if(cell_type_name == ''){
cell_type <- dat$c.dat$id
}else{
(cell_type <-dat[[ cell_list_name ]] [[ cell_type_name ]])
}
(bin_col <- select.list(names(dat$bin), title="Select bin collumn"))
(cells <- cell_type[ dat$bin[cell_type , bin_col] == 1 ])
if( length(cells) == 0 ){
return(NA)
}else{
cells_to_view <- list()
cells_to_view[[ 'name' ]]<- paste0(cell_type_name,"__", bin_col)
cells_to_view[[ 'cells' ]] <- cells
return(cells_to_view)
}
}
#' Function to rename experiment to the name of the folder it
#' resides
#' @export
renamer <- function(){
expName <- rev(strsplit(getwd(), "/")[[1]])[1]
expName <- strsplit(expName, " ")[[1]][1]
expName <- paste0("RD.", expName)
print(ls(pattern = "^RD[.]"))
expToRename <- get(ls(pattern = "^RD[.]", envir=.GlobalEnv))
assign(expName, expToRename)
save(list=expName, file=paste0(expName,".Rdata") )
}
#' Legacy function to convert the census into binary collumns
#' @export
census_to_table<-function(dat){
census.df<-dat$bin
i<-1
while( is.na(dat$census[[i]]) ){
i<-i+1
}
(census.df.cn<-names(dat$census[[i]])[!is.na(names(dat$census[[i]]))])#census data frame column names)
for(i in 1:length(census.df.cn)){
census.df[census.df.cn[i]]<-0
}
for(a in 1:length(dat$census)){
if(!is.na(dat$census[[a]])){
for(b in 1:length(census.df.cn)){
census.df[ dat$census[[a]][[b]],census.df.cn[b]]<-1
}
}
}
#census.df[is.na(census.df)]<-0#convert all NA to 0
dat$bin<-census.df
return(dat)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.