Mercurial > repos > iuc > charts

changeset 1:344ac3ca7557 draft default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
"planemo upload for repository https://github.com/galaxyproject/tools-iuc/tree/master/tools/charts/ commit 4494db13b69987fbc97d47177d2a5956e46e927b"
author iuc
date Wed, 17 Nov 2021 09:06:59 +0000
parents a87a3773d8ed
children
files boxplot.r charts.r charts.xml heatmap.r histogram.r histogramdiscrete.r
diffstat 6 files changed, 118 insertions(+), 114 deletions(-) [+]
line wrap: on
line diff
--- a/boxplot.r	Fri Mar 09 08:23:08 2018 -0500
+++ b/boxplot.r	Wed Nov 17 09:06:59 2021 +0000
@@ -8,14 +8,14 @@
         # load column data
         column <- as.numeric(columns[key])
         column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))
-    
+
         # create hist data
-        data <- boxplot(column_data, plot=FALSE)
-        
+        data <- boxplot(column_data, plot = FALSE)
+
         # collect vectors in list
         l <- append(l, list(data$stats))
     }
-    
+
     # return
-    return (l)
+    return(l)
 }
--- a/charts.r	Fri Mar 09 08:23:08 2018 -0500
+++ b/charts.r	Wed Nov 17 09:06:59 2021 +0000
@@ -1,13 +1,13 @@
 #!/usr/bin/Rscript
 
 # load getopt library
-library('getopt');
+library("getopt");
 
 # convert multi parameter string (i.e. key1: value, key2: value, ...) to object
-split <- function(argument){
+split <- function(argument) {
     # process parameter string
     options <- list()
-    list <- gsub("\\s","", argument)
+    list <- gsub("\\s", "", argument)
     list <- strsplit(list, ",")
     if (length(list) > 0) {
         list <- list[[1]]
@@ -25,92 +25,92 @@
 }
 
 # get options, using the spec as defined by the enclosed list.
-spec = matrix(c(
-    'workdir',  'w', 1, 'character', 'Work directory',
-    'module',   'm', 1, 'character', 'Module name',
-    'input',    'i', 1, 'character', 'Input tabular file',
-    'columns',  'c', 1, 'character', 'Columns string',
-    'settings', 's', 1, 'character', 'Settings string',
-    'output',   'o', 1, 'character', 'Output tabular file',
-    'help',     'h', 0, '',          'Help',
-    'verbose',  'v', 0, '',          'Verbose'
-), byrow=TRUE, ncol=5);
-opt = getopt(spec);
+spec <- matrix(c(
+    "workdir",  "w", 1, "character", "Work directory",
+    "module",   "m", 1, "character", "Module name",
+    "input",    "i", 1, "character", "Input tabular file",
+    "columns",  "c", 1, "character", "Columns string",
+    "settings", "s", 1, "character", "Settings string",
+    "output",   "o", 1, "character", "Output tabular file",
+    "help",     "h", 0, "",          "Help",
+    "verbose",  "v", 0, "",          "Verbose"
+), byrow = TRUE, ncol = 5);
+opt <- getopt(spec);
 
 # show help
-if ( !is.null(opt$help) ||
+if (!is.null(opt$help) ||
     is.null(opt$module) ||
     is.null(opt$input) ||
     is.null(opt$columns) ||
     is.null(opt$output)) {
-    cat(getopt(spec, usage=TRUE))
-    q(status=1);
+    cat(getopt(spec, usage = TRUE))
+    q(status = 1);
 }
 
 # read columns/settings
-columns = split(opt$columns)
-settings = split(opt$settings)
+columns <- split(opt$columns)
+settings <- split(opt$settings)
 
 # read table
-table <- read.table(opt$input, comment.char='#', fill=TRUE)
+table <- read.table(opt$input, comment.char = "#", fill = TRUE)
 
 # identify module file
-module_file = paste(opt$workdir, opt$module, '.r', sep='')
+module_file <- paste(opt$workdir, opt$module, ".r", sep = "")
 
 # source module
 source(module_file)
 
 # run module
-l = wrapper (table, columns, settings)
+l <- wrapper(table, columns, settings)
 
 # header
-header_title <- '# title - Chart Utilities (charts)'
-header_date <- paste('# date -', Sys.time(), sep=' ')
-header_module <- paste('# module -', opt$module, sep=' ')
-header_settings <- paste('# settings -', opt$settings, sep=' ')
-header_columns <- paste('# columns -', opt$columns, sep=' ')
+header_title <- "# title - Chart Utilities (charts)"
+header_date <- paste("# date -", Sys.time(), sep = " ")
+header_module <- paste("# module -", opt$module, sep = " ")
+header_settings <- paste("# settings -", opt$settings, sep = " ")
+header_columns <- paste("# columns -", opt$columns, sep = " ")
 
 # check result
 if (length(l) > 0) {
     # print details
     if (!is.null(opt$verbose)) {
-        print ('Columns:')
-        print (columns)
-        print ('Settings:')
-        print (settings)
-        print ('Result:')
-        print (l)
+        print("Columns:")
+        print(columns)
+        print("Settings:")
+        print(settings)
+        print("Result:")
+        print(l)
     }
 
     # create output file
-    output <- file(opt$output, open='wt')
-    
+    output <- file(opt$output, open = "wt")
+
     # write header
-    writeLines('#', output)
+    writeLines("#", output)
     writeLines(header_title, output)
     writeLines(header_date, output)
     writeLines(header_module, output)
     writeLines(header_settings, output)
     writeLines(header_columns, output)
-    writeLines('#', output)
-    
+    writeLines("#", output)
+
     # pad columns
     rows <- max(unlist(lapply(l, length)))
     padded <- lapply(l, function(col) {
-        length(col) = rows;
+        length(col) <- rows;
         col
     })
-    
+
     # write table
-    write.table(padded, file=output, row.names=FALSE, col.names = FALSE, quote=FALSE, sep='\t')
-    
+    write.table(padded, file = output, row.names = FALSE, col.names  =  FALSE, quote = FALSE, sep = "\t")
+
     # close file
     close(output)
 } else {
     # print details
-    print ('Columns:')
-    print (columns)
-    print ('Settings:')
-    print (settings)
-    print ('No output generated.')
+    print("Columns:")
+    print(columns)
+    print("Settings:")
+    print(settings)
+    print("No output generated.")
 }
\ No newline at end of file
--- a/charts.xml	Fri Mar 09 08:23:08 2018 -0500
+++ b/charts.xml	Wed Nov 17 09:06:59 2021 +0000
@@ -52,7 +52,7 @@
             <output name="output" file="histogram.002.txt" lines_diff="2"/>
         </test>
         <test>
-            <param name="input" value="tabular_single.txt" />
+            <param name="input" value="tabular_single.txt" ftype="tabular"/>
             <param name="module" value="histogram" />
             <param name="columns" value="key1: 1" />
             <param name="settings" value="" />
--- a/heatmap.r	Fri Mar 09 08:23:08 2018 -0500
+++ b/heatmap.r	Wed Nov 17 09:06:59 2021 +0000
@@ -1,44 +1,44 @@
 # load sparse matrix package
-suppressPackageStartupMessages(library('Matrix'))
+suppressPackageStartupMessages(library("Matrix"))
 
 # access a numeric column
 get_numeric <- function(table, column_key) {
     column <- as.numeric(column_key)
     column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))
-    return (c(column_data))
+    return(c(column_data))
 }
 
 # access a label column
 get_label <- function(table, column_key) {
     column <- as.numeric(column_key)
     column_data <- as.character(table[column][[1]])
-    return (c(column_data))
+    return(c(column_data))
 }
 
 # inflate three columns into matrix
-matrify <- function (data) {
+matrify <- function(data) {
     if (ncol(data) != 3)
-        stop('Data frame must have three column format')
+        stop("Data frame must have three column format")
     plt <- data[, 1]
     spc <- data[, 2]
     abu <- data[, 3]
-    plt.codes <- levels(factor(plt))
-    spc.codes <- levels(factor(spc))
-    taxa <- Matrix(0, nrow=length(plt.codes), ncol=length(spc.codes), sparse=TRUE)
-    row <- match(plt, plt.codes)
-    col <- match(spc, spc.codes)
-    for (i in 1:length(abu)) {
+    plt_codes <- levels(factor(plt))
+    spc_codes <- levels(factor(spc))
+    taxa <- Matrix(0, nrow = length(plt_codes), ncol = length(spc_codes), sparse = TRUE)
+    row <- match(plt, plt_codes)
+    col <- match(spc, spc_codes)
+    for (i in seq_len(length(abu))) {
         taxa[row[i], col[i]] <- abu[i]
     }
-    colnames(taxa) <- spc.codes
-    rownames(taxa) <- plt.codes
+    colnames(taxa) <- spc_codes
+    rownames(taxa) <- plt_codes
     taxa
 }
 
 # flatten data.frame into three column format
 flatten <- function(my_matrix) {
-    summ <-summary(my_matrix)
-    summ <- data.frame(i=rownames(my_matrix)[summ$i], j=colnames(my_matrix)[summ$j], x=summ$x)
+    summ <- summary(my_matrix)
+    summ <- data.frame(i = rownames(my_matrix)[summ$i], j = colnames(my_matrix)[summ$j], x = summ$x)
     summ
 }
 
@@ -49,49 +49,49 @@
     l <- list()
 
     # get number of columns
-    n = length(columns)
-    
+    n <- length(columns)
+
     # consistency check
     if (n %% 3 != 0) {
-        print ('heatmap::wrapper() - Data not consistent (n mod 3 != 0)')
-        return (l)
+        print("heatmap::wrapper() - Data not consistent (n mod 3 != 0)")
+        return(l)
     }
-    
+
     # create index sequence
-    index = seq(1, n, by=3)
-    
+    index <- seq(1, n, by = 3)
+
     # get keys
-    keys = names(columns)
-    
+    keys <- names(columns)
+
     # loop through blocks
     for (i in index) {
         # create columns
         ci <- get_label(table, columns[keys[i]])
-        cj <- get_label(table, columns[keys[i+1]])
-        cx <- get_numeric(table, columns[keys[i+2]])
-        
+        cj <- get_label(table, columns[keys[i + 1]])
+        cx <- get_numeric(table, columns[keys[i + 2]])
+
         # create a frame from columns
-        my_frame <- data.frame(ci=ci, cj=cj, cx=cx)
-        
+        my_frame <- data.frame(ci = ci, cj = cj, cx = cx)
+
         # create matrix out of the frame
         my_matrix <- matrify(my_frame)
-        
+
         # create/cluster matrix
         row_order <- hclust(dist(my_matrix))$order
         col_order <- hclust(dist(t(my_matrix)))$order
-        
+
         # reorder matrix
         my_matrix <- my_matrix[row_order, col_order]
-        
+
         # transform back to three columns
-        my_flatmatrix = flatten(my_matrix)
-        
+        my_flatmatrix <- flatten(my_matrix)
+
         # append to result list
         l <- append(l, list(my_flatmatrix$i))
         l <- append(l, list(my_flatmatrix$j))
         l <- append(l, list(my_flatmatrix$x))
     }
-    
+
     # return
-    return (l)
+    return(l)
 }
--- a/histogram.r	Fri Mar 09 08:23:08 2018 -0500
+++ b/histogram.r	Wed Nov 17 09:06:59 2021 +0000
@@ -10,36 +10,36 @@
         # load column data
         column <- as.numeric(columns[key])
         column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))
