Newer
Older
gen_mz_err_f <- function(entry,msg) {
eppm <- grab_unit(entry,"ppm")
eda <- grab_unit(entry,"Da")
shinyscreen:::assert(xor(is.na(eda), is.na(eppm)), msg = msg)
if (is.na(eda)) function(mz) eppm*1e-6*mz else function (mz) eda
}
gen_rt_err <- function(entry,msg) {
em <- grab_unit(entry,"min")
es <- grab_unit(entry,"s")
shinyscreen:::assert(xor(is.na(em), is.na(es)), msg = msg)
if (is.na(em)) es/60. else em
}
fig_path <- function(top,set,group,id,suff,ext="pdf") {
base <- paste("plot",set,group,id,suff,sep="_")
fn <- paste0(base,".",ext)
fn <- gsub("\\[","",fn)
fn <- gsub("\\]","",fn)
fn <- gsub("\\+","p",fn)
fn <- gsub("-","m",fn)
if (!is.null(top)) file.path(top,fn) else fn
}
get_coord_lim <- function(new,def) {
if (is.null(new)) return(def)
res <- new
if (length(new[[1]])==0) res[[1]]<-def[[1]]
if (length(new[[2]])==0) res[[2]]<-def[[2]]
res
}
gen_base_ms1_plot_tab <- function(summ,ms1_spec) {
ident <- c("set",
"adduct",
"tag",
"ID",
"mz",
res <- summ[ms1_spec,c(.SD,
list(rt_peak=i.ms1_rt,
eicMS1=lapply(i.eicMS1,list))),
.SDcols=ident,
on=BASE_KEY,
nomatch=NULL]
setkeyv(res,cols=BASE_KEY)
res
}
gen_base_ms2_plot_tab <- function(summ,ms2_spec) {
ident <- c("set",
"adduct",
"tag",
"ID",
"mz",
res <- summ[ms2_spec,c(.SD,
list(CE=i.CE,
rt_peak = i.rt,
int_peak = ms2_max_int,
spec = i.spec,
ms2_sel = i.ms2_sel)),
.SDcols=ident,
on=BASE_KEY,
nomatch=NULL]
setkeyv(res,cols=BASE_KEY)
res
}
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
## Format the y labels.
sci10 <- function(x) {
prefmt <- formatC(x,format="e",digits=2)
bits <- strsplit(prefmt,split="e")
bits1 <-sapply(bits,function(x) {
if (length(x) > 1) {
res <- x[[1]]
sub(" ","~",res)
} else {
x
}
})
bits2 <-sapply(bits,function(x) if (length(x)>1) paste0(" %*% 10^","'",sub("[+]"," ",x[[2]]),"'") else "")
txt <- mapply(function(b1,b2) if (nchar(b2)!=0) {paste0("'",b1,"'",b2)} else NA,
bits1,
bits2,
SIMPLIFY = F)
names(txt) <- NULL
txt <- gsub(pattern = "^'0\\.00'.*$"," 0",x=txt)
parse(text=txt)
}
sci10_old <- function(x) {
if (length(x)!=0) {
x<-sapply(x,function(x) if(x!=0) x else "0")
ifelse(x==0,"0",{
prefmt <- formatC(x,format="e",digits=2)
bits <- strsplit(prefmt,split="e")
bits1 <-sapply(bits,function(x) {
if (length(x) > 1) {
res <- x[[1]]
sub(" ","~",res)
} else {
x
}
})
print(bits1)
bits2 <-sapply(bits,function(x) if (length(x)>1) paste0(" %*% 10^",sub("[+]","~",x[[2]])) else "")
txt <- mapply(function(b1,b2) if (nchar(b2)!=0) {paste0(b1,b2)} else NA,
bits1,
bits2,
SIMPLIFY = F)
names(txt) <- NULL
message("---------")
print(txt)
message("________")
## parse(text=txt)})
txt})
} else ""
}
plot_theme <- function (legend.position="none",...)
ggplot2::theme(
plot.margin = unit(c(0,0,0,0),"cm"),
legend.position = legend.position,
axis.text = ggplot2::element_text(size=ggplot2::rel(1.2)),
axis.title = ggplot2::element_text(size=ggplot2::rel(1.2)),
...)
plot_decor <- function(m,islog,all_ms1_labels,legend_name_ms1,legend_name_ms2="CE",all_ms2_labels=NULL,
ms1_legend_info=T) {
textf <- ggplot2::element_text
my_theme <- plot_theme(legend.position="bottom",legend.box="horizontal")
## Logarithmic, or linear y axis?
scale_y <- if (shiny::isTruthy(islog))
ggplot2::scale_y_log10 else ggplot2::scale_y_continuous
getpal <- colorRampPalette(RColorBrewer::brewer.pal(8,"Dark2"))
col_all_vals <- getpal(length(all_ms1_labels))
names(col_all_vals) <- all_ms1_labels
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
scale_colour <- if (ms1_legend_info) {
function(breaks, labels, ...) ggplot2::scale_colour_manual(values = col_all_vals,
breaks = breaks,
labels = labels,
name = legend_name_ms1,...)
} else {
function(breaks=NULL, labels=NULL, ...) NULL
}
shape_all_vals <- 1:length(all_ms2_labels)
scale_ms2 <- if (length(shape_all_vals)>0) {
names(shape_all_vals) <- all_ms2_labels
function(breaks, labels, ...) ggplot2::scale_shape_manual(values = shape_all_vals,
breaks = breaks,
labels = labels,
name = legend_name_ms2, ...)
} else {
function(breaks=NULL, labels=NULL, ...) NULL
}
function(plot, breaks, labels, ms2_breaks=NULL, ms2_labels=NULL) {
plot +
scale_colour(breaks=breaks,
labels=labels) +
scale_ms2(breaks=ms2_breaks,
labels=ms2_labels) +
}
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
gen_get_ms2_legend <- function(m,legend_name_ms2="CE",all_ms2_labels) {
shape_all_vals <- 1:length(all_ms2_labels)
scale_ms2 <- if (length(shape_all_vals)>0) {
names(shape_all_vals) <- all_ms2_labels
function(breaks, labels, ...) ggplot2::scale_shape_manual(values = shape_all_vals,
breaks = breaks,
labels = labels,
name = legend_name_ms2, ...)
} else {
function(breaks=NULL, labels=NULL, ...) NULL
}
function(plot,breaks,labels) {
thing <- plot + scale_ms2(breaks=breaks,
labels=labels)
cowplot::get_legend(thing)
}
}
plot_eic_ms1 <- function(df,style_fun,plot_label) {
mk_leg_lab<-function(tag,rt) {if (length(tag) > 0) paste(tag,"; rt= ",formatC(rt,format='f',digits=RT_DIGITS)," min",sep='') else character(0)}
mz <- df[,unique(mz)]
tbl <- df[,.(verb_labs=mk_leg_lab(plot_label,rt_peak),plot_label),
by=c("plot_label","rt_peak")]
verb_labs <- tbl[,verb_labs]
labs <- tbl[,plot_label]
df[,plot_label:=factor(plot_label)]
style_fun(ggplot2::ggplot(df,ggplot2::aes(x=rt,y=intensity,colour=plot_label)),
breaks=labs,
labels=verb_labs) +
ggplot2::geom_line(key_glyph=KEY_GLYPH) +
ggplot2::labs(x=CHR_GRAM_X,
y=CHR_GRAM_Y)
}
plot_eic_ms2 <- function(df,style_fun) {
mz <- df[,unique(mz)]
ddf <- df[!is.na(rt_peak)==T]
## mk_leg_lab<-function(tag,rt,have_sel) {if (length(tag) > 0 && have_sel) paste(tag,"; rt= ",formatC(rt,format='f',digits=RT_DIGITS)," min",sep='') else if (!have_sel) tag else character(0)}
## tbl <- ddf[,.(verb_labs=mk_leg_lab(plot_label,.SD[ms2_sel==T,rt_peak],any(ms2_sel)),plot_label),
## by="plot_label"]
## ms2_verb_labs <- tbl[,verb_labs] TODO: This is nonsense for
## multi-CE and multi-other-label.
ms2_labs <- ddf[,plot_label]
ms1_labs <- ddf[,levels(parent_label)]
res <- if (NROW(ddf)>0) {
plot <- style_fun(ggplot2::ggplot(ddf,ggplot2::aes(x = rt_peak,ymin = 0,ymax = int_peak,
y = int_peak,
color = parent_label, shape = plot_label)),
breaks=ms1_labs,
labels=ms1_labs,
ms2_breaks=ms2_labs,
ms2_labels=ms2_labs)
plot + ggplot2::geom_linerange(key_glyph=KEY_GLYPH) +
ggplot2::geom_point() +
ggplot2::labs(x=CHR_GRAM_X,
y=CHR_GRAM_Y)
} else {
p <- ggplot2::ggplot(ddf,ggplot2::aes(x=1:10,y=1:10))+ggplot2::geom_blank()+ggplot2::labs(x="",y="")
p + ggplot2::annotate(geom="text", x=5, y=5, size=6, label="NO MS2 SPECTRA", color="black")+ggplot2::theme(axis.text.x=ggplot2::element_blank(),
axis.ticks.x=ggplot2::element_blank(),
axis.text.y=ggplot2::element_blank(),
axis.ticks.y=ggplot2::element_blank())
}
plot_spec_ms2 <- function(df,style_fun) {
mk_leg_lab<-function(tag,rt,have_sel) {if (length(tag) > 0 && have_sel) paste(tag,"; rt= ",formatC(rt,format='f',digits=RT_DIGITS)," min",sep='') else if (!have_sel) tag else character(0)}
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
labels <- df[,unique(plot_label)]
parent_labels <- df[,unique(parent_label)]
rts <- df[,unique(rt_peak)]
ms2_labs <- df[,levels(plot_label)]
ms1_labs <- df[,levels(parent_label)]
leglabs <- mk_leg_lab(ms1_labs,rts,T)
plot <- if (NROW(df)>0) {
ddf <- df[,.(mz,intensity,parent_label,plot_label)]
plot <-style_fun(ggplot2::ggplot(ddf,
ggplot2::aes(x=mz,ymin=0,ymax=intensity,
y = intensity,
color=parent_label,
shape=plot_label)),
labels=leglabs,
breaks=ms1_labs,
ms2_breaks=ms2_labs,
ms2_labels=ms2_labs)
plot + ggplot2::geom_linerange(key_glyph=KEY_GLYPH) +
ggplot2::geom_point() +
ggplot2::labs(x="mz", y="intensity")
} else {
p <- ggplot2::ggplot(df,ggplot2::aes(x=1:10,y=1:10))+ggplot2::geom_blank()+ggplot2::labs(x="",y="")
p + ggplot2::annotate(geom="text", x=5, y=5, size=6, label="NO MS2 SPECTRA", color="black")+ggplot2::theme(axis.text.x=ggplot2::element_blank(),
axis.ticks.x=ggplot2::element_blank(),
axis.text.y=ggplot2::element_blank(),
axis.ticks.y=ggplot2::element_blank())
}
plot
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
plot_leg_ms2 <- function(df,style_fun) {
mz <- df[,unique(mz)]
ddf <- df[!is.na(rt_peak)==T]
mk_leg_lab<-function(tag,rt,have_sel) {if (length(tag) > 0 && have_sel) paste(tag,"; rt= ",formatC(rt,format='f',digits=RT_DIGITS)," min",sep='') else if (!have_sel) tag else character(0)}
tbl <- ddf[,.(verb_labs=mk_leg_lab(plot_label,.SD[ms2_sel==T,rt_peak],any(ms2_sel)),plot_label),
by="plot_label"]
ms2_verb_labs <- tbl[,verb_labs]
ms2_labs <- tbl[,plot_label]
ms1_labs <- ddf[,levels(parent_label)]
blah <- ggplot2::ggplot(ddf,ggplot2::aes(shape = plot_label,y=int_peak,x=rt_peak)) + ggplot2::geom_point()
plot <- style_fun(blah,
breaks=ms1_labs,
labels=ms1_labs,
ms2_breaks=ms2_labs,
ms2_labels=ms2_verb_labs)
cowplot::get_legend(plot)
}
#' @export
tk_save_file <- function (default = "", caption = "Select files", filters = NULL, index = 1) {
args <- list("tk_getSaveFile", title = caption)
if (nzchar(default))
args <- c(args, initialdir = dirname(default), initialfile = basename(default))
if (!is.null(filters)) {
if (!is.character(filters) || length(dim(filters)) !=
2 || ncol(filters) != 2)
stop("'filters' must be a 2-column character matrix")
f <- filters
f[] <- paste0("{", filters, "}")
ff <- apply(f, 1, paste, collapse = " ")
fff <- paste0("{", ff, "}")
args <- c(args, filetypes = paste(fff, collapse = " "))
}
as.character(do.call(tcltk::tcl, args))
}
get_rt_interval <- function(data_ms1,data_ms2,conf_figures) {
rt_new_lim <- c(rt_in_min(conf_figures$rt_min),
rt_in_min(conf_figures$rt_max))
rt_lim <- get_coord_lim(rt_new_lim,DEFAULT_RT_RANGE)
ms1_lim <- range(data_ms1$rt)
ms2_lim <- if (NROW(data_ms2)>0) range(data_ms2$rt_peak) else c(NA,NA)
rlim <- min(rt_lim[[2]],ms1_lim[[2]],ms2_lim[[2]],na.rm = T)
llim <- max(rt_lim[[1]],ms1_lim[[1]],ms2_lim[[1]],na.rm = T)
c(llim-0.5,rlim+0.5)
}