Merge pull request #214 from warrenmcg/patch_misc

Miscellaneous bug fixes

Author: pimentel

NAMESPACE

@@ -86,3 +86,4 @@ importFrom(lazyeval,interp)
 importFrom(lazyeval,lazy)
 importFrom(rhdf5,h5write)
 importFrom(rhdf5,h5write.default)
+importFrom(utils,head)

R/kallisto.R

@@ -118,7 +118,7 @@ subset_kallisto.kallisto <- function(obj, target_ids) {
 
   subset_num <- length(unique(target_ids))
   new_obj <- obj
-  new_obj$abundance <- new_obj$abundance[which(new_obj$abundance %in% target_ids), ]
+  new_obj$abundance <- new_obj$abundance[which(new_obj$abundance$target_id %in% target_ids), ]
   new_obj$bootstrap <- lapply(new_obj$bootstrap, function(bs) {
     bs[which(bs$target_id %in% target_ids), ]
   })

R/matrix.R

@@ -29,6 +29,7 @@
 #' @examples
 #' sleuth_matrix <- sleuth_to_matrix(sleuth_obj, 'obs_norm', 'tpm')
 #' head(sleuth_matrix) # look at first 5 transcripts, sorted by name
+#' @importFrom utils head
 #' @export
 sleuth_to_matrix <- function(obj, which_df, which_units) {
   if ( !(which_df %in% c("obs_norm", "obs_raw")) ) {

R/plots.R

@@ -1049,6 +1049,7 @@ plot_transcript_heatmap <- function(obj,
 
   rownames(tabd_df) <- tabd_df$target_id
   tabd_df$target_id <- NULL
+  tabd_df <- tabd_df[transcripts, ]
 
   if (nchar(trans) > 0 && !is.null(trans)) {
     tFunc <- eval(parse(text = trans))
@@ -1075,16 +1076,10 @@ plot_transcript_heatmap <- function(obj,
   colors <- colorRampPalette(c(color_low, color_mid, color_high))(100)
   # the PDF code prevents the heatmap from printing before we modify the plot
   pdf(file = NULL)
-  if (cluster_transcripts) {
-    p <- pheatmap::pheatmap(trans_mat, annotation_col = s2c, color = colors,
-                            cluster_cols = TRUE,
-                            cluster_rows = cluster_transcripts,
-                            ...)
-  } else {
-    p <- pheatmap::pheatmap(trans_mat, annotation_col = s2c, color = colors,
-                            cluster_cols = TRUE,
-                            ...)
-  }
+  p <- pheatmap::pheatmap(trans_mat, annotation_col = s2c, color = colors,
+                          cluster_cols = TRUE,
+                          cluster_rows = cluster_transcripts,
+                          ...)
   invisible(dev.off())
   # modify the column labels with the x_axis_angle
   # subtracting from 360 degrees to get it to align well without modifying

R/read_write.R

@@ -27,7 +27,7 @@
 #' @return a \code{kallisto} object
 #' @export
 read_kallisto <- function(path, read_bootstrap = TRUE, max_bootstrap = NULL) {
-  stopifnot(is(path, "character"))
+  path <- as.character(path)
 
   kal_path <- get_kallisto_path(path)
 
@@ -62,13 +62,36 @@ read_kallisto_h5 <- function(fname, read_bootstrap = TRUE, max_bootstrap = NULL)
     is(max_bootstrap, "numeric") ||
     is(max_bootstrap, "integer") )
 
+  kal_path <- get_kallisto_path(fname)
+  if (kal_path$ext != "h5") {
+    stop(paste0("File '", fname, "' does not appear to be an HDF5 file"))
+  }
+
   fname <- path.expand(fname)
 
   if (!file.exists(fname)) {
     stop("Can't find file: '", fname, "'")
   }
 
-  target_id <- as.character(rhdf5::h5read(fname, "aux/ids"))
+  tryCatch({
+    target_id <- as.character(rhdf5::h5read(fname, "aux/ids"))
+  }, error = function(e) {
+    msg <- conditionMessage(e)
+    err_msg <- paste0("The HDF5 file '", fname, "' exists but could not be ",
+                      "read. The most common reason is that the rdhf5 and ",
+                      "Rhdf5lib were built using bioconda without support ",
+                      "to read zlib-compressed HDF5 files, which is used ",
+                      "by kallisto to save space.\nPlease update R, rdhf5, ",
+                      "and Rhdf5lib to latest versions on bioconda, or ",
+                      "consider doing a Bioconductor installation of ",
+                      "Rhdf5lib, which usually automatically includes zlib ",
+                      "support.")
+    err_msg <- paste0(err_msg, "\nThe actual error thrown was '", msg, "'")
+    stop(err_msg)
+  }, finally = {
+    rhdf5::H5close()
+  })
+
   if ( length(target_id) != length(unique(target_id))) {
     tid_counts <- table(target_id)
     warning(

R/shiny.R

@@ -140,7 +140,7 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
                                    'enter a gene identifier that matches that column.',
                                    'The most significant gene by q-value for the first test within the currently selected test type is already entered.");',
                                    '} </script>'),
-                      value = textOutput("default_top_hit"))
+                      value = '')
             ),
             column(3,
                    selectInput('bsg_var_color_by',
@@ -277,7 +277,7 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
             'alert("Enter a space-separated list of transcript names here to view a hierarchical clustering of those transcripts.",
                    "The ten most significant transcripts for the first test of the currently selected test type have been listed for you by default.");',
             '} </script>'),
-            value = textOutput("default_top_ten"))
+            value = '')
               ),
           column(8, style = "margin-top:15px;",
             checkboxGroupInput('hm_covars',
@@ -458,7 +458,10 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
               uiOutput('group_by_lrt')
               )
             ),
-          dataTableOutput('lrt_de_dt')
+            dataTableOutput('lrt_de_dt'),
+            fluidRow(
+              div(align = "right", style = "margin-right:15px; margin-bottom:10px",
+                  downloadButton("download_test_table",  "Download Table")))
           )
         ),
 
@@ -782,7 +785,10 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
         ),
         fluidRow(
           plotOutput('fld_plt')
-          )
+          ),
+        fluidRow(
+          div(align = "right", style = "margin-right:15px; margin-bottom: 10px",
+            downloadButton("download_fld_plt", "Download Table")))
       ),
 
       ####
@@ -1044,7 +1050,8 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
       sample_table = NULL,
       kallisto_table = NULL,
       hm_plt = NULL,
-      bs_var_plt = NULL
+      bs_var_plt = NULL,
+      fld_plt = NULL
       )
     user_settings <- reactiveValues(save_width = 45, save_height = 11)
     # TODO: Once user settings are available, read these values from input
@@ -1065,29 +1072,112 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
       current_ui
     })
 
-    output$default_top_hit <- renderText({
-      default_test <- ifelse(length(valid_test_types) == 0, NULL,
-                             ifelse(input$settings_test_type == 'wt',
-                                    obj$tests[['wt']][[1]][[1]],
-                                    obj$tests[['lrt']][[1]])
-                            )
+    ### CODE TO FILL IN DEFAULT VALUES FOR TEXT BOXES
+    defaults <- reactiveValues(
+      top_hit = '',
+      top_gene = '',
+      top_ten = ''
+    )
+
+    ## Observe to see if the test type changes
+    ## Pick the top transcript for the first test of that type
+    observe({
+      test_type <- input$settings_test_type
+      default_test <- if (length(valid_test_types) == 0) {
+        NULL
+      } else if (test_type == "wt") {
+        obj$tests[["wt"]][[1]][[1]]
+      } else {
+        obj$tests[["lrt"]][[1]]
+      }
+
+      default_id <- ifelse(is.null(default_test), "No tests found. This feature won't work",
+        default_test[order(default_test$qval), "target_id"][1])
+      defaults$top_hit <- default_id
+    })
+
+    ## Observe to see if the test type changes
+    ## Pick the top 10 hits for the first test of that type
+    observe({
+      test_type <- input$settings_test_type
+      default_test <- if (length(valid_test_types) == 0) {
+        NULL
+      } else if (test_type == "wt") {
+        obj$tests[["wt"]][[1]][[1]]
+      } else {
+        obj$tests[["lrt"]][[1]]
+      }
+
+      default_ids <- if (is.null(default_test)) {
+        c("No tests found. This feature won't work")
+      } else {
+        default_test[order(default_test$qval), "target_id"][1:10]
+      }
+
+      defaults$top_ten <- paste(default_ids, collapse = " ")
+    })
+
+    ## Observe to see if the test type changes or the gene column changes
+    ## Pick the gene with the most significant transcript for the first test of that type
+    observe({
+      gene_col <- input$gv_gene_colname
+      test_type <- input$settings_test_type
+      default_test <- if (length(valid_test_types) == 0) {
+        NULL
+      } else if (test_type == "wt") {
+        obj$tests[["wt"]][[1]][[1]]
+      } else {
+        obj$tests[["lrt"]][[1]]
+      }
       default_id <- ifelse(is.null(default_test), "No tests found. This feature won't work",
-                            default_test[order(default_test$qval), "target_id"][1])
-      default_id
+        default_test[order(default_test$qval), "target_id"][1])
+      id_row <- which(obj$target_mapping$target_id == default_id)
+      defaults$top_gene <- obj$target_mapping[id_row, gene_col]
+    })
+
+    ## Check if the transcript input is empty or invalid
+    ## Fill in with default value if either of above are true
+    observe({
+      var_input <- input$bs_var_input
+      if (is.null(var_input) || !var_input %in% obj$target_mapping$target_id) {
+        updateTextInput(session, "bs_var_input", value = defaults$top_hit)
+      }
+    })
+
+    ## Check if the gene input is empty or invalid
+    ## Fill in with default value if either of above are true
+    observe({
+      var_input <- input$bsg_var_input
+      gene_col <- obj$gene_column
+      genes <- obj$target_mapping[, gene_col]
+      if (is.null(genes)) {
+        updateTextInput(session, "bsg_var_input", value = "This won't work")
+      } else if (is.null(var_input) || !var_input %in% genes) {
+        updateTextInput(session, "bsg_var_input", value = defaults$top_hit)
+      }
     })
 
-    output$default_top_ten <- renderText({
-      default_test <- ifelse(length(valid_test_types) == 0, NULL,
-                             ifelse(input$settings_test_type == 'wt',
-                                    obj$tests[['wt']][[1]][[1]],
-                                    obj$tests[['lrt']][[1]])
-                            )
-      default_ids <- ifelse(is.null(default_test), "No tests found. This feature won't work",
-                            default_test[order(default_test$qval), "target_id"][1:10])
-      default_ids <- paste(default_ids, collapse = " ")
-      default_ids
+    ## Check if the gene input is empty or invalid
+    ## Fill in with default value if either of above are true
+    observe({
+      var_input <- input$gv_var_input
+      gene_col <- input$gene_col
+      genes <- obj$target_mapping[, gene_col]
+      if (is.null(var_input) || !var_input %in% genes) {
+        updateTextInput(session, "gv_var_input", value = defaults$top_gene)
+      }
     })
 
+    ## Check if the list of inputs is empty
+    ## Fill in with default top 10 if either of above are true
+    observe({
+      hm_input <- input$hm_transcripts
+      if (is.null(hm_input) || hm_input == "") {
+        updateTextInput(session, "hm_transcripts", value = defaults$top_ten)
+      }
+    })
+    ### END OF CODE FOR DEFAULT VALUES
+
     output$qqplot <- renderPlot({
       poss_tests <- list_tests(obj, input$settings_test_type)
       current_test <- NULL
@@ -1378,6 +1468,19 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
 
     output$fld_plt <- renderPlot({
       plot_fld(obj, input$fld_sample)
+      #saved_plots_and_tables$fld_plt <- plot_fld(obj, input$fld_sample)
+      #saved_plots_and_tables$fld_plt
+    })
+
+    output$download_fld_plt <- downloadHandler(
+      filename = function() {
+        "fld_plot.pdf"
+        },
+      content = function(file) {
+         ggsave(file, saved_plots_and_tables$fld_plt,
+           width = user_settings$save_width,
+           height = user_settings$save_height,
+           units = "cm")
     })
 
     output$bias_weights_table <- renderDataTable({
@@ -1700,7 +1803,7 @@ sleuth_live <- function(obj, settings = sleuth_live_settings(),
                                           'You can find target_ids in the test table under Analyses. The most significant transcript',
                                           'by q-value for the first test within the currently selected test type is already entered.");',
                                           '} </script>'),
-                             value = textOutput("default_top_hit"))
+                             value = '')
             ),
             column(4,
                    selectInput('bs_var_color_by',

R/sleuth.R

@@ -121,7 +121,7 @@ filter_df_by_groups <- function(df, fun, group_df, ...) {
 #'   \itemize{
 #'     \item \code{filter_fun}: the function to use when filtering. This function will be applied to the raw counts
 #'     on a row-wise basis, meaning that each feature will be considered individually. The default is to filter out
-#'     any features that do not have at least 5 estimated counts in at least 47% of the samples (see \code{\link{basic_filter}}
+#'     any features that do not have at least 5 estimated counts in at least 47\% of the samples (see \code{\link{basic_filter}}
 #'     for more information). If the preferred filtering method requires a matrix-wide transformation or otherwise
 #'     needs to consider multiple features simultaneously instead of independently, please consider using
 #'     \code{filter_target_id} below.
@@ -1095,6 +1095,7 @@ summary.sleuth <- function(obj, covariates = TRUE) {
 #'                                   which_group = 'ext_gene')
 #' head(sleuth_genes) # show info for first 5 genes
 #' sleuth_genes[1:5, 6] # show transcripts for first 5 genes
+#' @importFrom utils head
 #' @export
 sleuth_gene_table <- function(obj, test, test_type = 'lrt', which_model = 'full', which_group = 'ens_gene') {