-        
+
         # collect vectors in list
         m <- append(m, list(column_data))
     }
-    
+
     # identify optimal breaks
-    hist_data <- hist(unlist(m), plot=FALSE)
+    hist_data <- hist(unlist(m), plot = FALSE)
     breaks <- hist_data$breaks;
-    
+
     # add as first column
     l <- append(l, list(breaks[2: length(breaks)]))
-    
+
     # loop through all columns
     for (key in seq(m)) {
         # load column data
         column_data <- m[[key]]
-        
+
         # create hist data
-        hist_data <- hist(column_data, breaks=breaks, plot=FALSE)
-        
+        hist_data <- hist(column_data, breaks = breaks, plot = FALSE)
+
         # normalize densities
         count_sum <- sum(hist_data$counts)
         if (count_sum > 0) {
-            hist_data$counts = hist_data$counts / count_sum
+            hist_data$counts <- hist_data$counts / count_sum
         }
-        
+
         # collect vectors in list
         l <- append(l, list(hist_data$counts))
     }
-    
+
     # return
-    return (l)
+    return(l)
 }
--- a/histogramdiscrete.r	Fri Mar 09 08:23:08 2018 -0500
+++ b/histogramdiscrete.r	Wed Nov 17 09:06:59 2021 +0000
@@ -1,3 +1,7 @@
+zero <- function(v) {
+    0
+}
+
 # wrapper
 wrapper <- function(table, columns, options) {
 
@@ -9,46 +13,46 @@
     for (key in names(columns)) {
         # load column data
         column <- as.numeric(columns[key])
-        
+
         # ensure string column
         column_data <- as.character(table[column][[1]])
-    
+
         # collect vectors in list
         m <- append(m, list(column_data))
     }
-    
+
     # get alphabetically sorted bins
     bins <- sort(unique(unlist(m)))
-    
+
     # add first column
     l <- append(l, list(bins))
-    
+
     # loop through all columns
     for (key in seq(m)) {
         # reset bins
-        bins = sapply(bins, function(v) { 0 })
-        
+        bins <- sapply(bins, zero)
+
         # load column data
         column_data <- m[[key]]
-        
+
         # create hist data
         table_data <- table(column_data)
-        
+
         # transfer counts to bins
         for (id in names(table_data)) {
             bins[id] <- table_data[id]
         }
-        
+
         # normalize densities
         total <- length(column_data)
         if (total > 0) {
-            bins = bins / total
+            bins <- bins / total
         }
-        
+
         # collect vectors in list
         l <- append(l, list(bins))
     }
 
     # return
-    return (l)
+    return(l)
 }