diff --git a/DESCRIPTION b/DESCRIPTION index b658d2c..e200cc1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: wilson Type: Package Title: Web-Based Interactive Omics Visualization -Version: 2.2.1 +Version: 2.3.0 Authors@R: c( person("Hendrik", "Schultheis", email = "hendrik.schultheis@mpi-bn.mpg.de", role = c("aut", "cre")), person("Jens", "Preussner", email = "jens.preussner@mpi-bn.mpg.de", role = "aut"), @@ -45,11 +45,14 @@ Imports: shiny, log4r, openssl, methods, - R6 + R6, + magrittr RoxygenNote: 6.1.1 biocViews: Suggests: knitr, rmarkdown, testthat, - vdiffr + vdiffr, + i2dash, + stringi VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 8db88f5..df42e3b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,10 +15,12 @@ export(featureSelector) export(featureSelectorUI) export(geneView) export(geneViewUI) +export(geneview_to_i2dash) export(global_cor_heatmap) export(global_cor_heatmapUI) export(heatmap) export(heatmapUI) +export(heatmap_to_i2dash) export(label) export(labelUI) export(limit) @@ -35,9 +37,11 @@ export(pca) export(pcaUI) export(scatterPlot) export(scatterPlotUI) +export(scatterplot_to_i2dash) export(set_logger) export(tobias_parser) export(transformation) export(transformationUI) import(data.table) importFrom(R6,R6Class) +importFrom(magrittr,"%<>%") diff --git a/NEWS.md b/NEWS.md index 145e2f8..db5f0da 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# wilson 2.3.0 +- implemented: + - heatmap_to_i2dash + - geneView_to_i2dash + - scatterplot_to_i2dash # wilson 2.2.1 - fixed orTextual selection bug # wilson 2.2.0 diff --git a/R/i2dash.R b/R/i2dash.R new file mode 100644 index 0000000..2b7a1e7 --- /dev/null +++ b/R/i2dash.R @@ -0,0 +1,202 @@ +#' Prepare a heatmap to be rendered with the i2dash package. +#' +#' @param object A \linkS4class{i2dash::i2dashboard} object. +#' @param countTable A matrix with features as rows and observations as columns. The rownames and columnnames should be provided and are used in building the heatmap. +#' @param group_by A vector with numerical values or a named list will be mapped to the y-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list. +#' @param title (Optional) The title of the components chunk. +#' @param ... Further parameters which are compatible with wilsons create_heatmap() method. See \code{\link{create_heatmap}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @importFrom magrittr %<>% +#' @export +heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE) || + !requireNamespace("stringi", quietly = TRUE) || + !requireNamespace("magrittr", quietly = TRUE)) { + stop("Packages i2dash, stringi & magrittr are needed to use this function. Please install those.") + } + + # Create env id + id <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") + env_id <- paste0("env_", id) + + # Create list if element is not a list already + if (!is.list(group_by)) group_by <- list(group_by) + + # Name the lists + if (is.null(names(group_by))) group_by %<>% magrittr::set_names("grouping") + + # Validate input + if ((!is.matrix(countTable) & !is.data.frame(countTable))) stop("'countTable' should be a class of 'matrix' or 'data.frame'.") + + # Check, if lengths in a list are the same and if x and y and label and color_by are the same length + if (length(unique(sapply(group_by, length))) != 1) stop("The list 'group_by' should contain elements with the same length.") + + if (!identical(ncol(countTable), length(group_by[[1]])) & !is.null(expression)) stop("The number of columns in 'countTable' should be equal to the length of the vector 'group_by'.") + + additional_arguments <- list(...) + if ("data" %in% names(additional_arguments)) warning("The parameters 'countTable' and 'group_by' will be used instead of 'data.table'") + valid_arguments <- names(as.list(args(create_scatterplot))) + invalid_args <- setdiff(names(additional_arguments), valid_arguments) + if (length(invalid_args) != 0) stop(paste0(" The following parameter is not a valid parameter of 'Wilson::create_heatmap': ", invalid_args)) + + # Create component environment + env <- new.env() + env$countTable <- countTable + env$group_by_selection <- FALSE + + env$group_by <- group_by + env$group_by_selection <- length(env$group_by) > 1 + + env$additional_arguments <- additional_arguments + + # Save environment object + saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) + + # Expand component + timestamp <- Sys.time() + expanded_component <- knitr::knit_expand(file = system.file("templates", "heatmap_wilson.Rmd", package = "wilson"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} + +#' Prepare a geneview to be rendered with the i2dash package. +#' +#' @param object A \linkS4class{i2dash::i2dashboard} object. +#' @param countTable A matrix with features as rows and observations as columns. The rownames and columnnames should be provided and are used in buiding the heatmap. +#' @param group_by A vector with values or a named list will be mapped to the y-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list. +#' @param title (Optional) The title of the components chunk. +#' @param ... Further parameters which are compatible with wilsons create_geneview() method. See \code{\link{create_geneview}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @importFrom magrittr %<>% +#' @export +geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE) || + !requireNamespace("stringi", quietly = TRUE) || + !requireNamespace("magrittr", quietly = TRUE)) { + stop("Packages i2dash, stringi & magrittr are needed to use this function. Please install those.") + } + + # Create env id + id <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") + env_id <- paste0("env_", id) + + # Create list if element is not a list already + if (!is.list(group_by)) group_by <- list(group_by) + + # Name the lists + if (is.null(names(group_by))) group_by %<>% magrittr::set_names("grouping") + + # Validate input + if (length(unique(sapply(group_by, length))) != 1) stop("The list 'group_by' should contain elements with the same length.") + if (!identical(ncol(countTable), length(group_by[[1]])) & !is.null(expression)) stop("The number of columns in 'countTable' should be equal to the length of the vector 'group_by'.") + + additional_arguments <- list(...) + if ("data" %in% names(additional_arguments)) warning("The parameter 'countTable' will be used instead of 'data'") + if ("grouping" %in% names(additional_arguments)) warning("The parameter 'group_by' will be used instead of 'grouping'") + valid_arguments <- names(as.list(args(create_scatterplot))) + invalid_args <- setdiff(names(additional_arguments), valid_arguments) + if (length(invalid_args) != 0) stop(paste0(" The following parameter is not a valid parameter of 'Wilson::create_scatterplot': ", invalid_args)) + + # Create component environment + env <- new.env() + env$countTable <- countTable + env$group_by_selection <- FALSE + + env$group_by <- group_by + env$group_by_selection <- length(env$group_by) > 1 + + env$additional_arguments <- additional_arguments + + # Save environment object + saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) + + # Expand component + timestamp <- Sys.time() + expanded_component <- knitr::knit_expand(file = system.file("templates", "geneView_wilson.Rmd", package = "wilson"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} + +#' Prepare a scatterplot to be rendered with the i2dash package. +#' +#' @param object A \linkS4class{i2dash::i2dashboard} object. +#' @param x A vector with numerical values or a named list will be mapped to the x-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list. +#' @param y A vector with numerical values or a named list will be mapped to the y-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list. +#' @param colour_by (Optional) A vector with factorial (= categorical coloring), numerical (= sequential colouring; can be forced to use categorical colouring by providing the parameter '"categorized" = TRUE') or character (= categorical colouring) values or a named list that will be used for colouring. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of the vector should be of the same length as x and y as well as the length of all vectors in case of a named list. +#' @param expression (Optional) A matrix or dataframe with the same length of columns as 'x'. The sequence and number of the columns should be equal to the sequence and length of 'x'. The rownames represent the feature i.e. gene names and the values represent the expression level. Note: This feature is not compatible with the statical mode (parameter '"interactive" = TRUE'). Alternatively you can provide a vector as colour_by. +#' @param title (Optional) The title of the components chunk. +#' @param ... Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link{create_scatterplot}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @importFrom magrittr %<>% +#' @export +scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = NULL, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE) || + !requireNamespace("stringi", quietly = TRUE) || + !requireNamespace("magrittr", quietly = TRUE)) { + stop("Packages i2dash, stringi & magrittr are needed to use this function. Please install those.") + } + + # Create env id + id <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") + env_id <- paste0("env_", id) + + # Create list if element is not a list already + if (!is.list(x)) x <- list(x) + if (!is.list(y)) y <- list(y) + if (!is.list(colour_by) & !is.null(colour_by)) colour_by <- list(colour_by) + + # Name the lists + if (is.null(names(x))) x %<>% magrittr::set_names("x") + if (is.null(names(y))) y %<>% magrittr::set_names("y") + if (is.null(names(colour_by)) & !is.null(colour_by)) colour_by %<>% magrittr::set_names("colour") + + # Validate input + if (!all(sapply(x, is.numeric))) stop("'x' should only contain numerical values.") + if (!all(sapply(y, is.numeric))) stop("'y' should only contain numerical values.") + if ((!is.matrix(expression) & !is.data.frame(expression)) & !is.null(expression)) stop("'expression' should be a class of 'matrix' or 'data.frame'.") + + # Check, if lengths in a list are the same and if x and y and label and color_by are the same length + if (length(unique(sapply(x, length))) != 1) stop("The list 'x' should contain elements with the same length.") + if (length(unique(sapply(y, length))) != 1) stop("The list 'y' should contain elements with the same length.") + if (length(unique(sapply(colour_by, length))) != 1 & !is.null(colour_by)) stop("The list 'colour_by' should contain elements with the same length.") + + if (!identical(length(x[[1]]), length(y[[1]]))) stop("All arguments should be of the the same length.") + if (!identical(length(x[[1]]), length(colour_by[[1]])) & !is.null(colour_by)) stop("All arguments should be of the the same length.") + if (!identical(ncol(expression), length(x[[1]])) & !is.null(expression)) stop("The number of columns in 'expression' should be equal to the length of the vector 'x'.") + + additional_arguments <- list(...) + if ("data" %in% names(additional_arguments)) warning("The parameters 'x' and 'y' will be used instead of 'data.table'") + if ("plot.method" %in% names(additional_arguments)) warning("This parameter will be ignored and 'plot.method' = 'interactive' will be used.") + valid_arguments <- names(as.list(args(create_scatterplot))) + invalid_args <- setdiff(names(additional_arguments), valid_arguments) + if (length(invalid_args) != 0) stop(paste0(" The following parameter is not a valid parameter of 'Wilson::create_scatterplot': ", invalid_args)) + + # Create component environment + env <- new.env() + + env$x_selection <- F + env$y_selection <- F + env$colour_by_selection <- F + + env$x <- x + env$x_selection <- length(env$x) > 1 + + env$y <- y + env$y_selection <- length(env$y) > 1 + + env$colour_by <- colour_by + env$colour_by_selection <- length(env$colour_by) > 1 + + env$expression <- expression + + env$additional_arguments <- additional_arguments + + # Save environment object + saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) + + # Expand component + timestamp <- Sys.time() + expanded_component <- knitr::knit_expand(file = system.file("templates", "scatterplot_wilson.Rmd", package = "wilson"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} diff --git a/inst/templates/geneView_wilson.Rmd b/inst/templates/geneView_wilson.Rmd new file mode 100644 index 0000000..50e3c78 --- /dev/null +++ b/inst/templates/geneView_wilson.Rmd @@ -0,0 +1,186 @@ + +### {{ title }} + + + +```{r} +{{ env_id }} = readRDS("envs/{{ env_id }}.rds") + +is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") +``` + +```{r, eval=!is_shiny} +# Parameters for wilson::create_geneview() +# params <- list() +"%ni%" <- Negate("%in%") +additional_arguments <- {{ env_id }}$additional_arguments + +if("plot.type" %ni% names({{ env_id }}$additional_arguments)){ + additional_arguments$plot.type <- "line" +} +if("facet.target" %ni% names({{ env_id }}$additional_arguments)){ + additional_arguments$facet.target <- "gene" +} +if("facet.cols" %ni% names({{ env_id }}$additional_arguments)){ + additional_arguments$facet.cols <- 3 +} +if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(8, "Accent") + additional_arguments$color <- color +} + +# force static +additional_arguments$plot.method <- "static" + +# set variables +countTable <- {{ env_id }}$countTable +group_by <- {{ env_id }}$group_by[1] + +# create data.tables "data" and "grouping" from provided data +data <- data.table::data.table("features" = rownames(countTable), countTable) +grouping <- data.table::data.table("keys" = colnames(countTable), "factor" = group_by[[1]]) + +additional_arguments$data <- data +additional_arguments$grouping <- grouping + +# Provide data for download +#i2dash::embed_var(data) + +# Render plot +output_list <- do.call(wilson::create_geneview, additional_arguments) +plot <- output_list$plot +plot +``` + +```{r, eval=is_shiny} +######### +library(shinyWidgets) +############# + +ui_list <- list() + +# select type of plot +ui_list <- rlist::list.append(ui_list, + selectInput("select_type_{{ env_id }}", label = "Type of Plot:", + choices = c("line", "box", "violin", "bar"), selected = "line")) + +# subset features +ui_list <- rlist::list.append(ui_list, + selectInput("select_subset_{{ env_id }}", + label = "Select features:", + choices = rownames({{ env_id }}$countTable), + multiple = TRUE) + ) + +# selection field for group_by +if ({{ env_id }}$group_by_selection){ + ui_list <- rlist::list.append(ui_list, + selectInput("select_group_by_{{ env_id }}", label = "Select grouping:", + choices = names({{ env_id }}$group_by))) +} +# selection grouping by +ui_list <- rlist::list.append(ui_list, + selectInput("select_by_{{ env_id }}", + label = "Grouping by:", + choices = c("gene", "condition"), + selected = "gene", + multiple = FALSE) + ) +# selection column number of plot +ui_list <- rlist::list.append(ui_list, + sliderInput("colnumber_{{ env_id }}", label = h3("Plot columns:"), min = 1, max = 7, value = 3) + ) + +# Download link +ui_list <- rlist::list.append(ui_list, tags$div(tags$br(), downloadButton('downloadData_{{ env_id }}', 'Download data'))) + +# +# Create reactive data table +# +df_{{ env_id }} <- shiny::reactive({ + + # Parameters for wilson::create_geneview() + # params <- list() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # type of plot + additional_arguments$plot.type <- input$select_type_{{ env_id }} + + # type of grouping by + additional_arguments$facet.target <- input$select_by_{{ env_id }} + + # number of columns in plot + additional_arguments$facet.cols <- input$colnumber_{{ env_id }} + + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(8, "Accent") + additional_arguments$color <- color + } + + # force static + additional_arguments$plot.method <- "static" + + # Set values for 'group_by' + if( !{{ env_id }}$group_by_selection ) { + group_by <- {{ env_id }}$group_by[1] + } else { + group_by <- {{ env_id }}$group_by[input$select_group_by_{{ env_id }}] + } + + # subset countTable by chosen features + countTable <- {{ env_id }}$countTable + + if(!is.null(input$select_subset_{{ env_id }})){ + subset_features <- input$select_subset_{{ env_id }} + if(length(subset_features) > 1){ + countTable <- countTable[subset_features,] + } else if(length(subset_features) == 1){ + countTable <- countTable[subset_features,,drop = FALSE] + } + } + + # create data.tables "data" and "grouping" from provided data + data <- data.table::data.table("features" = rownames(countTable), countTable) + grouping <- data.table::data.table("keys" = colnames(countTable), "factor" = group_by[[1]]) + + additional_arguments$data <- data + additional_arguments$grouping <- grouping + return(list("params" = additional_arguments, "data" = data, "grouping" = grouping)) +}) + +# +# Download +# +############ +# To do: provide both data.frames for download +output$downloadData_{{ env_id }} <- downloadHandler( + filename = paste('data-', Sys.Date(), '.csv', sep=''), + content = function(file) { + write.csv(df_{{ env_id }}()$data, file) + } +) + +# +# Output +# +output$plot_{{ env_id }} <- shiny::renderPlot({ + if(!is.null(input$select_subset_{{ env_id }})){ + output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) + plot <- output_list$plot + plot + } + # convert to plotly object for automatic resizing + +}) + +# +# Layout of component +# +shiny::fillRow(flex = c(NA, 1), + dropdownButton(do.call(shiny::inputPanel, ui_list), + circle = TRUE, status = "danger", icon = icon("gear"), width = "300px", + tooltip = tooltipOptions(title = "Click, to change plot settings:")), + plotOutput("plot_{{ env_id }}") +) +``` diff --git a/inst/templates/heatmap_wilson.Rmd b/inst/templates/heatmap_wilson.Rmd new file mode 100644 index 0000000..2947045 --- /dev/null +++ b/inst/templates/heatmap_wilson.Rmd @@ -0,0 +1,257 @@ + +### {{ title }} + + + +```{r} +{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") + +is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") +``` + +```{r} +###### +library(magrittr) +library(shinyWidgets) +##### +# +# Method for creating a data.table required by create_heatmap() method from wilson. +# +create_data.table <- function(matrix, group_by){ + # validate input + if(ncol(matrix) != length(group_by)) stop("The length of the vector 'group_by' should be of the same length as the column number of 'matrix'.") + # create data.table + dt <- data.table::data.table(t(matrix)) + dt[, cell := dimnames(matrix)[2]] + dt[, grouping := group_by] + # Melt + dt <- data.table::melt(dt, id.vars = c('cell', 'grouping'), variable.name='gene') + # Aggregate + dt2 <- dt[, .(meanvalue = mean(value)), by = c('grouping', 'gene')] + # Cast + dt3 <- dt2 %>% data.table::dcast(gene ~ grouping, value.var = 'meanvalue') + # change categorical 'gene' column to character + dt3[[1]] <- as.character(dt3[[1]]) + return(dt3) +} +``` + + +```{r, eval=!is_shiny} +# Parameters for wilson::create_scatterplot +"%ni%" <- Negate("%in%") +additional_arguments <- {{ env_id }}$additional_arguments + +if("clustering" %ni% names({{ env_id }}$additional_arguments)){ + additional_arguments$clustering <- "none" +} +if("clustdist" %ni% names({{ env_id }}$additional_arguments)){ + additional_arguments$clustdist <- "euclidean" +} +if("clustmethod" %ni% names({{ env_id }}$additional_arguments)){ + additional_arguments$clustmethod <- "average" +} +additional_arguments$plot.method <- "interactive" + +if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color +} +# set variables +countTable <- {{ env_id }}$countTable +group_by <- {{ env_id }}$group_by[1] + + # create data.table +dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) +additional_arguments$data <- dt + +# Provide data for download +i2dash::embed_var(dt) + +# Render plot +output_list <- do.call(wilson::create_heatmap, additional_arguments) +heatmap <- output_list$plot +# reset the width and hight of the plotly object for automatic scaling +heatmap$x$layout$height <- 0 +heatmap$x$layout$width <- 0 +heatmap +``` + +```{r, eval=is_shiny} +ui_list <- list() + +# selection field for group_by +if ({{ env_id }}$group_by_selection){ + ui_list <- rlist::list.append(ui_list, + selectInput("select_group_by_{{ env_id }}", label = "Select grouping:", + choices = names({{ env_id }}$group_by))) +} +# subset the genes +# ui_list <- rlist::list.append(ui_list, +# pickerInput( +# inputId = "select_subset_{{ env_id }}", +# label = "Select features:", +# choices = rownames({{ env_id }}$countTable), +# options = list(`actions-box` = TRUE), +# multiple = TRUE) +# ) +# subset the genes +ui_list <- rlist::list.append(ui_list, + selectInput("select_subset_{{ env_id }}", + label = "Select features:", + choices = rownames({{ env_id }}$countTable), + multiple = TRUE) + ) +# select columns +ui_list <- rlist::list.append(ui_list, + uiOutput("select_columns_{{ env_id }}") + ) + + +# select clustering +ui_list <- rlist::list.append(ui_list, + selectInput("select_clustering_{{ env_id }}", + label = "Select clustering:", + choices = c("no clustering" = "none", "columns and rows" = "both", "only columns" = "column", "only rows" = "row"), + multiple = FALSE) + ) +# select clustering distance +ui_list <- rlist::list.append(ui_list, + selectInput("select_clustdist_{{ env_id }}", + label = "Cluster distance:", + choices = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "pearson", "spearman", "kendall"), + multiple = FALSE) + ) +# select clustering method +ui_list <- rlist::list.append(ui_list, + selectInput("select_clustmethod_{{ env_id }}", + label = "Cluster method:", + choices = c("average", "ward.D", "ward.D2", "single", "complete", "mcquitty"), + multiple = FALSE) + ) + + + +# Download link +ui_list <- rlist::list.append(ui_list, tags$div(tags$br(), downloadButton('downloadData_{{ env_id }}', 'Download data'))) + +# create dynamic uiElement +output$select_columns_{{ env_id }} <- renderUI({ + # if (is.null(input$select_group_by_{{ env_id }})) + # return() + # ui_list <- rlist::list.append(ui_list, selectInput("select_col_dyn_{{ env_id }}", + # label = "Select columns:", + # choices = unique({{ env_id }}$group_by[[input$select_group_by_{{ env_id }}]]), + # multiple = TRUE) + # ) + selectInput("select_col_dyn_{{ env_id }}", + label = "Select columns:", + choices = unique({{ env_id }}$group_by[[input$select_group_by_{{ env_id }}]]), + multiple = TRUE) + +}) + + + +# +# Create reactive data table +# +df_{{ env_id }} <- shiny::reactive({ + #print(unique({{ env_id }}$group_by[[input$select_group_by_{{ env_id }}]])) + # Parameters for wilson::create_scatterplot + # params <- list() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # "static" not possible yet + additional_arguments$plot.method <- "interactive" + + # Set values for 'countTable' + countTable <- {{ env_id }}$countTable + + # Set values for 'group_by' + if( !{{ env_id }}$group_by_selection ) { + group_by <- {{ env_id }}$group_by[1] + } else { + group_by <- {{ env_id }}$group_by[input$select_group_by_{{ env_id }}] + } + + # subset countTable by chosen features + if(!is.null(input$select_subset_{{ env_id }})){ + subset_features <- input$select_subset_{{ env_id }} + if(length(subset_features) > 1){ + countTable <- countTable[subset_features,] + } else if(length(subset_features) == 1){ + countTable <- countTable[subset_features,,drop = FALSE] + } + } + # subset group_by by chosen grouping + if(!is.null(input$select_subset_{{ env_id }})){ + subset_features <- input$select_subset_{{ env_id }} + if(length(subset_features) > 1){ + countTable <- countTable[subset_features,] + } else if(length(subset_features) == 1){ + countTable <- countTable[subset_features,,drop = FALSE] + } + } + + # create data.table + dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) + #print(dt) + + # subset group_by by chosen grouping + if(!is.null(input$select_col_dyn_{{ env_id }})){ + column_vector <- c(c("gene"), input$select_col_dyn_{{ env_id }}) + dt <- dt[,..column_vector,] + } + + + # sequential (one-sided) color palette + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color + } + additional_arguments$plot.method <- "interactive" + additional_arguments$data <- dt + + # add clustering parameters + additional_arguments$clustering <- input$select_clustering_{{ env_id }} + additional_arguments$clustdist <- input$select_clustdist_{{ env_id }} + additional_arguments$clustmethod <- input$select_clustmethod_{{ env_id }} + + return(list("params" = additional_arguments, "data" = dt)) +}) + +# +# Download +# +output$downloadData_{{ env_id }} <- downloadHandler( + filename = paste('data-', Sys.Date(), '.csv', sep=''), + content = function(file) { + write.csv(df_{{ env_id }}()$data, file) + } +) + +# +# Output +# +output$plot_{{ env_id }} <- plotly::renderPlotly({ + output_list <- do.call(wilson::create_heatmap, df_{{ env_id }}()$params) + heatmap <- output_list$plot + # reset the width and hight of the plotly object for automatic scaling + heatmap$x$layout$height <- 0 + heatmap$x$layout$width <- 0 + heatmap +}) + +# +# Layout of component +# +shiny::fillRow(flex = c(NA, 1), + dropdownButton(div(style='max-height: 350px; overflow-x: auto;',do.call(shiny::inputPanel, ui_list)), + circle = TRUE, status = "danger", icon = icon("gear"), width = "300px", + tooltip = tooltipOptions(title = "Click, to change plot settings:")), + plotly::plotlyOutput("plot_{{ env_id }}", width = "100%", height = "400px") +) +``` + diff --git a/inst/templates/scatterplot_wilson.Rmd b/inst/templates/scatterplot_wilson.Rmd new file mode 100644 index 0000000..1f0f3cf --- /dev/null +++ b/inst/templates/scatterplot_wilson.Rmd @@ -0,0 +1,271 @@ + +### {{ title }} + + + +```{r} +{{ env_id }} = readRDS("envs/{{ env_id }}.rds") + +is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") +``` + +```{r, eval=!is_shiny} +# Parameters for wilson::create_scatterplot +"%ni%" <- Negate("%in%") +additional_arguments <- {{ env_id }}$additional_arguments + +# force interctive parameter +additional_arguments$plot.method <- "interactive" + +if("density" %ni% names(additional_arguments)){ + additional_arguments$density <- F +} +if("line" %ni% names(additional_arguments)){ + additional_arguments$line <- F +} +if("categorized" %ni% names(additional_arguments)){ + additional_arguments$categorized <- F +} +# Set values for 'x' +x <- {{ env_id }}$x[1] + +# Set values for 'y' +y <- {{ env_id }}$y[1] + +# Set values for 'colour_by' +if (!is.null({{ env_id }}$colour_by)){ + colour_by <- {{ env_id }}$colour_by[1] +} + +# Set values for id' +id <- c(1:length(x[[1]])) + +# Create a data.frame +df <- data.frame(id, x, y) + +# if colour_by provided +if(!is.null({{ env_id }}$colour_by)){ + df["colour_by"] <- colour_by + # if colour_by is character + if(is.character(df[["colour_by"]])){ + additional_arguments$categorized <- T + # if colour_by is factor + } else if (is.factor(df[["colour_by"]])){ + additional_arguments$categorized <- T + df["colour_by"] <- droplevels(df["colour_by"]) + # if colour_by is numeric + } else if (is.numeric(df[["colour_by"]])){ + if("categorized" %in% names({{ env_id }}$additional_arguments)){ + additional_arguments$categorized <- {{ env_id }}$additional_arguments$categorized + } + } +} + +# color +if(additional_arguments$categorized){ + # categorical (qualitative) color palettes + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(8, "Accent") + additional_arguments$color <- color + } +} else { + # sequential (one-sided) color palettes + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color + } +} + +# Create data.table from data.frame +dt <- data.table::setDT(df) +additional_arguments$data <- dt + +# Provide data for download +i2dash::embed_var(dt) + +# Render plot +output_list <- do.call(wilson::create_scatterplot, additional_arguments) +gg <- output_list$plot +gg$x$layout$height <- 0 +gg$x$layout$width <- 0 + +gg +# convert to plotly object for automatic resizing +#plotly::ggplotly(gg) +``` + +```{r, eval=is_shiny} +ui_list <- list() +# selection field for x +if ({{ env_id }}$x_selection){ + ui_list <- rlist::list.append(ui_list, + selectInput("select_x_{{ env_id }}", label = "Select data for x axis:", + choices = names({{ env_id }}$x))) +} + +# selection field for y +if ({{ env_id }}$y_selection){ + ui_list <- rlist::list.append(ui_list, + selectInput("select_y_{{ env_id }}", label = "Select data for y axis:", + choices = names({{ env_id }}$y))) +} + +# selection field for colour_by +if ({{ env_id }}$colour_by_selection){ + ui_list <- rlist::list.append(ui_list, + selectInput("select_colour_{{ env_id }}", label = "Select colouring:", + choices = names({{ env_id }}$colour_by))) +} + +# Checkbox and selection field for colour by feature +if (!is.null({{ env_id }}$expression)) { + ui_list <- rlist::list.append(ui_list, + tags$div(checkboxInput("expr_checkbox_{{ env_id }}", label = "Colour by feature", value = FALSE), + selectInput("select_feature_{{ env_id }}", label = NULL, choices = rownames({{ env_id }}$expression)) + )) +} + +# Download link +ui_list <- rlist::list.append(ui_list, tags$div(tags$br(), downloadButton('downloadData_{{ env_id }}', 'Download data'))) + +# +# Create reactive data table +# +df_{{ env_id }} <- shiny::reactive({ + + # Parameters for wilson::create_scatterplot + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # force to use interactive parameter + additional_arguments$plot.method <- "interactive" + + if("density" %ni% names(additional_arguments)){ + additional_arguments$density <- F + } + if("line" %ni% names(additional_arguments)){ + additional_arguments$line <- F + } + if("categorized" %ni% names(additional_arguments)){ + additional_arguments$categorized <- F + } + # Set values for 'x' + if( !{{ env_id }}$x_selection ) { + x <- {{ env_id }}$x[1] + } else { + x <- {{ env_id }}$x[input$select_x_{{ env_id }}] + } + # Set values for 'y' + if( !{{ env_id }}$y_selection ) { + y <- {{ env_id }}$y[1] + } else { + y <- {{ env_id }}$y[input$select_y_{{ env_id }}] + } + # Set values for 'colour_by' + if (!{{ env_id }}$colour_by_selection){ + colour_by <- {{ env_id }}$colour_by[1] + } else { + colour_by <- {{ env_id }}$colour_by[input$select_colour_{{ env_id }}] + } + # Set values for id' + id <- c(1:length(x[[1]])) + + # Create a data.frame + df <- data.frame(id, x, y) + + # if checkbox for expression exists + if(!is.null(input$expr_checkbox_{{ env_id }})){ + if(input$expr_checkbox_{{ env_id }}){ + df["colour_by"] <- {{ env_id }}$expression[input$select_feature_{{ env_id }},] + } else { + if(!is.null({{ env_id }}$colour_by)){ + df["colour_by"] <- colour_by + # if colour_by is character + if(is.character(df[["colour_by"]])){ + additional_arguments$categorized <- T + # if colour_by is factor + } else if (is.factor(df[["colour_by"]])){ + additional_arguments$categorized <- T + df["colour_by"] <- droplevels(df["colour_by"]) + # if colour_by is numeric + } else if (is.numeric(df[["colour_by"]])){ + if("categorized" %in% names({{ env_id }}$additional_arguments)){ + additional_arguments$categorized <- {{ env_id }}$additional_arguments$categorized + } + } + } + } + } else { + # if colour_by provided + if(!is.null({{ env_id }}$colour_by)){ + df["colour_by"] <- colour_by + # if colour_by is character + if(is.character(df[["colour_by"]])){ + additional_arguments$categorized <- T + # if colour_by is factor + } else if (is.factor(df[["colour_by"]])){ + additional_arguments$categorized <- T + df["colour_by"] <- droplevels(df["colour_by"]) + # if colour_by is numeric + } else if (is.numeric(df[["colour_by"]])){ + if("categorized" %in% names({{ env_id }}$additional_arguments)){ + additional_arguments$categorized <- {{ env_id }}$additional_arguments$categorized + } + } + } + } + # color + if(additional_arguments$categorized){ + # categorical (qualitative) color palettes + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(8, "Accent") + additional_arguments$color <- color + } + } else { + # sequential (one-sided) color palettes + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color + } + } + + # Create data.table from data.frame + dt <- data.table::setDT(df) + additional_arguments$data <- dt + + return(list("params" = additional_arguments, "data" = dt)) +}) + +# +# Download +# +output$downloadData_{{ env_id }} <- downloadHandler( + filename = paste('data-', Sys.Date(), '.csv', sep=''), + content = function(file) { + write.csv(df_{{ env_id }}()$data, file) + } +) + +# +# Output +# +output$plot_{{ env_id }} <- plotly::renderPlotly({ + output_list <- do.call(wilson::create_scatterplot, df_{{ env_id }}()$params) + gg <- output_list$plot + + # convert to plotly object for automatic resizing + gg$x$layout$height <- 0 + gg$x$layout$width <- 0 + + gg +}) + +# +# Layout of component +# +shiny::fillCol(flex = c(NA, 1), + do.call(shiny::inputPanel, ui_list), + plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") +) +``` + diff --git a/man/geneview_to_i2dash.Rd b/man/geneview_to_i2dash.Rd new file mode 100644 index 0000000..7c1a76e --- /dev/null +++ b/man/geneview_to_i2dash.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/i2dash.R +\name{geneview_to_i2dash} +\alias{geneview_to_i2dash} +\title{Prepare a geneview to be rendered with the i2dash package.} +\usage{ +geneview_to_i2dash(object, countTable, group_by, title = NULL, ...) +} +\arguments{ +\item{object}{A \linkS4class{i2dash::i2dashboard} object.} + +\item{countTable}{A matrix with features as rows and observations as columns. The rownames and columnnames should be provided and are used in buiding the heatmap.} + +\item{group_by}{A vector with values or a named list will be mapped to the y-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list.} + +\item{title}{(Optional) The title of the components chunk.} + +\item{...}{Further parameters which are compatible with wilsons create_geneview() method. See \code{\link{create_geneview}}.} +} +\value{ +A string containing markdown code for the rendered textbox +} +\description{ +Prepare a geneview to be rendered with the i2dash package. +} diff --git a/man/heatmap_to_i2dash.Rd b/man/heatmap_to_i2dash.Rd new file mode 100644 index 0000000..353d3d4 --- /dev/null +++ b/man/heatmap_to_i2dash.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/i2dash.R +\name{heatmap_to_i2dash} +\alias{heatmap_to_i2dash} +\title{Prepare a heatmap to be rendered with the i2dash package.} +\usage{ +heatmap_to_i2dash(object, countTable, group_by, title = NULL, ...) +} +\arguments{ +\item{object}{A \linkS4class{i2dash::i2dashboard} object.} + +\item{countTable}{A matrix with features as rows and observations as columns. The rownames and columnnames should be provided and are used in building the heatmap.} + +\item{group_by}{A vector with numerical values or a named list will be mapped to the y-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list.} + +\item{title}{(Optional) The title of the components chunk.} + +\item{...}{Further parameters which are compatible with wilsons create_heatmap() method. See \code{\link{create_heatmap}}.} +} +\value{ +A string containing markdown code for the rendered textbox +} +\description{ +Prepare a heatmap to be rendered with the i2dash package. +} diff --git a/man/scatterplot_to_i2dash.Rd b/man/scatterplot_to_i2dash.Rd new file mode 100644 index 0000000..a2645e9 --- /dev/null +++ b/man/scatterplot_to_i2dash.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/i2dash.R +\name{scatterplot_to_i2dash} +\alias{scatterplot_to_i2dash} +\title{Prepare a scatterplot to be rendered with the i2dash package.} +\usage{ +scatterplot_to_i2dash(object, x, y, colour_by = NULL, + expression = NULL, title = NULL, ...) +} +\arguments{ +\item{object}{A \linkS4class{i2dash::i2dashboard} object.} + +\item{x}{A vector with numerical values or a named list will be mapped to the x-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list.} + +\item{y}{A vector with numerical values or a named list will be mapped to the y-axis. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of vectors x and y should be the same as well as the length of all vectors in case of a named list.} + +\item{colour_by}{(Optional) A vector with factorial (= categorical coloring), numerical (= sequential colouring; can be forced to use categorical colouring by providing the parameter '"categorized" = TRUE') or character (= categorical colouring) values or a named list that will be used for colouring. In case of a named list, a dropdown menu will be provided in the interactive mode. Note: The length of the vector should be of the same length as x and y as well as the length of all vectors in case of a named list.} + +\item{expression}{(Optional) A matrix or dataframe with the same length of columns as 'x'. The sequence and number of the columns should be equal to the sequence and length of 'x'. The rownames represent the feature i.e. gene names and the values represent the expression level. Note: This feature is not compatible with the statical mode (parameter '"interactive" = TRUE'). Alternatively you can provide a vector as colour_by.} + +\item{title}{(Optional) The title of the components chunk.} + +\item{...}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link{create_scatterplot}}.} +} +\value{ +A string containing markdown code for the rendered textbox +} +\description{ +Prepare a scatterplot to be rendered with the i2dash package. +}