Skip to content
Snippets Groups Projects
mix.R 48.2 KiB
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",
Todor Kondic's avatar
Todor Kondic committed
               "file")
    
    res <- summ[ms1_spec,c(.SD,
                           list(rt_peak=i.ms1_rt,
                                eicMS1=lapply(i.eicMS1,list))),
                nomatch=NULL]
    setkeyv(res,cols=BASE_KEY)
    res
}

gen_base_ms2_plot_tab <- function(summ,ms2_spec) {
    ident <- c("set",
               "adduct",
               "tag",
               "ID",
               "mz",
Todor Kondic's avatar
Todor Kondic committed
               "file")
    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
}
Todor Kondic's avatar
Todor Kondic committed

## 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 ""
}
Todor Kondic's avatar
Todor Kondic committed

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
Todor Kondic's avatar
Todor Kondic committed

    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
    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) +
Todor Kondic's avatar
Todor Kondic committed
            scale_y(labels=sci10) + my_theme
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)}
    
    
    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
    
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)
}