Merge pull request #4 from computational-metabolomics/tk_workflow

Tk workflow

Author: grlloyd

.travis.yml

@@ -1,5 +1,5 @@
 language: r
-r: bioc-devel
+r: bioc-release
 sudo: false
 cache: packages
 warnings_are_errors: false

DESCRIPTION

@@ -24,6 +24,7 @@ Collate:
     'autoscale_class.R'
     'balanced_accuracy_class.R'
     'blank_filter_class.R'
+    'bootstrap_class.R'
     'calculate_doc.R'
     'chart_plot_doc.R'
     'classical_lsq_class.R'
@@ -57,6 +58,7 @@ Collate:
     'mv_feature_filter_class.R'
     'mv_sample_filter_class.R'
     'pairs_filter_class.R'
+    'permutation_test2_class.R'
     'permutation_test_class.R'
     'permute_sample_order_class.R'
     'pqn_norm_method_class.R'
@@ -73,7 +75,7 @@ Collate:
     'vec_norm_class.R'
     'wilcox_test_class.R'
     'zzz.R'
-Depends: struct
+Depends: struct (== 0.4.0)
 Imports: ggplot2,
  pmp,
  gridExtra,
@@ -101,7 +103,7 @@ Suggests:
  sbcms,
  Rtsne
 Remotes: computational-metabolomics/pmp,
-  computational-metabolomics/struct,
+  computational-metabolomics/struct@v0.4.0,
   computational-metabolomics/sbcms
 VignetteBuilder: knitr
 biocViews: WorkflowStep

NAMESPACE

@@ -14,6 +14,7 @@ export(autoscale)
 export(balanced_accuracy)
 export(blank_filter)
 export(blank_filter.hist)
+export(bootstrap)
 export(classical_lsq)
 export(compare_dist)
 export(confounders_clsq)
@@ -66,6 +67,7 @@ export(permutation_test.boxplot)
 export(permutation_test.hist)
 export(permutation_test.scatter)
 export(permutation_test.violin)
+export(permutation_test2)
 export(permute_sample_order)
 export(plsda_scores_plot)
 export(plsr_cook_dist)
@@ -89,7 +91,7 @@ export(wilcox_p_hist)
 export(wilcox_test)
 exportMethods(calculate)
 exportMethods(chart.plot)
-exportMethods(method.apply)
+exportMethods(model.apply)
 exportMethods(model.predict)
 exportMethods(model.reverse)
 exportMethods(model.train)

R/HSDEM_class.R

