Commit 18c1707c authored by arsenij.ustjanzew's avatar arsenij.ustjanzew
Browse files

bugfixes & colour by sample-name functionality

parent e30c623c
#' Renders a features by factor violin plot
#'
#' @param plot_title The title of the Component
#' @param object A \linkS4class{i2dash::i2dashboard} object.
#' @param title A title that will be displayed on top.
#' @param x A list with the x-axis values. If it is a nested list, a dropdown-field will be provided in the interactive mode.
#' @param y A list with the y-axis values. If it is a nested list, a dropdown-field will be provided in the interactive mode.(Needs to be categorial. Horizontal violinplots are not possible.)
#'
......@@ -39,4 +40,5 @@ features_by_factors <- function(object, x, y, title = "Features by factor") {
# save environment as rds-object
saveRDS(env, file = file.path(workdir, "envs", paste0(env_id, ".rds")))
print("validation TRUE")
}
......@@ -3,37 +3,51 @@
#' @param object A \linkS4class{i2dash::i2dashboard} object.
#' @param x Numeric values mapped to the x-axis. In case of a nested list, a dropdown menu will be provided in the interactive mode.
#' @param y Numeric values mapped to the y-axis. In case of a nested list, a dropdown menu will be provided in the interactive mode.
#' @param coulor_by A factor that will be mapped to colours.In case of a nested list, a dropdown menu will be provided in the interactive mode.
#' @param colour_by A factor that will be mapped to colours. In case of a nested list, a dropdown menu will be provided in the interactive mode.
#' @param labels A list with sample names, that should be of the same length as x and y.
#' @param title A title that will be displayed on top.
#'
#' @return A string containing markdown code for the rendered textbox
sequence_saturation <- function(object, x, y, colour_by = NULL, title = "Sequencing saturation") {
sequence_saturation <- function(object, x, y, colour_by = NULL, labels = NULL, title = "Sequencing saturation") {
# Create random env id
env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]"))
# validate input, create environment variables, save environment object
.validate_input_sequence_saturation(object@workdir, env_id, x, y, colour_by)
.validate_input_sequence_saturation(object@workdir, env_id, x, y, colour_by, labels)
timestamp <- Sys.time()
expanded_component <- knitr::knit_expand(file = system.file("templates", "sequence_saturation_template.Rmd", package = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp)
return(expanded_component)
}
.validate_input_sequence_saturation <- function(workdir, env_id, x, y, colour_by) {
.validate_input_sequence_saturation <- function(workdir, env_id, x, y, colour_by, labels) {
env <- new.env()
env$x_selection <- FALSE
env$y_selection <- FALSE
env$colour_by_selection <- FALSE
# Create lists if needed
if(!is.list(x)) x <- list(x = x)
if(!is.list(y)) y <- list(y = y)
if(!is.list(colour_by)) colour_by <- list(colour_by)
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)
if(!is.list(labels) & !is.null(labels)) labels <- list(labels)
# should I use magrittr::%<>% ?
# name the lists
library(magrittr)
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")
if(is.null(names(labels)) & !is.null(labels)) labels %<>% magrittr::set_names("labels")
# Check validity
if(!all(sapply(x, is.numeric))) stop("x should only contain numeric values.")
if(!all(sapply(y, is.numeric))) stop("y should only contain numeric values.")
# To Do: check if lengths in a list are the same and if x and y and label and color_by are the same length
# Add objects to env
env$x <- x
env$x_selection <- length(env$x) > 1
......@@ -44,6 +58,8 @@ sequence_saturation <- function(object, x, y, colour_by = NULL, title = "Sequenc
env$colour_by <- colour_by
env$colour_by_selection <- length(env$colour_by) > 1
env$labels <- labels
# save environment as rds-object
saveRDS(env, file = file.path(workdir, "envs", paste0(env_id, ".rds")))
print("validation TRUE")
......
......@@ -51,6 +51,18 @@ p
```{r, eval=is_shiny}
ui_list <- list()
# devtools::install_github('yihui/xfun')
# embed_file() requires a few more packages
xfun::pkg_load2(c('base64enc', 'htmltools', 'mime'))
embed_var = function(x, ...) {
f = tempfile(fileext = '.csv')
write.csv(x, f)
xfun::embed_file(f, text = 'Download full data as .csv', ...)
}
# selection field for x
if ({{ env_id }}$x_selection){
ui_list <- rlist::list.append(ui_list,
......@@ -72,6 +84,24 @@ if ({{ env_id }}$colour_by_selection){
choices = names({{ env_id }}$colour_by)))
}
# Checkbox and selection field for colour by sample name
if (!is.null({{ env_id }}$labels)) {
ui_list <- rlist::list.append(ui_list,
tags$div(checkboxInput("checkbox_{{ env_id }}", label = "Colour by sample name", value = FALSE),
selectInput("select_name_{{ env_id }}", label = NULL, choices = {{ env_id }}$labels)
))
}
# Create data.frame for download
df_list <- list()
if (!is.null({{ env_id }}$labels)) df_list <- rlist::list.append(df_list, {{ env_id }}$labels)
df_list <- rlist::list.append(df_list, c({{ env_id }}$x, {{ env_id }}$y))
if (!is.null({{ env_id }}$colour_by)) df_list <- rlist::list.append(df_list, {{ env_id }}$colour_by)
df <- do.call("data.frame", df_list)
# download_link
ui_list <- rlist::list.append(ui_list, embed_var(df))
fillCol(flex = c(NA, 1),
do.call("inputPanel", ui_list),
plotly::plotlyOutput("plot_{{ env_id }}", height = "100%")
......@@ -81,34 +111,80 @@ output$plot_{{ env_id }} <- plotly::renderPlotly({
if (!{{ env_id }}$x_selection){
x_value <- {{ env_id }}$x[[1]]
x_title <- names({{ env_id }}$x)
x_title <- names({{ env_id }}$x[1])
x <- {{ env_id }}$x[1]
} else {
x_value <- {{ env_id }}$x[[input$select_x_{{ env_id }}]]
x_title <- input$select_x_{{ env_id }}
x <- {{ env_id }}$x[input$select_x_{{ env_id }}]
}
if (!{{ env_id }}$y_selection){
y_value <- {{ env_id }}$y[[1]]
y_title <- names({{ env_id }}$y)
y_title <- names({{ env_id }}$y[1])
y <- {{ env_id }}$y[1]
} else {
y_value <- {{ env_id }}$y[[input$select_y_{{ env_id }}]]
y_title <- input$select_y_{{ env_id }}
y <- {{ env_id }}$y[input$select_y_{{ env_id }}]
}
if (!{{ env_id }}$colour_by_selection){
colour_value <- {{ env_id }}$colour_by[[1]]
if (!is.null({{ env_id }}$colour_by)){
colour_value <- {{ env_id }}$colour_by[[1]]
colour <- {{ env_id }}$colour_by[1]
} else {
colour_value <- NULL
}
} else {
colour_value <- {{ env_id }}$colour_by[[input$select_colour_{{ env_id }}]]
colour <- {{ env_id }}$colour_by[input$select_colour_{{ env_id }}]
}
p <- plotly::plot_ly(data.frame(x_value, y_value, colour_value = I("black")),
# create data.frame for plot
plot_list <- list()
if (!is.null({{ env_id }}$labels)) plot_list <- rlist::list.append(plot_list, {{ env_id }}$labels)
plot_list <- rlist::list.append(plot_list, c(x, y))
if (!is.null({{ env_id }}$colour_by)) plot_list <- rlist::list.append(plot_list, colour)
plot_df <- do.call("data.frame", plot_list)
a <- NULL
labels <- NULL
colour_value <- NULL
if (!is.null({{ env_id }}$labels)) {
if (input$checkbox_{{ env_id }}) {
colour_value <- NULL
point_index <- match(input$select_name_{{ env_id }}, plot_df[[1]])
point <- plot_df[point_index,]
a <- list(
x = point[,2],
y = point[,3],
text = point[,1],
xref = "x",
yref = "y",
showarrow = T,
arrowhead = 7,
arrowcolor = "red",
ax = 20,
ay = -40
)
}
}
if (!is.null({{ env_id }}$labels)) labels <- plot_df[[1]]
p <- plotly::plot_ly(plot_df,
x = x_value,
y = y_value,
color = colour_value
color = colour_value,
text = labels
)
p <- plotly::add_markers(p)
p <- plotly::layout(p,
xaxis = list(title = x_title),
yaxis = list(title = y_title))
yaxis = list(title = y_title),
annotations = a)
p
})
......
......@@ -7,11 +7,13 @@
features_by_factors(object, x, y, title = "Features by factor")
}
\arguments{
\item{object}{A \linkS4class{i2dash::i2dashboard} object.}
\item{x}{A list with the x-axis values. If it is a nested list, a dropdown-field will be provided in the interactive mode.}
\item{y}{A list with the y-axis values. If it is a nested list, a dropdown-field will be provided in the interactive mode.(Needs to be categorial. Horizontal violinplots are not possible.)}
\item{plot_title}{The title of the Component}
\item{title}{A title that will be displayed on top.}
}
\value{
A string containing markdown code for the rendered textbox
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/sequence_saturation.R
% Please edit documentation in R/dimension_reduction.R, R/sequence_saturation.R
\name{sequence_saturation}
\alias{sequence_saturation}
\title{Renders a Sequence saturation plot}
\usage{
sequence_saturation(object, x, y, colour_by = NULL,
sequence_saturation(object, x, y, colour_by = NULL, labels = NULL,
title = "Sequencing saturation")
sequence_saturation(object, x, y, colour_by = NULL, labels = NULL,
title = "Sequencing saturation")
}
\arguments{
......@@ -14,13 +17,27 @@ sequence_saturation(object, x, y, colour_by = NULL,
\item{y}{Numeric values mapped to the y-axis. In case of a nested list, a dropdown menu will be provided in the interactive mode.}
\item{colour_by}{A factor that will be mapped to colours. In case of a nested list, a dropdown menu will be provided in the interactive mode.}
\item{labels}{A list with sample names, that should be of the same length as x and y.}
\item{title}{A title that will be displayed on top.}
\item{red_dim}{List with reduced dimensions as data.frames.}
\item{coulor_by}{A factor that will be mapped to colours.In case of a nested list, a dropdown menu will be provided in the interactive mode.}
\item{object}{A \linkS4class{i2dash::i2dashboard} object.}
\item{title}{A title that will be displayed on top.}
}
\value{
A string containing markdown code for the rendered textbox
A string containing markdown code for the rendered textbox
}
\description{
Renders a Sequence saturation plot
Renders a Sequence saturation plot
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment