rbbt-marq 1.0.0

data/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2009 Miguel Vazquez
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

data/R/CustomDS.R

@@ -0,0 +1,80 @@
+CustomDS.process <- function(prefix, cross_platform, conditions, description, two.channel,do.log2 = NULL){
+  tryCatch({
+    
+    # Read data
+    genes = scan(file=paste(prefix,'codes',sep = "/"), what=character(),sep="\n",quiet=T);
+    m = matrix(scan(file=paste(prefix,'values',sep = "/"), sep="\t",quiet=T),length(genes),byrow=T);
+    rownames(m) <- genes
+
+    # Read conditions
+    conditions.list = vector();
+    names = vector();
+    for (file in conditions){
+      values = scan(paste(prefix,file,sep="/"),what=character(),sep="\n",quiet=T)
+      names = c(names, file)
+      conditions.list = cbind(conditions.list, values)
+    }
+
+
+
+
+    # Do log2 if needed
+    if (is.null(do.log2)){
+      do.log2 = MA.guess.do.log2(m, two.channel)
+    }
+    if (do.log2){
+        m <- log2(m);
+    }
+    m[is.infinite(m)] = NA; # The log may have created infinite values
+
+    # Make translations to genes
+    if (cross_platform){
+        trans = scan(file=paste(prefix,'cross_platform',sep = "/"),what=character(),sep="\n",quiet=T);
+        if (!is.null(trans)){
+            m <- MA.translate(m, trans);
+        }
+    }
+
+    # Once the data is read, change the prefix for cross_platform ids
+    if (cross_platform){
+      prefix = paste(prefix,'cross_platform', sep="_")
+    }
+    colnames(conditions.list) <- names;
+
+    values <- MA.process(m, conditions.list, two.channel);
+
+    ratios   = as.data.frame(values$ratios);
+    t        = as.data.frame(values$t);
+    p.values = as.data.frame(values$p.values);
+
+
+    # Calculate orders from best information
+    best = vector();
+    names = vector();
+    for (name in colnames(ratios)){
+        if (sum(colnames(t) == name) > 0){
+            best = cbind(best, t[,name]);
+            names = c(names, name);
+        }else{
+            best = cbind(best, ratios[,name]);
+            names = c(names, paste(name,'[ratio]', sep=" "));
+        }
+    }
+    rownames(best) <- rownames(ratios);
+    orders   = as.data.frame(MA.get_order(best));
+    colnames(orders) <- names;
+
+
+    if (is.null(values)){
+        write(file=paste(prefix,'skip',sep="."), "no suitable samples for analysis" );
+    }else{
+        MA.save(prefix, orders, ratios, t, p.values, colnames(orders), description);
+    }
+  },
+    error=function(x){ 
+        print("exception caught");
+        print(x);
+        write(file=paste(prefix,'skip',sep="."), paste("an exception was caught during the analysis.",x,sep="\n") );
+    }
+  )
+}

data/R/GEO.R

@@ -0,0 +1,249 @@
+library(Biobase);
+library(GEOquery);
+
+GEO.values <- function(data){
+    values <- MA.process(data$m, data$conditions, data$two.channel)
+
+    if (length(values$ratios) == 0){
+        return(NULL);
+    }else{
+        ratios   = as.data.frame(values$ratios);
+        t        = as.data.frame(values$t);
+        p.values = as.data.frame(values$p.values);
+
+
+        # Calculate orders from best information
+        best = vector();
+        names = vector();
+        for (name in colnames(ratios)){
+            if (sum(colnames(t) == name) > 0){
+                best = cbind(best, t[,name]);
+                names = c(names, name);
+            }else{
+                best = cbind(best, ratios[,name]);
+                names = c(names, paste(name,'[ratio]', sep=" "));
+            }
+        }
+        rownames(best) <- rownames(ratios)
+        orders   = as.data.frame(MA.get_order(best));
+        colnames(orders) <- names
+
+        return(list(ratios = ratios, t = t, p.values = p.values, orders = orders));
+    }
+}
+
+
+
+GEO.get <- function(name, cachedir = NULL){
+    if (is.null(cachedir)){
+        object  <- getGEO(name);
+    }else{
+        filename = dir(cachedir,pattern= paste(name, 'soft', sep='.'))[1]
+        if (is.na(filename)){
+            object  <- getGEO(name, destdir=cachedir);
+        }else{
+            object  <- getGEO(name, filename = paste(cachedir,filename,sep="/"));
+        }
+    }
+
+    object
+}
+
+# Parses phenotype data structure to determine the conditions
+GEO.find_conditions <- function(ph) {
+    # Find conditions
+    labels = varLabels(ph);
+
+    # Removed not usefull
+    labels = labels[-grep('sample|description|individual|none',labels)]
+
+    # Find labels with replicates
+
+    labels
+}
+
+GEO.GDS.data <- function(name, id.field = NULL, translation.file = NULL, cachedir = NULL){
+
+    gds = GEO.get(name, cachedir);
+
+    gpl_name = Meta(gds)$platform
+    gpl = GEO.get(gpl_name, cachedir);
+    description = paste(Meta(gds)$title, Meta(gds)$description, sep="\n--\n")
+
+ 
+    two.channel <- attr(gds,'header')$channel_count == '2'
+    value.type  <-  attr(gds,'header')$value_type
+    if (length(grep('log',value.type)) == 0){
+        do.log2 = TRUE;
+    }else{
+        do.log2 = FALSE;
+    }
+    eSet <- GDS2eSet(gds, GPL=gpl, do.log2 = do.log2 );
+
+    ph = phenoData(eSet)
+    conditions = sapply(GEO.find_conditions(ph), function(condition){ph[[condition]]});
+
+    m = exprs(eSet)
+
+    trans = NULL
+    if (!is.null(id.field)){
+        trans = featureData(eSet)[[id.field]];
+    }
+    if (!is.null(translation.file)){
+        trans = scan(file=translation.file,what=character(),sep="\n",quiet=T);
+    }
+
+    if (!is.null(trans)){
+        m <- MA.translate(m, trans);
+    }
+
+
+
+    return (list(conditions = conditions, m = m, two.channel = two.channel, description = description))
+}
+
+
+GEO.GDS.process <- function(name, prefix, id.field = NULL, translation.file = NULL,cachedir=NULL){
+    tryCatch(
+    {
+        gds.data = GEO.GDS.data(name, id.field, translation.file, cachedir)
+        values = GEO.values(gds.data)
+        if (is.null(values)){
+            write(file=paste(prefix,'skip',sep="."), "No suitable samples for analysis" );
+        }else{
+            MA.save(prefix, values$orders, values$ratios, values$t, values$p.values, colnames(values$orders), gds.data$description);
+        }
+    }
+    ,
+        error=function(x){ 
+             print("Exception caught");
+             print(x);
+             write(file=paste(prefix,'skip',sep="."), paste("An exception was caught during the analysis.",x,sep="\n") );
+        }
+    )
+}
+
+
+
+
+GEO.GSE.data <- function(gsms, conditions, do.log2 = NULL, translation.file = NULL, use.fields = NULL, cachedir = NULL){
+
+    c = sapply(conditions,function(x){x});
+    colnames(c) <- names(conditions);
+    conditions = c;
+
+    # Get gene names
+    gene.names = vector();
+    for(name in gsms){
+        gsm = GEO.get(name, cachedir);
+        data = attr(dataTable(gsm),'table');
+        if (!is.null(use.fields)){
+            gsm.names = levels(factor(data[,use.fields[name]]))
+        }else{
+            gsm.names = levels(factor(data[,1]))
+        }
+        gene.names <- c(gene.names, gsm.names)
+    }
+
+    gene.names= sort(unique((gene.names)));
+    gene.names = gene.names[gene.names != ""];
+
+    
+    # Merge Arrays
+    init <- rep(NA,length(gene.names))
+    names(init) <- gene.names;
+    m <- NULL;
+    for(name in gsms){
+        gsm = GEO.get(name, cachedir);
+        two.channel <- attr(gsm,'header')$channel_count == '2';
+        data = attr(dataTable(gsm),'table')
+        values = as.numeric(data[,"VALUE"])
+
+        # Merge duplicates
+       
+
+        if (!is.null(use.fields)){
+            names = factor(data[,use.fields[name]])
+        }else{
+            names = factor(data[,1])
+        }
+        
+        values = tapply(values, factor(names), mean, na.rm = T)
+        n <- names(values)
+        values = as.vector(values)
+        names(values) <- n
+ 
+        if (is.null(m)){
+            m = init
+            m[names(values)] = values
+        }else{
+            new = init
+            new[names(values)] = values;
+            m = cbind(m, new)
+        }
+    }
+    colnames(m) <- as.list(gsms);
+
+
+
+    if (is.null(m)){
+        return(NULL);
+    }
+
+    trans = NULL
+    if (!is.null(translation.file)){
+        trans = read.table(file=translation.file, sep="\t",header=F)[,1];
+    }
+    if (!is.null(trans)){
+        m <- MA.translate(m, trans);
+    }
+
+    if(is.null(do.log2)){
+      do.log2 = MA.guess.do.log2(m, two.channel);
+    }
+
+    if (do.log2){
+        m <- log2(m);
+    }
+
+    # The log may have created infinite values
+    m[is.infinite(m)] = NA
+
+    return (list(conditions = conditions, m = m, two.channel = two.channel))
+}
+
+GEO.GSE.process <- function(gsms, conditions, prefix, do.log2 = NULL, translation.file = NULL, use.field = NULL, title = NULL,  description = NULL,cachedir=NULL){
+    tryCatch(
+    {
+        gse.data = GEO.GSE.data(gsms, conditions, do.log2, translation.file, use.field, cachedir)
+        values = GEO.values(gse.data)
+        full_desc = paste(title, description, sep="\n--\n")
+        if (is.null(values)){
+            write(file=paste(prefix,'skip',sep="."), "No suitable samples for analysis" );
+        }else{
+            MA.save(prefix, values$orders, values$ratios, values$t, values$p.values, colnames(values$orders), full_desc );
+        }
+    }
+    ,
+        error=function(x){ 
+             print("Exception caught");
+             print(x);
+             write(file=paste(prefix,'skip',sep="."), paste("An exception was caught during the analysis.",x,sep="\n") );
+        }
+    )
+
+}
+
+
+GEO.GPL.process <- function(name, prefix, id.field = NULL, cachedir = NULL){
+    gpl = GEO.get(name, cachedir);
+    if (is.null(id.field)){
+        ids <- Table(gpl)$ID;
+    }else{
+        ids <- Table(gpl)[[id.field]];
+    }
+
+    write.table(file=paste(prefix,'codes',sep="."), ids, sep="\t",  row.names=F, col.names=F, quote=F);
+}
+
+

data/R/MA.R

@@ -0,0 +1,359 @@
+library(limma)
+
+MA.get_order <- function(values){
+    orders = values;
+    orders[,] = NA;
+
+    for (i in 1:dim(values)[2]){
+        positions = names(sort(values[,i],decreasing=T))
+
+        orders[,i] = NA
+        orders[positions,i] = 1:length(positions)
+    }
+    orders 
+}
+
+MA.guess.do.log2 <- function(m, two.channel){
+  if (two.channel){
+    return (sum(m < 0, na.rm = TRUE) == 0);
+  }else{
+    return (max(m, na.rm = TRUE) > 100);
+  }
+}
+
+MA.translate <- function(m, trans){
+    trans[trans==""] = NA;
+    trans[trans=="NO MATCH"] = NA;
+
+    missing = length(trans) - dim(m)[1];
+
+    # If extra genes
+    if (missing < 0){
+      trans = c(trans,rep(NA, - missing))
+      missing = 0;
+    }
+    n = apply(m,2,function(x){ 
+      
+      # Complete data with missing genes
+      x.complete = c(x,rep(NA, missing));
+      tapply(x.complete, factor(trans), median)
+    });
+    n[sort(rownames(n),index.return=T)$ix,]
+}
+
+# Conditions
+
+MA.conditions.has_control <- function(x){
+    keywords = c('none', 'control', 'normal', 'wild', 'baseline', 'untreat', 'uninfected', 'universal', 'reference', 'vehicle', 'w.t.','wt');
+    for(keyword in keywords){
+      control = grep(keyword, x, ignore.case = TRUE);
+      if (any(control)){
+          return(x[control[1]]);
+      }
+    }
+    return(NULL)
+}
+
+MA.condition.values <- function(values){
+    control = MA.conditions.has_control(values);
+
+    values.factor = factor(values);
+    values.levels = levels(values.factor);
+
+    # If there is a control state remove it from sorting
+    if (!is.null(control))
+        values.levels = values.levels[values.levels != control];    
+
+    
+    # Use numeric sort if they all have numbers
+    if (length(grep('^ *[0-9]+',values.levels,perl=TRUE)) == length(values.levels)){
+        ix = sort(as.numeric(sub('^ *([0-9]+).*',"\\1",values.levels)), decreasing = T, index.return = TRUE)$ix
+    }else{
+        ix = sort(values.levels, decreasing = T, index.return = TRUE)$ix
+    }
+    
+    return(list(values = values.levels[ix], control = control));
+}
+
+
+#########################################################################
+# Model processing 
+
+# Ratio
+MA.ratio.two_channel <- function(m, conditions, main){
+    main = m[,conditions==main];
+    if (!is.null(dim(main))){
+        main = apply(main, 1 ,function(x){mean(x, na.rm = TRUE)});
+    }
+    return(main);
+}
+
+MA.ratio.contrast <- function(m, conditions, main, contrast){
+    main = m[,conditions==main];
+    if (!is.null(dim(main))){
+        main = apply(main, 1 ,function(x){mean(x, na.rm = TRUE)});
+    }
+
+    contrast = m[,conditions==contrast];
+    if (!is.null(dim(contrast))){
+        contrast = apply(contrast, 1 ,function(x){mean(x, na.rm = TRUE)});
+    }
+      
+    return (main - contrast);
+}
+
+
+# Limma
+
+MA.limma.two_channel <- function(m, conditions, main){
+  if (sum(conditions == main) < 3){
+    return(NULL);
+  }
+    
+  design = rep(0,dim(m)[2]);
+  design[conditions == main] = 1;
+
+  # We need to subset the columns because of a problem with NA values. This
+  # might affect eBayes variance estimations, thats my guess anyway...
+  
+  fit <- lmFit(m[,design == 1],rep(1, sum(design)));
+  
+  tryCatch({
+      fit <- eBayes(fit);
+      sign = fit$t < 0;
+      sign[is.na(sign)] = FALSE;
+      fit$p.value[sign] =  - fit$p.value[sign];
+      return(list(t= fit$t, p.values= fit$p.value));
+  }, error=function(x){
+      print("Exception caught in eBayes");
+      print(x);
+  })
+
+  return(NULL);
+}
+
+MA.limma.contrast <- function(m, conditions, main, contrast){
+  if (sum(conditions == main) + sum(conditions == contrast) < 3){
+    return(NULL);
+  }
+  m = cbind(m[,conditions == main],m[,conditions == contrast])
+  
+  design = cbind(rep(1,dim(m)[2]), rep(0,dim(m)[2]));
+  colnames(design) <-c('intercept', 'main');
+  design[1:sum(conditions==main),2] = 1;
+
+
+  fit <- lmFit(m,design);
+  tryCatch({
+      fit <- eBayes(fit);
+      sign = fit$t[,2] < 0;
+      sign[is.na(sign)] = FALSE;
+      fit$p.value[sign,2] = - fit$p.value[sign,2] 
+      return(list(t= fit$t[,2], p.values= fit$p.value[,2] ));
+  }, error=function(x){
+      print("Exception caught in eBayes");
+      print(x);
+  })
+
+  return(NULL);
+}
+
+
+#########################################################################
+# Process conditions
+
+MA.process_conditions.contrasts <- function(m, conditions, two.channel){
+  max_levels             = 10;
+  max_levels_control     = 1;
+
+
+  values = MA.condition.values(conditions);
+
+
+  ratios   = vector();
+  t       = vector();
+  p.values = vector();
+
+  ratio_names = vector();
+  t_names     = vector();
+
+  if (!is.null(values$control)){
+      contrast = values$control;
+      for (main in values$values){
+          name =  paste(main, contrast, sep = " <=> ")
+          
+          ratio       = MA.ratio.contrast(m, conditions, main, contrast);
+          ratio_names = c(ratio_names, name);
+          ratios      = cbind(ratios, ratio);
+
+          res      = MA.limma.contrast(m, conditions, main, contrast);        
+          if (!is.null(res)){
+              t_names = c(t_names, name);
+              t           = cbind(t, res$t);
+              p.values     = cbind(p.values, res$p.values);
+         } 
+     }
+  }
+
+
+  if (length(values$values) <= max_levels_control || (is.null(values$control) && !two.channel && length(values$values) <= max_levels )){
+
+      remaining = values$values;
+      for (main in values$values){
+          remaining = remaining[remaining != main];
+          for (contrast in remaining){
+              name =  paste(main, contrast, sep = " <=> ");
+          
+              ratio       = MA.ratio.contrast(m, conditions, main, contrast);
+              ratio_names = c(ratio_names, name);
+              ratios      = cbind(ratios, ratio);
+
+              res      = MA.limma.contrast(m, conditions, main, contrast);        
+              if (!is.null(res)){
+                  t_names  = c(t_names, name);
+                  t        = cbind(t, res$t);
+                  p.values = cbind(p.values, res$p.values);
+              } 
+          }
+      }
+  }
+
+ 
+  if (length(ratio_names) != 0){
+    colnames(ratios) <- ratio_names
+  }
+
+  if (length(t_names) != 0){
+    colnames(t) <- t_names
+    colnames(p.values) <- t_names
+  }
+
+  return(list(ratios = ratios, t=t, p.values = p.values));
+}
+
+MA.process_conditions.two_channel <- function(m, conditions){
+  values = MA.condition.values(conditions);
+
+  all_values = values$values
+  if (!is.null(values$control)){
+      all_values = c(all_values, values$control);
+  }
+  
+
+  ratios   = vector();
+  t        = vector();
+  p.values = vector();
+
+  ratio_names = vector();
+  t_names     = vector();
+
+
+  for (main in all_values){
+      name =  main;
+
+      ratio       = MA.ratio.two_channel(m, conditions, main);
+      ratio_names = c(ratio_names, name);
+      ratios      = cbind(ratios, ratio);
+
+      res      = MA.limma.two_channel(m, conditions, main);        
+      if (!is.null(res)){
+          t_names = c(t_names, name);
+          t           = cbind(t, res$t);
+          p.values     = cbind(p.values, res$p.values);
+      } 
+  }
+
+  if (length(ratio_names) != 0){
+    colnames(ratios) <- ratio_names
+  }
+
+  if (length(t_names) != 0){
+    colnames(t) <- t_names
+    colnames(p.values) <- t_names
+  }
+
+  return(list(ratios = ratios, t=t, p.values = p.values));
+}
+
+
+
+# Process microarray matrix
+
+MA.process <- function(m, conditions_list, two.channel = FALSE){
+   
+  ratios   = vector();
+  t        = vector();
+  p.values = vector();
+
+  for(type in colnames(conditions_list)){
+     conditions = conditions_list[,type]
+
+     if (two.channel){
+         res = MA.process_conditions.two_channel(m, conditions);
+         if (length(res$ratios) != 0){    colnames(res$ratios) <- sapply(colnames(res$ratios),function(x){paste(type,x,sep=": ")});     ratios   = cbind(ratios,res$ratios);}
+         if (length(res$t) != 0){         colnames(res$t) <- sapply(colnames(res$t),function(x){paste(type,x,sep=": ")});               t        = cbind(t,res$t);}
+         if (length(res$p.values) != 0){  colnames(res$p.values) <- sapply(colnames(res$p.values),function(x){paste(type,x,sep=": ")}); p.values = cbind(p.values,res$p.values);}
+     }
+
+     res = MA.process_conditions.contrasts(m, conditions, two.channel);
+     if (length(res$ratios) != 0){    colnames(res$ratios) <- sapply(colnames(res$ratios),function(x){paste(type,x,sep=": ")});     ratios   = cbind(ratios,res$ratios);}
+     if (length(res$t) != 0){         colnames(res$t) <- sapply(colnames(res$t),function(x){paste(type,x,sep=": ")});               t        = cbind(t,res$t);}
+     if (length(res$p.values) != 0){  colnames(res$p.values) <- sapply(colnames(res$p.values),function(x){paste(type,x,sep=": ")}); p.values = cbind(p.values,res$p.values);}
+   }
+
+   return(list(ratios = ratios, t=t, p.values = p.values));
+}
+
+
+MA.save <- function(prefix, orders, ratios, t , p.values, experiments, description = NULL) {
+    if (is.null(orders)){
+        write(file=paste(prefix,'skip',sep="."), "No suitable samples for analysis" );
+    } else {
+        write.table(file=paste(prefix,'orders',sep="."), orders, sep="\t",  row.names=F, col.names=F, quote=F);
+        write.table(file=paste(prefix,'codes',sep="."), rownames(orders), sep="\t",  row.names=F, col.names=F, quote=F);
+        write.table(file=paste(prefix,'logratios',sep="."), ratios, sep="\t",  row.names=F, col.names=F, quote=F);
+        write.table(file=paste(prefix,'t',sep="."), t, sep="\t",  row.names=F, col.names=F, quote=F);
+        write.table(file=paste(prefix,'pvalues',sep="."), p.values, sep="\t",  row.names=F, col.names=F, quote=F);
+        write.table(file=paste(prefix,'experiments',sep="."), experiments, sep="\t",  row.names=F, col.names=F, quote=F);
+
+        write(file=paste(prefix,'description',sep="."),  description)
+    }
+}
+
+MA.load <- function(prefix, orders = TRUE, logratios = TRUE, t = TRUE, p.values = TRUE){
+  data = list();
+  genes <- scan(file=paste(prefix,'codes',sep="."),sep="\n",quiet=T,what=character());
+  experiments <- scan(file=paste(prefix,'experiments',sep="."),sep="\n",quiet=T,what=character());
+
+  experiments.no.ratio = experiments[- grep('ratio', experiments)];
+
+  if (orders){
+      orders <- read.table(file=paste(prefix,'orders',sep="."),sep="\t");
+      rownames(orders) <- genes;
+      colnames(orders) <- experiments;
+      data$orders=orders;
+  }
+  if (logratios){
+      logratios <- read.table(file=paste(prefix,'logratios',sep="."),sep="\t");
+      rownames(logratios) <- genes;
+      colnames(logratios) <- experiments;
+      data$logratios=logratios;
+  }
+  if (t){
+      t <- read.table(file=paste(prefix,'t',sep="."),sep="\t");
+      rownames(t) <- genes;
+      colnames(t) <- experiments.no.ratio;
+      data$t=t;
+  }
+  if (p.values){
+      p.values <- read.table(file=paste(prefix,'pvalues',sep="."),sep="\t");
+      rownames(p.values) <- genes;
+      colnames(p.values) <- experiments.no.ratio;
+      data$p.values=p.values;
+  }
+ 
+
+  return(data);
+
+
+}