@@ -12,7 +12,7 @@
 #' M = HSDEM()
 HSDEM<-setClass(
     "HSDEM",
-    contains=c('method','stato'),
+    contains=c('model','stato'),
     slots=c(
         # INPUTS
         params.alpha='entity.stato',
@@ -60,8 +60,8 @@ HSDEM<-setClass(
 )
 
 #' @export
-#' @template method_apply
-setMethod(f="method.apply",
+#' @template model_apply
+setMethod(f="model.apply",
     signature=c("HSDEM",'dataset'),
     definition=function(M,D) {
         X=dataset.data(D)

R/HSD_class.R

@@ -11,7 +11,7 @@
 #' M = HSD()
 HSD<-setClass(
     "HSD",
-    contains=c('method','stato'),
+    contains=c('model','stato'),
     slots=c(
         # INPUTS
         params.alpha='entity.stato',
@@ -70,8 +70,8 @@ HSD<-setClass(
 )
 
 #' @export
-#' @template method_apply
-setMethod(f="method.apply",
+#' @template model_apply
+setMethod(f="model.apply",
     signature=c("HSD",'dataset'),
     definition=function(M,D) {
         X=dataset.data(D)

R/PLSFC_class.R

@@ -20,8 +20,8 @@ PLSFC<-setClass(
 )
 
 #' @export
-#' @template method_apply
-setMethod(f="method.apply",
+#' @template model_apply
+setMethod(f="model.apply",
     signature=c("PLSFC",'dataset'),
     definition=function(M,D) {
         # log transform
@@ -59,7 +59,7 @@ setMethod(f="method.apply",
             for (B in (A+1):(length(L))) {
                 # filter groups to A and B
                 FG=filter_smeta(factor_name=M$factor_name,mode='include',levels=L[c(A,B)])
-                FG=method.apply(FG,D)
+                FG=model.apply(FG,D)
                 # change to ordered factor so that we make use of control group
                 FG$filtered$sample_meta[[M$factor_name]]=ordered(FG$filtered$sample_meta[[M$factor_name]],levels=L[c(A,B)])
 

R/anova_class.R

@@ -14,14 +14,14 @@
 #' @examples
 #' D = iris_dataset()
 #' M = ANOVA(formula=y~Species)
-#' M = method.apply(M,D)
+#' M = model.apply(M,D)
 #'
 #' @include entity_objects.R
 #'
 #' @export ANOVA
 ANOVA<-setClass(
     "ANOVA",
-    contains=c('method','stato'),
+    contains=c('model','stato'),
     slots=c(
         # INPUTS
         params.alpha='entity.stato',
@@ -58,8 +58,8 @@ ANOVA<-setClass(
 
 
 #' @export
-#' @template method_apply
-setMethod(f="method.apply",
+#' @template model_apply
+setMethod(f="model.apply",
     signature=c("ANOVA",'dataset'),
     definition=function(M,D)
     {

R/blank_filter_class.R

@@ -20,12 +20,12 @@
 #'                  factor_name='Species',
 #'                  blank_label='setosa',
 #'                  qc_label='versicolor')
-#' M = method.apply(M,D)
+#' M = model.apply(M,D)
 #'
 #' @export blank_filter
 blank_filter<-setClass(
     "blank_filter",
-    contains = c('method'),
+    contains = c('model'),
     slots=c(params.fold_change='entity',
         params.blank_label='entity',
         params.qc_label='entity',
@@ -58,41 +58,49 @@ blank_filter<-setClass(
 )
 
 #' @export
-#' @template method_apply
-setMethod(f="method.apply",
+#' @template model_train
+setMethod(f="model.train",
     signature=c("blank_filter","dataset"),
     definition=function(M,D)
     {
-        opt=param.list(M)
         smeta=dataset.sample_meta(D)
         x=dataset.data(D)
         # remove = NULL does not remove blanks. ANY VALUE removes blanks.
-        blank_filtered = pmp::filter_peaks_by_blank(t(x), fold_change=opt$fold_change,
-            classes=smeta[,opt$factor_name],
-            blank_label=opt$blank_label,
-            qc_label=opt$qc_label,
+        blank_filtered = pmp::filter_peaks_by_blank(t(x), fold_change=M$fold_change,
+            classes=smeta[,M$factor_name],
+            blank_label=M$blank_label,
+            qc_label=M$qc_label,
             remove=FALSE,
-            fraction_in_blank=opt$fraction
+            fraction_in_blank=M$fraction
         )
-        dataset.data(D) = as.data.frame(t(blank_filtered$df))
 
+        # store the flags
+        flags=data.frame(blank_filtered$flags)
+        output.value(M,'flags') = data.frame(blank_filtered$flags,stringsAsFactors = F)
+        return(M)
+    }
+)
+
+#' @export
+#' @template model_predict
+setMethod(f="model.predict",signature=c("blank_filter","dataset"),
+    definition=function(M,D) {
         # remove the blanks. do it this way because pmp doesnt remove from class labels.
-        RB = filter_smeta(mode='exclude',levels=opt$blank_label,factor_name=opt$factor_name)
-        RB=method.apply(RB,D)
+        RB = filter_smeta(mode='exclude',levels=M$blank_label,factor_name=M$factor_name)
+        RB=model.apply(RB,D)
         D=predicted(RB)
 
-        flags=data.frame(blank_filtered$flags)
+        # get the flags
+        flags=M$flags
         vmeta=dataset.variable_meta(D)
         vmeta=vmeta[flags$blank_flags==1,,drop=FALSE]
         dataset.variable_meta(D)=vmeta
 
         output.value(M,'filtered') = D
-        output.value(M,'flags') = data.frame(blank_filtered$flags,stringsAsFactors = F)
         return(M)
     }
 )
 
-
 ##### plots
 #' plot for blank filter
 #'

R/bootstrap_class.R

@@ -0,0 +1,99 @@
+#' permutation test class
+#'
+#' Applies a permutation test to a model or model.seq()
+#' @examples
+#' I=bootstrap()
+#'
+#' @export bootstrap
+bootstrap<-setClass(
+    "bootstrap",
+    contains='resampler',
+    slots=c(
+        params.number_of_permutations='numeric',
+        params.collect='character',
+        outputs.results='data.frame',
+        outputs.metric='data.frame',
+        outputs.collected='entity'
+    ),
+    prototype = list(name='permutation test',
+                     type='permutation',
+                     result='results',
+                     params.number_of_permutations=10,
+                     params.collect='vip',
+                     outputs.collected=entity(name='collected output',
+                                              type=c('logical','list'),
+                                              value=NA,max_length=Inf)
+    )
+)
+
+#' @export
+#' @template run
+setMethod(f="run",
+          signature=c("bootstrap",'dataset','metric'),
+          definition=function(I,D,MET=NULL)
+          {
+
+              X=dataset.data(D)
+              y=dataset.sample_meta(D)
+              # get the WF
+              WF=models(I)
+              n=param.value(I,'number_of_permutations')
+
+              all_results=data.frame('actual'=rep(y[,1],n),'predicted'=rep(y[,1],n),'permutation'=0)
+
+              collected=list()
+
+              for (i in 1:n)
+              {
+                  results=data.frame('actual'=y[,1],'predicted'=y[,1],'permutation'=i)
+
+                  # generate a random sample order
+                  order=sample.int(nrow(X),replace = TRUE) # WITH REPLACEMENT
+
+                  # permute
+                  Xp=X[order,,drop=FALSE]
+                  Yp=as.data.frame(y[order,,drop=FALSE])
+
+                  # rebuild datasets
+                  Dp=D
+                  dataset.data(Dp)=Xp
+                  dataset.sample_meta(Dp)=Yp
+
+                  if (is(WF,'model_OR_model.seq'))
+                  {
+                      ## permuted labels
+                      # train
+                      WF=model.train(WF,Dp)
+                      # predict
+                      WF=model.predict(WF,Dp)
+                      p=predicted(WF)
+                      results[,2]=p[,1]
+                      all_results[((nrow(X)*(i-1))+1):(nrow(X)*i),]=results
+
+                      if (!is.na(I$collect)) {
+                          if (is(WF,'model')) {
+                              collected=c(collected,list(output.value(WF,I$collect)))
+                          } else {
+                              # if sequence assume collecting from last index
+                              collected=c(collected,list(output.value(WF[length(WF)],I$collect)))
+                          }
+                          I$collected=collected
+                      }
+
+
+                  }
+
+                  if (is(WF,'iterator'))
+                  {
+
+                     stop('not implemented yet')
+                  }
+
+              }
+              # store results
+              output.value(I,'results')=all_results
+              return(I)
+          }
+)
+
+

R/classical_lsq_class.R

@@ -17,13 +17,13 @@
 #' @examples
 #' D = iris_dataset()
 #' M = classical_lsq(factor_names = 'Species')
-#' M = method.apply(M,D)
+#' M = model.apply(M,D)
 #'
 #' @export classical_lsq
 
 classical_lsq<-setClass(
     "classical_lsq",
-    contains='method',
+    contains='model',
     slots=c(
         # INPUTS
         params.alpha='entity.stato',
@@ -75,8 +75,8 @@ classical_lsq<-setClass(
 )
 
 #' @export
-#' @template method_apply
-setMethod(f="method.apply",
+#' @template model_apply
+setMethod(f="model.apply",
     signature=c("classical_lsq",'dataset'),
     definition=function(M,D)
     {