From 9930878dc3696d9fe874978c3df3f8c585ea4573 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Mon, 22 Jul 2019 14:48:34 +0200 Subject: [PATCH 01/15] copied functions from i2dash --- R/i2dash.R | 242 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 242 insertions(+) create mode 100644 R/i2dash.R diff --git a/R/i2dash.R b/R/i2dash.R new file mode 100644 index 0000000..80689db --- /dev/null +++ b/R/i2dash.R @@ -0,0 +1,242 @@ +#' Renders a heatmap plot from 'wilson' 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 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 junk. +#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @export +heatmap_wilson <- function(object, countTable, group_by, title = NULL, ...) { + # Create random env id + env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + + # Create list if element is not a list already + if(!is.list(group_by)) group_by <- list(group_by) + #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) + + # Name the lists + if(is.null(names(group_by))) group_by %<>% magrittr::set_names("grouping") + #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") + + # 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(wilson::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)) + #if(length(additional_arguments) == 0) additional_arguments <- NULL + + # 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 = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} + +#' Renders a pca plot from 'wilson' 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 colour_by (Optional) 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 junk. +#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @export +pca_wilson <- function(object, countTable, colour_by, title = NULL, ...) { + # Create random env id + env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + + # Create list if element is not a list already + if(!is.list(colour_by) & !is.null(colour_by)) colour_by <- list(colour_by) + + # Name the lists + if(is.null(names(colour_by)) & !is.null(colour_by)) colour_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 lengths + if(!is.null(colour_by) & length(unique(sapply(colour_by, length))) != 1) stop("The list 'colour_by' should contain elements with the same length.") + if(!identical(ncol(countTable), length(colour_by[[1]])) & !is.null(colour_by)) stop("The number of columns in 'countTable' should be equal to the length of the vector 'colour_by'.") + + additional_arguments <- list(...) + if("data" %in% names(additional_arguments)) warning("The parameter 'countTable' will be used instead of 'data.table'.") + if("color.group" %in% names(additional_arguments)) stop("The parameter 'color.group' is not usable. Please use 'colour_by' instead.") + valid_arguments <- names(as.list(args(wilson::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_pca': ", invalid_args)) + #if(length(additional_arguments) == 0) additional_arguments <- NULL + + # Create component environment + env <- new.env() + env$countTable <- countTable + env$colour_by_selection <- FALSE + + env$colour_by <- colour_by + env$colour_by_selection <- length(env$colour_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", "pca_wilson.Rmd", package = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} + +#' Method for geneView creation from 'wilson' 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 junk. +#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @export +geneview_wilson <- function(object, countTable, group_by, title = NULL, ...) { + # Create random env id + env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + + # 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(wilson::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)) + #if(length(additional_arguments) == 0) additional_arguments <- NULL + + # 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 = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} + +#' Renders a scatter plot from 'wilson' 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 junk. +#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' +#' @return A string containing markdown code for the rendered textbox +#' @export +scatterplot_wilson <- function(object, x, y, colour_by = NULL, expression = NULL, title = NULL, ...) { + # Create random env id + env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + + # 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) + #if(!is.list(labels) & !is.null(labels)) labels <- list(labels) + + # 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") + #if(is.null(names(labels)) & !is.null(labels)) labels %<>% magrittr::set_names("labels") + + # 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(length(unique(sapply(labels, length))) != 1 & !is.null(labels)) stop("The list 'labels' 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(length(x[[1]]), length(labels[[1]])) & !is.null(labels)) 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(wilson::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)) + #if(length(additional_arguments) == 0) additional_arguments <- NULL + + # Create component environment + env <- new.env() + 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$labels <- labels + + 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 = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + return(expanded_component) +} From 8bf05ee6cba36fc9ab5f01056b0aa2555095033f Mon Sep 17 00:00:00 2001 From: Schultheis Date: Mon, 22 Jul 2019 15:22:15 +0200 Subject: [PATCH 02/15] add i2dash to suggested packages --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index b658d2c..bcc38c9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -51,5 +51,6 @@ biocViews: Suggests: knitr, rmarkdown, testthat, - vdiffr + vdiffr, + i2dash VignetteBuilder: knitr From 25efb67077d51602ca0153bc097d76bd5ad43ea9 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Mon, 22 Jul 2019 15:23:16 +0200 Subject: [PATCH 03/15] Refactored functions to match wilson context; check whether suggested i2dash is installed --- R/i2dash.R | 126 +++++++++++++++++++++++++++-------------------------- 1 file changed, 64 insertions(+), 62 deletions(-) diff --git a/R/i2dash.R b/R/i2dash.R index 80689db..d109bf2 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -1,4 +1,4 @@ -#' Renders a heatmap plot from 'wilson' package +#' 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 buiding the heatmap. @@ -8,36 +8,33 @@ #' #' @return A string containing markdown code for the rendered textbox #' @export -heatmap_wilson <- function(object, countTable, group_by, title = NULL, ...) { +heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE)) { + stop("Package i2dash is needed to use this function. Please install it.") + } + # Create random env id env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) # Create list if element is not a list already - if(!is.list(group_by)) group_by <- list(group_by) - #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) + 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") - #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") + 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'.") + 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 (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'.") + 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'") + 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(wilson::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)) - #if(length(additional_arguments) == 0) additional_arguments <- NULL + 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() @@ -58,7 +55,7 @@ heatmap_wilson <- function(object, countTable, group_by, title = NULL, ...) { return(expanded_component) } -#' Renders a pca plot from 'wilson' package +#' Prepare a pca 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. @@ -68,30 +65,33 @@ heatmap_wilson <- function(object, countTable, group_by, title = NULL, ...) { #' #' @return A string containing markdown code for the rendered textbox #' @export -pca_wilson <- function(object, countTable, colour_by, title = NULL, ...) { +pca_to_i2dash <- function(object, countTable, colour_by, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE)) { + stop("Package i2dash is needed to use this function. Please install it.") + } + # Create random env id env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) # Create list if element is not a list already - if(!is.list(colour_by) & !is.null(colour_by)) colour_by <- list(colour_by) + if (!is.list(colour_by) & !is.null(colour_by)) colour_by <- list(colour_by) # Name the lists - if(is.null(names(colour_by)) & !is.null(colour_by)) colour_by %<>% magrittr::set_names("grouping") + if (is.null(names(colour_by)) & !is.null(colour_by)) colour_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'.") + if ((!is.matrix(countTable) & !is.data.frame(countTable))) stop("'countTable' should be a class of 'matrix' or 'data.frame'.") # Check lengths - if(!is.null(colour_by) & length(unique(sapply(colour_by, length))) != 1) stop("The list 'colour_by' should contain elements with the same length.") - if(!identical(ncol(countTable), length(colour_by[[1]])) & !is.null(colour_by)) stop("The number of columns in 'countTable' should be equal to the length of the vector 'colour_by'.") + if (!is.null(colour_by) & length(unique(sapply(colour_by, length))) != 1) stop("The list 'colour_by' should contain elements with the same length.") + if (!identical(ncol(countTable), length(colour_by[[1]])) & !is.null(colour_by)) stop("The number of columns in 'countTable' should be equal to the length of the vector 'colour_by'.") additional_arguments <- list(...) - if("data" %in% names(additional_arguments)) warning("The parameter 'countTable' will be used instead of 'data.table'.") - if("color.group" %in% names(additional_arguments)) stop("The parameter 'color.group' is not usable. Please use 'colour_by' instead.") + if ("data" %in% names(additional_arguments)) warning("The parameter 'countTable' will be used instead of 'data.table'.") + if ("color.group" %in% names(additional_arguments)) stop("The parameter 'color.group' is not usable. Please use 'colour_by' instead.") valid_arguments <- names(as.list(args(wilson::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_pca': ", invalid_args)) - #if(length(additional_arguments) == 0) additional_arguments <- NULL + if (length(invalid_args) != 0) stop(paste0(" The following parameter is not a valid parameter of 'wilson::create_pca': ", invalid_args)) # Create component environment env <- new.env() @@ -112,7 +112,7 @@ pca_wilson <- function(object, countTable, colour_by, title = NULL, ...) { return(expanded_component) } -#' Method for geneView creation from 'wilson' package +#' 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. @@ -122,27 +122,30 @@ pca_wilson <- function(object, countTable, colour_by, title = NULL, ...) { #' #' @return A string containing markdown code for the rendered textbox #' @export -geneview_wilson <- function(object, countTable, group_by, title = NULL, ...) { +geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE)) { + stop("Package i2dash is needed to use this function. Please install it.") + } + # Create random env id env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) # Create list if element is not a list already - if(!is.list(group_by)) group_by <- list(group_by) + 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") + 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'.") + 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'") + 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(wilson::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)) - #if(length(additional_arguments) == 0) additional_arguments <- NULL + 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() @@ -163,7 +166,7 @@ geneview_wilson <- function(object, countTable, group_by, title = NULL, ...) { return(expanded_component) } -#' Renders a scatter plot from 'wilson' package +#' 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. @@ -175,45 +178,44 @@ geneview_wilson <- function(object, countTable, group_by, title = NULL, ...) { #' #' @return A string containing markdown code for the rendered textbox #' @export -scatterplot_wilson <- function(object, x, y, colour_by = NULL, expression = NULL, title = NULL, ...) { +scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = NULL, title = NULL, ...) { + if (!requireNamespace("i2dash", quietly = TRUE)) { + stop("Package i2dash is needed to use this function. Please install it.") + } + # Create random env id env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) # 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) - #if(!is.list(labels) & !is.null(labels)) labels <- list(labels) + 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") - #if(is.null(names(labels)) & !is.null(labels)) labels %<>% magrittr::set_names("labels") + 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'.") + 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(length(unique(sapply(labels, length))) != 1 & !is.null(labels)) stop("The list 'labels' should contain elements with 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(length(x[[1]]), length(labels[[1]])) & !is.null(labels)) 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'.") + 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.") + 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(wilson::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)) - #if(length(additional_arguments) == 0) additional_arguments <- NULL + 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() From 710f5772af49bfeae6f36aefa291a44dfa718ab4 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Tue, 23 Jul 2019 12:04:06 +0200 Subject: [PATCH 04/15] removed pca_to_i2dash as it is not needed --- R/i2dash.R | 63 +++--------------------------------------------------- 1 file changed, 3 insertions(+), 60 deletions(-) diff --git a/R/i2dash.R b/R/i2dash.R index d109bf2..a4e990b 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -3,7 +3,7 @@ #' @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 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 junk. +#' @param title (Optional) The title of the components chunk. #' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. #' #' @return A string containing markdown code for the rendered textbox @@ -55,69 +55,12 @@ heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { return(expanded_component) } -#' Prepare a pca 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 colour_by (Optional) 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 junk. -#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. -#' -#' @return A string containing markdown code for the rendered textbox -#' @export -pca_to_i2dash <- function(object, countTable, colour_by, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE)) { - stop("Package i2dash is needed to use this function. Please install it.") - } - - # Create random env id - env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) - - # Create list if element is not a list already - if (!is.list(colour_by) & !is.null(colour_by)) colour_by <- list(colour_by) - - # Name the lists - if (is.null(names(colour_by)) & !is.null(colour_by)) colour_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 lengths - if (!is.null(colour_by) & length(unique(sapply(colour_by, length))) != 1) stop("The list 'colour_by' should contain elements with the same length.") - if (!identical(ncol(countTable), length(colour_by[[1]])) & !is.null(colour_by)) stop("The number of columns in 'countTable' should be equal to the length of the vector 'colour_by'.") - - additional_arguments <- list(...) - if ("data" %in% names(additional_arguments)) warning("The parameter 'countTable' will be used instead of 'data.table'.") - if ("color.group" %in% names(additional_arguments)) stop("The parameter 'color.group' is not usable. Please use 'colour_by' instead.") - valid_arguments <- names(as.list(args(wilson::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_pca': ", invalid_args)) - - # Create component environment - env <- new.env() - env$countTable <- countTable - env$colour_by_selection <- FALSE - - env$colour_by <- colour_by - env$colour_by_selection <- length(env$colour_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", "pca_wilson.Rmd", package = "i2dash.scrnaseq"), 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 junk. +#' @param title (Optional) The title of the components chunk. #' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. #' #' @return A string containing markdown code for the rendered textbox @@ -173,7 +116,7 @@ geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) #' @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 junk. +#' @param title (Optional) The title of the components chunk. #' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. #' #' @return A string containing markdown code for the rendered textbox From 97ab8052bba1b8255228eea46f32d1752dcdd34c Mon Sep 17 00:00:00 2001 From: Schultheis Date: Tue, 23 Jul 2019 12:26:42 +0200 Subject: [PATCH 05/15] added compId parameter to *_to_i2dash functions --- R/i2dash.R | 50 +++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 39 insertions(+), 11 deletions(-) diff --git a/R/i2dash.R b/R/i2dash.R index a4e990b..8a8cd24 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -3,18 +3,25 @@ #' @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 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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. #' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. #' #' @return A string containing markdown code for the rendered textbox #' @export -heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { +heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title = NULL, ...) { if (!requireNamespace("i2dash", quietly = TRUE)) { stop("Package i2dash is needed to use this function. Please install it.") } - # Create random env id - env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + # Create env id + if (is.null(compId)) { + compId <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") # this compId is for the check in the Rmd file and is not saved in object@compIds + env_id <- paste0("env_", compId) + } else { + env_id <- paste0("env_", compId) + } + # Create list if element is not a list already if (!is.list(group_by)) group_by <- list(group_by) @@ -46,6 +53,8 @@ heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { env$additional_arguments <- additional_arguments + env$compId <- compId + # Save environment object saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) @@ -60,18 +69,24 @@ heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. #' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. #' #' @return A string containing markdown code for the rendered textbox #' @export -geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { +geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, title = NULL, ...) { if (!requireNamespace("i2dash", quietly = TRUE)) { stop("Package i2dash is needed to use this function. Please install it.") } - # Create random env id - env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + # Create env id + if (is.null(compId)) { + compId <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") # this compId is for the check in the Rmd file and is not saved in object@compIds + env_id <- paste0("env_", compId) + } else { + env_id <- paste0("env_", compId) + } # Create list if element is not a list already if (!is.list(group_by)) group_by <- list(group_by) @@ -100,6 +115,8 @@ geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) env$additional_arguments <- additional_arguments + env$compId <- compId + # Save environment object saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) @@ -116,18 +133,24 @@ geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. #' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. #' #' @return A string containing markdown code for the rendered textbox #' @export -scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = NULL, title = NULL, ...) { +scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = NULL, compId = NULL, title = NULL, ...) { if (!requireNamespace("i2dash", quietly = TRUE)) { stop("Package i2dash is needed to use this function. Please install it.") } - # Create random env id - env_id <- paste0("env_", stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]")) + # Create env id + if (is.null(compId)) { + compId <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") # this compId is for the check in the Rmd file and is not saved in object@compIds + env_id <- paste0("env_", compId) + } else { + env_id <- paste0("env_", compId) + } # Create list if element is not a list already if (!is.list(x)) x <- list(x) @@ -162,6 +185,11 @@ scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = N # 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 @@ -171,12 +199,12 @@ scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = N env$colour_by <- colour_by env$colour_by_selection <- length(env$colour_by) > 1 - #env$labels <- labels - env$expression <- expression env$additional_arguments <- additional_arguments + env$compId <- compId + # Save environment object saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) From 1955f55735483e5b90ad169e481f324f608e9dd8 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Tue, 23 Jul 2019 14:43:01 +0200 Subject: [PATCH 06/15] fixed typo --- R/i2dash.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/i2dash.R b/R/i2dash.R index 8a8cd24..7021f70 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -1,7 +1,7 @@ #' 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 buiding the heatmap. +#' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. @@ -22,7 +22,6 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title env_id <- paste0("env_", compId) } - # Create list if element is not a list already if (!is.list(group_by)) group_by <- list(group_by) From 08405ff7e20568a6e583cde6dde4b9e33d237f9f Mon Sep 17 00:00:00 2001 From: Schultheis Date: Tue, 23 Jul 2019 14:43:27 +0200 Subject: [PATCH 07/15] update package version and news --- DESCRIPTION | 2 +- NEWS.md | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index bcc38c9..322d837 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"), 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 From 652b82ed91b882e399f1ceba2e30a3ee0997349c Mon Sep 17 00:00:00 2001 From: Schultheis Date: Tue, 23 Jul 2019 15:46:19 +0200 Subject: [PATCH 08/15] require i2dash.scrnaseq package as it provides the needed templates --- DESCRIPTION | 3 ++- R/i2dash.R | 12 ++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 322d837..595cb4d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -52,5 +52,6 @@ Suggests: knitr, rmarkdown, testthat, vdiffr, - i2dash + i2dash, + i2dash.scrnaseq VignetteBuilder: knitr diff --git a/R/i2dash.R b/R/i2dash.R index 7021f70..231735e 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -10,8 +10,8 @@ #' @return A string containing markdown code for the rendered textbox #' @export heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE)) { - stop("Package i2dash is needed to use this function. Please install it.") + if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("i2dash.scrnaseq", quietly = TRUE)) { + stop("Packages i2dash and i2dash.scrnaseq are needed to use this function. Please install those.") } # Create env id @@ -75,8 +75,8 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title #' @return A string containing markdown code for the rendered textbox #' @export geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE)) { - stop("Package i2dash is needed to use this function. Please install it.") + if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("i2dash.scrnaseq", quietly = TRUE)) { + stop("Packages i2dash and i2dash.scrnaseq are needed to use this function. Please install those.") } # Create env id @@ -139,8 +139,8 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl #' @return A string containing markdown code for the rendered textbox #' @export scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = NULL, compId = NULL, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE)) { - stop("Package i2dash is needed to use this function. Please install it.") + if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("i2dash.scrnaseq", quietly = TRUE)) { + stop("Packages i2dash and i2dash.scrnaseq are needed to use this function. Please install those.") } # Create env id From 28cc11e92173ef749580ef84ebb53f676c47b5d6 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Tue, 23 Jul 2019 15:47:12 +0200 Subject: [PATCH 09/15] add namespace and documentation of {plot}_to_i2dash functions --- NAMESPACE | 3 +++ man/geneview_to_i2dash.Rd | 28 ++++++++++++++++++++++++++++ man/heatmap_to_i2dash.Rd | 28 ++++++++++++++++++++++++++++ man/scatterplot_to_i2dash.Rd | 32 ++++++++++++++++++++++++++++++++ 4 files changed, 91 insertions(+) create mode 100644 man/geneview_to_i2dash.Rd create mode 100644 man/heatmap_to_i2dash.Rd create mode 100644 man/scatterplot_to_i2dash.Rd diff --git a/NAMESPACE b/NAMESPACE index 8db88f5..bd434cf 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,6 +37,7 @@ export(pca) export(pcaUI) export(scatterPlot) export(scatterPlotUI) +export(scatterplot_to_i2dash) export(set_logger) export(tobias_parser) export(transformation) diff --git a/man/geneview_to_i2dash.Rd b/man/geneview_to_i2dash.Rd new file mode 100644 index 0000000..a93c67e --- /dev/null +++ b/man/geneview_to_i2dash.Rd @@ -0,0 +1,28 @@ +% 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, compId = NULL, + 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{compId}{(Optional) The component ID provided through add_component and used for linking components together.} + +\item{title}{(Optional) The title of the components chunk.} + +\item{(...)}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}.} +} +\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..62cfb4f --- /dev/null +++ b/man/heatmap_to_i2dash.Rd @@ -0,0 +1,28 @@ +% 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, compId = NULL, + 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{compId}{(Optional) The component ID provided through add_component and used for linking components together.} + +\item{title}{(Optional) The title of the components chunk.} + +\item{(...)}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}.} +} +\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..83f5d86 --- /dev/null +++ b/man/scatterplot_to_i2dash.Rd @@ -0,0 +1,32 @@ +% 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, compId = 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{compId}{(Optional) The component ID provided through add_component and used for linking components together.} + +\item{title}{(Optional) The title of the components chunk.} + +\item{(...)}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}.} +} +\value{ +A string containing markdown code for the rendered textbox +} +\description{ +Prepare a scatterplot to be rendered with the i2dash package. +} From 22be9339f1e1a42b7e138090c28bc767388b67b4 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 12:29:43 +0200 Subject: [PATCH 10/15] update dependencies --- DESCRIPTION | 5 +++-- NAMESPACE | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 595cb4d..e200cc1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,7 +45,8 @@ Imports: shiny, log4r, openssl, methods, - R6 + R6, + magrittr RoxygenNote: 6.1.1 biocViews: Suggests: knitr, @@ -53,5 +54,5 @@ Suggests: knitr, testthat, vdiffr, i2dash, - i2dash.scrnaseq + stringi VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index bd434cf..df42e3b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,3 +44,4 @@ export(transformation) export(transformationUI) import(data.table) importFrom(R6,R6Class) +importFrom(magrittr,"%<>%") From d429c87cd488afd3571535ff156a6b7f27204ac4 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 12:30:14 +0200 Subject: [PATCH 11/15] added templates for i2dash functions --- inst/templates/geneView_wilson.Rmd | 186 +++++++++ inst/templates/geneView_wilson_link.Rmd | 272 +++++++++++++ inst/templates/heatmap_wilson.Rmd | 257 +++++++++++++ inst/templates/heatmap_wilson_link.Rmd | 315 +++++++++++++++ inst/templates/scatterplot_wilson.Rmd | 271 +++++++++++++ inst/templates/scatterplot_wilson_link.Rmd | 422 +++++++++++++++++++++ 6 files changed, 1723 insertions(+) create mode 100644 inst/templates/geneView_wilson.Rmd create mode 100644 inst/templates/geneView_wilson_link.Rmd create mode 100644 inst/templates/heatmap_wilson.Rmd create mode 100644 inst/templates/heatmap_wilson_link.Rmd create mode 100644 inst/templates/scatterplot_wilson.Rmd create mode 100644 inst/templates/scatterplot_wilson_link.Rmd 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/geneView_wilson_link.Rmd b/inst/templates/geneView_wilson_link.Rmd new file mode 100644 index 0000000..d857173 --- /dev/null +++ b/inst/templates/geneView_wilson_link.Rmd @@ -0,0 +1,272 @@ + +### {{ 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} +################ UI #################### +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 = "Number of 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'))) + +################# Server #################### +# if component is a reciever +if({{ env_id }}$compId %in% edgeTable$reciever){ + + # set variables + reciever_{{ env_id }} <- {{ env_id }}$compId + transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter + + 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 + } + + additional_arguments$plot.method <- "static" + + # Set values for 'group_by' and 'countTable' + 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 }}] + } + countTable <- {{ env_id }}$countTable + + # subset countTable according to transmitted sample keys + plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) + keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") + selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key + if(!is.null(selection_transmitter)){ + if(all(selection_transmitter %in% colnames(countTable))){ + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } else { + false_keys <- which(!(selection_transmitter %in% colnames(countTable))) + print("The following keys are not in the countTable:") + print(selection_transmitter[false_keys]) + if(!is.null(ncol(selection_transmitter[-false_keys]))){ + selection_transmitter <- selection_transmitter[-false_keys] + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } + } + } + + # 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] + } + } + + # 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]]) + download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) + additional_arguments$data <- data + additional_arguments$grouping <- grouping + #additional_arguments$width <- 20 + #additional_arguments$height <- 15 + + return(list("params" = additional_arguments, "data" = download_dt)) + }) +} else { + 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 + } + + additional_arguments$plot.method <- "static" + + # Set values for 'group_by' and 'countTable' + 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 }}] + } + countTable <- {{ env_id }}$countTable + + # 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] + } + } + # + # 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]]) + download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) + additional_arguments$data <- data + additional_arguments$grouping <- grouping + #additional_arguments$width <- 20 + #additional_arguments$height <- 15 + return(list("params" = additional_arguments, "data" = download_dt)) + }) +} + +# Download +output$downloadData_{{ env_id }} <- downloadHandler( + filename = paste('data-', Sys.Date(), '.csv', sep=''), + content = function(file) { + write.csv(df_{{ env_id }}()$data, file) + } +) + +# works as transmitter with brushopt +plot_{{ env_id }} <- shiny::reactive({ + if(!is.null(input$select_subset_{{ env_id }})){ + output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) + dt <- output_list$plot$data + return(dt) + } +}) + +# Output +output$plot_{{ env_id }} <- renderPlot({ + if(!is.null(input$select_subset_{{ env_id }})){ + output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) + gg <- output_list$plot + gg + #p <- plotly::ggplotly(gg) + #p + } + # convert to plotly object for automatic resizing + +}) + +# Layout of component +shiny::fillRow(flex = c(NA, 1), + shinyWidgets::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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), + plotOutput("plot_{{ env_id }}", width = "100%",click = "plot1_click", + brush = brushOpts( + id = "plot1_brush" + )) +) +``` 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/heatmap_wilson_link.Rmd b/inst/templates/heatmap_wilson_link.Rmd new file mode 100644 index 0000000..20b9e62 --- /dev/null +++ b/inst/templates/heatmap_wilson_link.Rmd @@ -0,0 +1,315 @@ + +### {{ title }} + + + +```{r} +{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") + +is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") +``` + +```{r} +###### +library(magrittr) +##### +# +# 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 #################### +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) + +}) + +################# Server #################### +# if component is a reciever +if({{ env_id }}$compId %in% edgeTable$reciever){ + + # set variables + reciever_{{ env_id }} <- {{ env_id }}$compId + transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter + + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # "static" not possible yet + additional_arguments$plot.method <- "interactive" + + # 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 }} + + # sequential (one-sided) color palette + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color + } + + # 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 according to transmitted sample keys + plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) + keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") + selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key + if(!is.null(selection_transmitter)){ + if(all(selection_transmitter %in% colnames(countTable))){ + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } else { + false_keys <- which(!(selection_transmitter %in% colnames(countTable))) + print("The following keys are not in the countTable:") + print(selection_transmitter[false_keys]) + if(!is.null(ncol(selection_transmitter[-false_keys]))){ + selection_transmitter <- selection_transmitter[-false_keys] + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } + } + } + + # 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] + } + } + + # create data.table + dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) + + # 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,] + } + key <- NULL + additional_arguments$data <- dt + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) + + # if compId is not a reciever +} else { + + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # "static" not possible yet + additional_arguments$plot.method <- "interactive" + + # 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 }} + + # sequential (one-sided) color palette + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color + } + + # 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] + } + } + + # create data.table + dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) + + # 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,] + } + key <- NULL + additional_arguments$data <- dt + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) +} + +# create plot with wilson +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$x$source <- "plot_{{ env_id }}" + #heatmap %>% plotly::event_register("plotly_selected") + # no output as transmitter implemented + heatmap +}) + +# Layout of component +shiny::fillRow(flex = c(NA, 1), + shinyWidgets::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 = shinyWidgets::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/inst/templates/scatterplot_wilson_link.Rmd b/inst/templates/scatterplot_wilson_link.Rmd new file mode 100644 index 0000000..262a114 --- /dev/null +++ b/inst/templates/scatterplot_wilson_link.Rmd @@ -0,0 +1,422 @@ + +### {{ 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} +############## +library(magrittr) +############# +################# UI #################### +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)) + )) +} + +if ({{ env_id }}$compId %in% edgeTable$transmitter) { + ui_list <- rlist::list.append(ui_list, + tags$div(radioButtons("linking_mode_{{ env_id }}", label = "Select linking mode: ", + choices = list("Subsetting", "Highlighting"), + selected = "Subsetting"))) + ui_list <- rlist::list.append(ui_list, + tags$div(colourpicker::colourInput("col_{{ env_id }}", "Select colour for highlighting:", "red"))) +} + +# Download link +ui_list <- rlist::list.append(ui_list, tags$div(tags$br(), downloadButton('downloadData_{{ env_id }}', 'Download data'))) + +################# Server #################### +# if compId exists and component is a reciever +if({{ env_id }}$compId %in% edgeTable$reciever){ + # set variables + reciever_{{ env_id }} <- {{ env_id }}$compId + transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter + + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + additional_arguments$plot.method <- "static" + + 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"]) + df["colour_by"] <- as.character(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"]) + df["colour_by"] <- as.character(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) + + if("data.labels" %in% names(additional_arguments)){ + dt[[1]] <- additional_arguments$data.labels + } + + # get all and selected keys from transmitter + plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) + keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") + color_transmitter_string <- paste0("input$col_env_", transmitter_to_{{ env_id }}) + color_transmitter <- eval(parse(text = color_transmitter_string)) + linking_mode_transmitter_string <- paste0("input$linking_mode_env_", transmitter_to_{{ env_id }}) + linking_mode_transmitter <- eval(parse(text = linking_mode_transmitter_string)) + all_keys_transmitter <- eval(parse(text = keys_transmitter_string)) + selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key + if (!is.null(selection_transmitter)) { + m <- match(selection_transmitter, dt[[1]]) + if(linking_mode_transmitter == "Subsetting"){ + dt <- dt[na.omit(m), ] + } else if (linking_mode_transmitter == "Highlighting") { + additional_arguments$highlight.data <- dt[na.omit(m), ] + additional_arguments$highlight.color <- color_transmitter + } + } + + additional_arguments$data <- dt + + key <- NULL + + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) + # if compId doesn't exists +} else { + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + additional_arguments$plot.method <- "static" + + 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 + + # provide key for linking components + if("data.labels" %in% names(additional_arguments)){ + key <- additional_arguments$data.labels + } else { + key <- dt[[1]] + } + + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) +} + +# Download +output$downloadData_{{ env_id }} <- downloadHandler( + filename = paste('data-', Sys.Date(), '.csv', sep=''), + content = function(file) { + write.csv(df_{{ env_id }}()$data, file) + } +) + +# create plot with wilson +output$plot_{{ env_id }} <- plotly::renderPlotly({ + output_list <- do.call(wilson::create_scatterplot, df_{{ env_id }}()$params) + gg <- output_list$plot #ggplot object + gg$mapping$key <- df_{{ env_id }}()$key + gg$label <- "key" + # convert to plotly object for automatic resizing + p <- plotly::ggplotly(gg) + p$x$source <- "plot_{{ env_id }}" + p %>% plotly::event_register("plotly_selected") +}) + +# Layout of component +shiny::fillRow(flex = c(NA, 1), + shinyWidgets::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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), + plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") +) +``` + From 0b36967774586362f1e510558f9995e59df43f77 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 12:31:48 +0200 Subject: [PATCH 12/15] check and import function dependencies; updated documentation; updated path to templates --- R/i2dash.R | 39 ++++++++++++++++++++++-------------- man/geneview_to_i2dash.Rd | 2 +- man/heatmap_to_i2dash.Rd | 2 +- man/scatterplot_to_i2dash.Rd | 2 +- 4 files changed, 27 insertions(+), 18 deletions(-) diff --git a/R/i2dash.R b/R/i2dash.R index 231735e..7fb147f 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -5,13 +5,16 @@ #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. -#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' @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, compId = NULL, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("i2dash.scrnaseq", quietly = TRUE)) { - stop("Packages i2dash and i2dash.scrnaseq are needed to use this function. Please install those.") + 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 @@ -38,7 +41,7 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title 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(wilson::create_scatterplot))) + 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)) @@ -59,7 +62,7 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title # Expand component timestamp <- Sys.time() - expanded_component <- knitr::knit_expand(file = system.file("templates", "heatmap_wilson.Rmd", package = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + 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) } @@ -70,13 +73,16 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. -#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' @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, compId = NULL, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("i2dash.scrnaseq", quietly = TRUE)) { - stop("Packages i2dash and i2dash.scrnaseq are needed to use this function. Please install those.") + 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 @@ -100,7 +106,7 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl 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(wilson::create_scatterplot))) + 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)) @@ -121,7 +127,7 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl # Expand component timestamp <- Sys.time() - expanded_component <- knitr::knit_expand(file = system.file("templates", "geneView_wilson.Rmd", package = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + 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) } @@ -134,13 +140,16 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @param title (Optional) The title of the components chunk. -#' @param (...) Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}. +#' @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, compId = NULL, title = NULL, ...) { - if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("i2dash.scrnaseq", quietly = TRUE)) { - stop("Packages i2dash and i2dash.scrnaseq are needed to use this function. Please install those.") + 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 @@ -178,7 +187,7 @@ scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = N 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(wilson::create_scatterplot))) + 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)) @@ -209,6 +218,6 @@ scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = N # Expand component timestamp <- Sys.time() - expanded_component <- knitr::knit_expand(file = system.file("templates", "scatterplot_wilson.Rmd", package = "i2dash.scrnaseq"), title = title, env_id = env_id, date = timestamp) + 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/man/geneview_to_i2dash.Rd b/man/geneview_to_i2dash.Rd index a93c67e..aead0ca 100644 --- a/man/geneview_to_i2dash.Rd +++ b/man/geneview_to_i2dash.Rd @@ -18,7 +18,7 @@ geneview_to_i2dash(object, countTable, group_by, compId = NULL, \item{title}{(Optional) The title of the components chunk.} -\item{(...)}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}.} +\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 diff --git a/man/heatmap_to_i2dash.Rd b/man/heatmap_to_i2dash.Rd index 62cfb4f..6abaf08 100644 --- a/man/heatmap_to_i2dash.Rd +++ b/man/heatmap_to_i2dash.Rd @@ -18,7 +18,7 @@ heatmap_to_i2dash(object, countTable, group_by, compId = NULL, \item{title}{(Optional) The title of the components chunk.} -\item{(...)}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}.} +\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 diff --git a/man/scatterplot_to_i2dash.Rd b/man/scatterplot_to_i2dash.Rd index 83f5d86..211a7ea 100644 --- a/man/scatterplot_to_i2dash.Rd +++ b/man/scatterplot_to_i2dash.Rd @@ -22,7 +22,7 @@ scatterplot_to_i2dash(object, x, y, colour_by = NULL, \item{title}{(Optional) The title of the components chunk.} -\item{(...)}{Further parameters which are compatible with wilsons create_scatterplot() method. See \code{\link[wilson::create_scatterplot()]{wilson}}.} +\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 From 233d37d437055cc89a74b63635c969fb9a63095e Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 12:53:16 +0200 Subject: [PATCH 13/15] removed duplicated templates --- inst/templates/geneView_wilson.Rmd | 230 +++++++---- inst/templates/geneView_wilson_link.Rmd | 272 ------------- inst/templates/heatmap_wilson.Rmd | 226 +++++++---- inst/templates/heatmap_wilson_link.Rmd | 315 --------------- inst/templates/scatterplot_wilson.Rmd | 373 ++++++++++++------ inst/templates/scatterplot_wilson_link.Rmd | 422 --------------------- 6 files changed, 562 insertions(+), 1276 deletions(-) delete mode 100644 inst/templates/geneView_wilson_link.Rmd delete mode 100644 inst/templates/heatmap_wilson_link.Rmd delete mode 100644 inst/templates/scatterplot_wilson_link.Rmd diff --git a/inst/templates/geneView_wilson.Rmd b/inst/templates/geneView_wilson.Rmd index 50e3c78..d857173 100644 --- a/inst/templates/geneView_wilson.Rmd +++ b/inst/templates/geneView_wilson.Rmd @@ -4,7 +4,7 @@ ```{r} -{{ env_id }} = readRDS("envs/{{ env_id }}.rds") +{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") ``` @@ -53,10 +53,7 @@ plot ``` ```{r, eval=is_shiny} -######### -library(shinyWidgets) -############# - +################ UI #################### ui_list <- list() # select type of plot @@ -88,72 +85,151 @@ ui_list <- rlist::list.append(ui_list, ) # 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) + sliderInput("colnumber_{{ env_id }}", label = "Number of 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] - } - } +################# Server #################### +# if component is a reciever +if({{ env_id }}$compId %in% edgeTable$reciever){ - # 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]]) + # set variables + reciever_{{ env_id }} <- {{ env_id }}$compId + transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - additional_arguments$data <- data - additional_arguments$grouping <- grouping - return(list("params" = additional_arguments, "data" = data, "grouping" = grouping)) -}) + 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 + } + + additional_arguments$plot.method <- "static" + + # Set values for 'group_by' and 'countTable' + 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 }}] + } + countTable <- {{ env_id }}$countTable + + # subset countTable according to transmitted sample keys + plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) + keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") + selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key + if(!is.null(selection_transmitter)){ + if(all(selection_transmitter %in% colnames(countTable))){ + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } else { + false_keys <- which(!(selection_transmitter %in% colnames(countTable))) + print("The following keys are not in the countTable:") + print(selection_transmitter[false_keys]) + if(!is.null(ncol(selection_transmitter[-false_keys]))){ + selection_transmitter <- selection_transmitter[-false_keys] + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } + } + } + + # 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] + } + } + + # 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]]) + download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) + additional_arguments$data <- data + additional_arguments$grouping <- grouping + #additional_arguments$width <- 20 + #additional_arguments$height <- 15 + + return(list("params" = additional_arguments, "data" = download_dt)) + }) +} else { + 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 + } + + additional_arguments$plot.method <- "static" + + # Set values for 'group_by' and 'countTable' + 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 }}] + } + countTable <- {{ env_id }}$countTable + + # 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] + } + } + # + # 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]]) + download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) + additional_arguments$data <- data + additional_arguments$grouping <- grouping + #additional_arguments$width <- 20 + #additional_arguments$height <- 15 + return(list("params" = additional_arguments, "data" = download_dt)) + }) +} -# # Download -# -############ -# To do: provide both data.frames for download output$downloadData_{{ env_id }} <- downloadHandler( filename = paste('data-', Sys.Date(), '.csv', sep=''), content = function(file) { @@ -161,26 +237,36 @@ output$downloadData_{{ env_id }} <- downloadHandler( } ) -# +# works as transmitter with brushopt +plot_{{ env_id }} <- shiny::reactive({ + if(!is.null(input$select_subset_{{ env_id }})){ + output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) + dt <- output_list$plot$data + return(dt) + } +}) + # Output -# -output$plot_{{ env_id }} <- shiny::renderPlot({ +output$plot_{{ env_id }} <- 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 + gg <- output_list$plot + gg + #p <- plotly::ggplotly(gg) + #p } # convert to plotly object for automatic resizing }) -# # Layout of component -# shiny::fillRow(flex = c(NA, 1), - dropdownButton(do.call(shiny::inputPanel, ui_list), + shinyWidgets::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:")), - plotOutput("plot_{{ env_id }}") + tooltip = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), + plotOutput("plot_{{ env_id }}", width = "100%",click = "plot1_click", + brush = brushOpts( + id = "plot1_brush" + )) ) ``` diff --git a/inst/templates/geneView_wilson_link.Rmd b/inst/templates/geneView_wilson_link.Rmd deleted file mode 100644 index d857173..0000000 --- a/inst/templates/geneView_wilson_link.Rmd +++ /dev/null @@ -1,272 +0,0 @@ - -### {{ 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} -################ UI #################### -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 = "Number of 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'))) - -################# Server #################### -# if component is a reciever -if({{ env_id }}$compId %in% edgeTable$reciever){ - - # set variables - reciever_{{ env_id }} <- {{ env_id }}$compId - transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - - 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 - } - - additional_arguments$plot.method <- "static" - - # Set values for 'group_by' and 'countTable' - 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 }}] - } - countTable <- {{ env_id }}$countTable - - # subset countTable according to transmitted sample keys - plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) - keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") - selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key - if(!is.null(selection_transmitter)){ - if(all(selection_transmitter %in% colnames(countTable))){ - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } else { - false_keys <- which(!(selection_transmitter %in% colnames(countTable))) - print("The following keys are not in the countTable:") - print(selection_transmitter[false_keys]) - if(!is.null(ncol(selection_transmitter[-false_keys]))){ - selection_transmitter <- selection_transmitter[-false_keys] - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } - } - } - - # 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] - } - } - - # 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]]) - download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) - additional_arguments$data <- data - additional_arguments$grouping <- grouping - #additional_arguments$width <- 20 - #additional_arguments$height <- 15 - - return(list("params" = additional_arguments, "data" = download_dt)) - }) -} else { - 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 - } - - additional_arguments$plot.method <- "static" - - # Set values for 'group_by' and 'countTable' - 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 }}] - } - countTable <- {{ env_id }}$countTable - - # 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] - } - } - # - # 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]]) - download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) - additional_arguments$data <- data - additional_arguments$grouping <- grouping - #additional_arguments$width <- 20 - #additional_arguments$height <- 15 - return(list("params" = additional_arguments, "data" = download_dt)) - }) -} - -# Download -output$downloadData_{{ env_id }} <- downloadHandler( - filename = paste('data-', Sys.Date(), '.csv', sep=''), - content = function(file) { - write.csv(df_{{ env_id }}()$data, file) - } -) - -# works as transmitter with brushopt -plot_{{ env_id }} <- shiny::reactive({ - if(!is.null(input$select_subset_{{ env_id }})){ - output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) - dt <- output_list$plot$data - return(dt) - } -}) - -# Output -output$plot_{{ env_id }} <- renderPlot({ - if(!is.null(input$select_subset_{{ env_id }})){ - output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) - gg <- output_list$plot - gg - #p <- plotly::ggplotly(gg) - #p - } - # convert to plotly object for automatic resizing - -}) - -# Layout of component -shiny::fillRow(flex = c(NA, 1), - shinyWidgets::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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), - plotOutput("plot_{{ env_id }}", width = "100%",click = "plot1_click", - brush = brushOpts( - id = "plot1_brush" - )) -) -``` diff --git a/inst/templates/heatmap_wilson.Rmd b/inst/templates/heatmap_wilson.Rmd index 2947045..20b9e62 100644 --- a/inst/templates/heatmap_wilson.Rmd +++ b/inst/templates/heatmap_wilson.Rmd @@ -12,7 +12,6 @@ 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. @@ -78,8 +77,8 @@ heatmap ``` ```{r, eval=is_shiny} +################ UI #################### ui_list <- list() - # selection field for group_by if ({{ env_id }}$group_by_selection){ ui_list <- rlist::list.append(ui_list, @@ -151,106 +150,165 @@ output$select_columns_{{ env_id }} <- renderUI({ }) - - -# -# 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 +################# Server #################### +# if component is a reciever +if({{ env_id }}$compId %in% edgeTable$reciever){ - # "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] + # set variables + reciever_{{ env_id }} <- {{ env_id }}$compId + transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter + + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # "static" not possible yet + additional_arguments$plot.method <- "interactive" + + # 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 }} + + # sequential (one-sided) color palette + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color } - } - # 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] + + # 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 }}] } - } - - # 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 }} + # subset countTable according to transmitted sample keys + plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) + keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") + selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key + if(!is.null(selection_transmitter)){ + if(all(selection_transmitter %in% colnames(countTable))){ + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } else { + false_keys <- which(!(selection_transmitter %in% colnames(countTable))) + print("The following keys are not in the countTable:") + print(selection_transmitter[false_keys]) + if(!is.null(ncol(selection_transmitter[-false_keys]))){ + selection_transmitter <- selection_transmitter[-false_keys] + countTable <- subset(countTable, select = selection_transmitter) + # subset group_by according to countTable + group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] + group_by <- list("group_by" = group_by) + } + } + } + + # 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] + } + } + + # create data.table + dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) + + # 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,] + } + key <- NULL + additional_arguments$data <- dt + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) - return(list("params" = additional_arguments, "data" = dt)) -}) + # if compId is not a reciever +} else { -# -# Download -# -output$downloadData_{{ env_id }} <- downloadHandler( - filename = paste('data-', Sys.Date(), '.csv', sep=''), - content = function(file) { - write.csv(df_{{ env_id }}()$data, file) - } -) + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + + # "static" not possible yet + additional_arguments$plot.method <- "interactive" + + # 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 }} + + # sequential (one-sided) color palette + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color + } + + # 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] + } + } + + # create data.table + dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) + + # 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,] + } + key <- NULL + additional_arguments$data <- dt + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) +} -# -# Output -# +# create plot with wilson 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$x$source <- "plot_{{ env_id }}" + #heatmap %>% plotly::event_register("plotly_selected") + # no output as transmitter implemented 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)), + shinyWidgets::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:")), + tooltip = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), plotly::plotlyOutput("plot_{{ env_id }}", width = "100%", height = "400px") ) ``` diff --git a/inst/templates/heatmap_wilson_link.Rmd b/inst/templates/heatmap_wilson_link.Rmd deleted file mode 100644 index 20b9e62..0000000 --- a/inst/templates/heatmap_wilson_link.Rmd +++ /dev/null @@ -1,315 +0,0 @@ - -### {{ title }} - - - -```{r} -{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") - -is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") -``` - -```{r} -###### -library(magrittr) -##### -# -# 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 #################### -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) - -}) - -################# Server #################### -# if component is a reciever -if({{ env_id }}$compId %in% edgeTable$reciever){ - - # set variables - reciever_{{ env_id }} <- {{ env_id }}$compId - transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - - # "static" not possible yet - additional_arguments$plot.method <- "interactive" - - # 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 }} - - # sequential (one-sided) color palette - if("color" %ni% names({{ env_id }}$additional_arguments)){ - color <- RColorBrewer::brewer.pal(9, "YlOrRd") - additional_arguments$color <- color - } - - # 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 according to transmitted sample keys - plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) - keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") - selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key - if(!is.null(selection_transmitter)){ - if(all(selection_transmitter %in% colnames(countTable))){ - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } else { - false_keys <- which(!(selection_transmitter %in% colnames(countTable))) - print("The following keys are not in the countTable:") - print(selection_transmitter[false_keys]) - if(!is.null(ncol(selection_transmitter[-false_keys]))){ - selection_transmitter <- selection_transmitter[-false_keys] - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } - } - } - - # 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] - } - } - - # create data.table - dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) - - # 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,] - } - key <- NULL - additional_arguments$data <- dt - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) - - # if compId is not a reciever -} else { - - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - - # "static" not possible yet - additional_arguments$plot.method <- "interactive" - - # 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 }} - - # sequential (one-sided) color palette - if("color" %ni% names({{ env_id }}$additional_arguments)){ - color <- RColorBrewer::brewer.pal(9, "YlOrRd") - additional_arguments$color <- color - } - - # 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] - } - } - - # create data.table - dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) - - # 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,] - } - key <- NULL - additional_arguments$data <- dt - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) -} - -# create plot with wilson -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$x$source <- "plot_{{ env_id }}" - #heatmap %>% plotly::event_register("plotly_selected") - # no output as transmitter implemented - heatmap -}) - -# Layout of component -shiny::fillRow(flex = c(NA, 1), - shinyWidgets::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 = shinyWidgets::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 index 1f0f3cf..262a114 100644 --- a/inst/templates/scatterplot_wilson.Rmd +++ b/inst/templates/scatterplot_wilson.Rmd @@ -3,8 +3,8 @@ -```{r} -{{ env_id }} = readRDS("envs/{{ env_id }}.rds") + ```{r} +{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") ``` @@ -39,21 +39,21 @@ if (!is.null({{ env_id }}$colour_by)){ # 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 + # 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 + # 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 @@ -95,6 +95,10 @@ gg ``` ```{r, eval=is_shiny} +############## +library(magrittr) +############# +################# UI #################### ui_list <- list() # selection field for x if ({{ env_id }}$x_selection){ @@ -122,72 +126,104 @@ 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)) - )) + )) +} + +if ({{ env_id }}$compId %in% edgeTable$transmitter) { + ui_list <- rlist::list.append(ui_list, + tags$div(radioButtons("linking_mode_{{ env_id }}", label = "Select linking mode: ", + choices = list("Subsetting", "Highlighting"), + selected = "Subsetting"))) + ui_list <- rlist::list.append(ui_list, + tags$div(colourpicker::colourInput("col_{{ env_id }}", "Select colour for highlighting:", "red"))) } # 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 }},] +################# Server #################### +# if compId exists and component is a reciever +if({{ env_id }}$compId %in% edgeTable$reciever){ + # set variables + reciever_{{ env_id }} <- {{ env_id }}$compId + transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter + + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + additional_arguments$plot.method <- "static" + + 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"]) + df["colour_by"] <- as.character(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 + # 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 + #df["colour_by"] <- droplevels(df["colour_by"]) + df["colour_by"] <- as.character(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 @@ -195,50 +231,167 @@ df_{{ env_id }} <- shiny::reactive({ } } } - } 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) + + if("data.labels" %in% names(additional_arguments)){ + dt[[1]] <- additional_arguments$data.labels + } + + # get all and selected keys from transmitter + plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) + keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") + color_transmitter_string <- paste0("input$col_env_", transmitter_to_{{ env_id }}) + color_transmitter <- eval(parse(text = color_transmitter_string)) + linking_mode_transmitter_string <- paste0("input$linking_mode_env_", transmitter_to_{{ env_id }}) + linking_mode_transmitter <- eval(parse(text = linking_mode_transmitter_string)) + all_keys_transmitter <- eval(parse(text = keys_transmitter_string)) + selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key + if (!is.null(selection_transmitter)) { + m <- match(selection_transmitter, dt[[1]]) + if(linking_mode_transmitter == "Subsetting"){ + dt <- dt[na.omit(m), ] + } else if (linking_mode_transmitter == "Highlighting") { + additional_arguments$highlight.data <- dt[na.omit(m), ] + additional_arguments$highlight.color <- color_transmitter + } + } + + additional_arguments$data <- dt + + key <- NULL + + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) + # if compId doesn't exists +} else { + # Create reactive data table + df_{{ env_id }} <- shiny::reactive({ + # set parameters for wilson::create_scatterplot() + "%ni%" <- Negate("%in%") + additional_arguments <- {{ env_id }}$additional_arguments + additional_arguments$plot.method <- "static" + + 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 + # 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 + } } - } 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 key for linking components + if("data.labels" %in% names(additional_arguments)){ + key <- additional_arguments$data.labels + } else { + key <- dt[[1]] } - } - # Create data.table from data.frame - dt <- data.table::setDT(df) - additional_arguments$data <- dt - - return(list("params" = additional_arguments, "data" = dt)) -}) + return(list("params" = additional_arguments, "data" = dt, "key" = key)) + }) +} -# # Download -# output$downloadData_{{ env_id }} <- downloadHandler( filename = paste('data-', Sys.Date(), '.csv', sep=''), content = function(file) { @@ -246,26 +399,24 @@ output$downloadData_{{ env_id }} <- downloadHandler( } ) -# -# Output -# +# create plot with wilson 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 + output_list <- do.call(wilson::create_scatterplot, df_{{ env_id }}()$params) + gg <- output_list$plot #ggplot object + gg$mapping$key <- df_{{ env_id }}()$key + gg$label <- "key" + # convert to plotly object for automatic resizing + p <- plotly::ggplotly(gg) + p$x$source <- "plot_{{ env_id }}" + p %>% plotly::event_register("plotly_selected") }) -# # Layout of component -# -shiny::fillCol(flex = c(NA, 1), - do.call(shiny::inputPanel, ui_list), - plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") +shiny::fillRow(flex = c(NA, 1), + shinyWidgets::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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), + plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") ) ``` diff --git a/inst/templates/scatterplot_wilson_link.Rmd b/inst/templates/scatterplot_wilson_link.Rmd deleted file mode 100644 index 262a114..0000000 --- a/inst/templates/scatterplot_wilson_link.Rmd +++ /dev/null @@ -1,422 +0,0 @@ - -### {{ 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} -############## -library(magrittr) -############# -################# UI #################### -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)) - )) -} - -if ({{ env_id }}$compId %in% edgeTable$transmitter) { - ui_list <- rlist::list.append(ui_list, - tags$div(radioButtons("linking_mode_{{ env_id }}", label = "Select linking mode: ", - choices = list("Subsetting", "Highlighting"), - selected = "Subsetting"))) - ui_list <- rlist::list.append(ui_list, - tags$div(colourpicker::colourInput("col_{{ env_id }}", "Select colour for highlighting:", "red"))) -} - -# Download link -ui_list <- rlist::list.append(ui_list, tags$div(tags$br(), downloadButton('downloadData_{{ env_id }}', 'Download data'))) - -################# Server #################### -# if compId exists and component is a reciever -if({{ env_id }}$compId %in% edgeTable$reciever){ - # set variables - reciever_{{ env_id }} <- {{ env_id }}$compId - transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - additional_arguments$plot.method <- "static" - - 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"]) - df["colour_by"] <- as.character(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"]) - df["colour_by"] <- as.character(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) - - if("data.labels" %in% names(additional_arguments)){ - dt[[1]] <- additional_arguments$data.labels - } - - # get all and selected keys from transmitter - plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) - keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") - color_transmitter_string <- paste0("input$col_env_", transmitter_to_{{ env_id }}) - color_transmitter <- eval(parse(text = color_transmitter_string)) - linking_mode_transmitter_string <- paste0("input$linking_mode_env_", transmitter_to_{{ env_id }}) - linking_mode_transmitter <- eval(parse(text = linking_mode_transmitter_string)) - all_keys_transmitter <- eval(parse(text = keys_transmitter_string)) - selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key - if (!is.null(selection_transmitter)) { - m <- match(selection_transmitter, dt[[1]]) - if(linking_mode_transmitter == "Subsetting"){ - dt <- dt[na.omit(m), ] - } else if (linking_mode_transmitter == "Highlighting") { - additional_arguments$highlight.data <- dt[na.omit(m), ] - additional_arguments$highlight.color <- color_transmitter - } - } - - additional_arguments$data <- dt - - key <- NULL - - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) - # if compId doesn't exists -} else { - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - additional_arguments$plot.method <- "static" - - 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 - - # provide key for linking components - if("data.labels" %in% names(additional_arguments)){ - key <- additional_arguments$data.labels - } else { - key <- dt[[1]] - } - - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) -} - -# Download -output$downloadData_{{ env_id }} <- downloadHandler( - filename = paste('data-', Sys.Date(), '.csv', sep=''), - content = function(file) { - write.csv(df_{{ env_id }}()$data, file) - } -) - -# create plot with wilson -output$plot_{{ env_id }} <- plotly::renderPlotly({ - output_list <- do.call(wilson::create_scatterplot, df_{{ env_id }}()$params) - gg <- output_list$plot #ggplot object - gg$mapping$key <- df_{{ env_id }}()$key - gg$label <- "key" - # convert to plotly object for automatic resizing - p <- plotly::ggplotly(gg) - p$x$source <- "plot_{{ env_id }}" - p %>% plotly::event_register("plotly_selected") -}) - -# Layout of component -shiny::fillRow(flex = c(NA, 1), - shinyWidgets::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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), - plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") -) -``` - From 5ac1047c66fb718556fc669648663d0bef0c8600 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 14:44:36 +0200 Subject: [PATCH 14/15] removed compId parameter --- R/i2dash.R | 39 +++++++++--------------------------- man/geneview_to_i2dash.Rd | 5 +---- man/heatmap_to_i2dash.Rd | 5 +---- man/scatterplot_to_i2dash.Rd | 4 +--- 4 files changed, 12 insertions(+), 41 deletions(-) diff --git a/R/i2dash.R b/R/i2dash.R index 7fb147f..2b7a1e7 100644 --- a/R/i2dash.R +++ b/R/i2dash.R @@ -3,14 +3,13 @@ #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @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, compId = NULL, title = NULL, ...) { +heatmap_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("stringi", quietly = TRUE) || !requireNamespace("magrittr", quietly = TRUE)) { @@ -18,12 +17,8 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title } # Create env id - if (is.null(compId)) { - compId <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") # this compId is for the check in the Rmd file and is not saved in object@compIds - env_id <- paste0("env_", compId) - } else { - env_id <- paste0("env_", compId) - } + 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) @@ -55,8 +50,6 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title env$additional_arguments <- additional_arguments - env$compId <- compId - # Save environment object saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) @@ -71,14 +64,13 @@ heatmap_to_i2dash <- function(object, countTable, group_by, compId = NULL, title #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @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, compId = NULL, title = NULL, ...) { +geneview_to_i2dash <- function(object, countTable, group_by, title = NULL, ...) { if (!requireNamespace("i2dash", quietly = TRUE) || !requireNamespace("stringi", quietly = TRUE) || !requireNamespace("magrittr", quietly = TRUE)) { @@ -86,12 +78,8 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl } # Create env id - if (is.null(compId)) { - compId <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") # this compId is for the check in the Rmd file and is not saved in object@compIds - env_id <- paste0("env_", compId) - } else { - env_id <- paste0("env_", compId) - } + 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) @@ -120,8 +108,6 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl env$additional_arguments <- additional_arguments - env$compId <- compId - # Save environment object saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) @@ -138,14 +124,13 @@ geneview_to_i2dash <- function(object, countTable, group_by, compId = NULL, titl #' @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 compId (Optional) The component ID provided through add_component and used for linking components together. #' @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, compId = NULL, title = NULL, ...) { +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)) { @@ -153,12 +138,8 @@ scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = N } # Create env id - if (is.null(compId)) { - compId <- stringi::stri_rand_strings(1, 6, pattern = "[A-Za-z0-9]") # this compId is for the check in the Rmd file and is not saved in object@compIds - env_id <- paste0("env_", compId) - } else { - env_id <- paste0("env_", compId) - } + 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) @@ -211,8 +192,6 @@ scatterplot_to_i2dash <- function(object, x, y, colour_by = NULL, expression = N env$additional_arguments <- additional_arguments - env$compId <- compId - # Save environment object saveRDS(env, file = file.path(object@workdir, "envs", paste0(env_id, ".rds"))) diff --git a/man/geneview_to_i2dash.Rd b/man/geneview_to_i2dash.Rd index aead0ca..7c1a76e 100644 --- a/man/geneview_to_i2dash.Rd +++ b/man/geneview_to_i2dash.Rd @@ -4,8 +4,7 @@ \alias{geneview_to_i2dash} \title{Prepare a geneview to be rendered with the i2dash package.} \usage{ -geneview_to_i2dash(object, countTable, group_by, compId = NULL, - title = NULL, ...) +geneview_to_i2dash(object, countTable, group_by, title = NULL, ...) } \arguments{ \item{object}{A \linkS4class{i2dash::i2dashboard} object.} @@ -14,8 +13,6 @@ geneview_to_i2dash(object, countTable, group_by, compId = NULL, \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{compId}{(Optional) The component ID provided through add_component and used for linking components together.} - \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}}.} diff --git a/man/heatmap_to_i2dash.Rd b/man/heatmap_to_i2dash.Rd index 6abaf08..353d3d4 100644 --- a/man/heatmap_to_i2dash.Rd +++ b/man/heatmap_to_i2dash.Rd @@ -4,8 +4,7 @@ \alias{heatmap_to_i2dash} \title{Prepare a heatmap to be rendered with the i2dash package.} \usage{ -heatmap_to_i2dash(object, countTable, group_by, compId = NULL, - title = NULL, ...) +heatmap_to_i2dash(object, countTable, group_by, title = NULL, ...) } \arguments{ \item{object}{A \linkS4class{i2dash::i2dashboard} object.} @@ -14,8 +13,6 @@ heatmap_to_i2dash(object, countTable, group_by, compId = NULL, \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{compId}{(Optional) The component ID provided through add_component and used for linking components together.} - \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}}.} diff --git a/man/scatterplot_to_i2dash.Rd b/man/scatterplot_to_i2dash.Rd index 211a7ea..a2645e9 100644 --- a/man/scatterplot_to_i2dash.Rd +++ b/man/scatterplot_to_i2dash.Rd @@ -5,7 +5,7 @@ \title{Prepare a scatterplot to be rendered with the i2dash package.} \usage{ scatterplot_to_i2dash(object, x, y, colour_by = NULL, - expression = NULL, compId = NULL, title = NULL, ...) + expression = NULL, title = NULL, ...) } \arguments{ \item{object}{A \linkS4class{i2dash::i2dashboard} object.} @@ -18,8 +18,6 @@ scatterplot_to_i2dash(object, x, y, colour_by = NULL, \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{compId}{(Optional) The component ID provided through add_component and used for linking components together.} - \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}}.} From 6e3761b80b52295e404623c10a6aaebd184ddb19 Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 14:45:31 +0200 Subject: [PATCH 15/15] update templates (apparently I forgot earlier) --- inst/templates/geneView_wilson.Rmd | 230 +++++----------- inst/templates/heatmap_wilson.Rmd | 226 ++++++---------- inst/templates/scatterplot_wilson.Rmd | 373 ++++++++------------------ 3 files changed, 267 insertions(+), 562 deletions(-) diff --git a/inst/templates/geneView_wilson.Rmd b/inst/templates/geneView_wilson.Rmd index d857173..50e3c78 100644 --- a/inst/templates/geneView_wilson.Rmd +++ b/inst/templates/geneView_wilson.Rmd @@ -4,7 +4,7 @@ ```{r} -{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") +{{ env_id }} = readRDS("envs/{{ env_id }}.rds") is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") ``` @@ -53,7 +53,10 @@ plot ``` ```{r, eval=is_shiny} -################ UI #################### +######### +library(shinyWidgets) +############# + ui_list <- list() # select type of plot @@ -85,151 +88,72 @@ ui_list <- rlist::list.append(ui_list, ) # selection column number of plot ui_list <- rlist::list.append(ui_list, - sliderInput("colnumber_{{ env_id }}", label = "Number of plot columns:", min = 1, max = 7, value = 3) + 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'))) -################# Server #################### -# if component is a reciever -if({{ env_id }}$compId %in% edgeTable$reciever){ +# +# Create reactive data table +# +df_{{ env_id }} <- shiny::reactive({ - # set variables - reciever_{{ env_id }} <- {{ env_id }}$compId - transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - - 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 - } - - additional_arguments$plot.method <- "static" - - # Set values for 'group_by' and 'countTable' - 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 }}] - } - countTable <- {{ env_id }}$countTable - - # subset countTable according to transmitted sample keys - plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) - keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") - selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key - if(!is.null(selection_transmitter)){ - if(all(selection_transmitter %in% colnames(countTable))){ - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } else { - false_keys <- which(!(selection_transmitter %in% colnames(countTable))) - print("The following keys are not in the countTable:") - print(selection_transmitter[false_keys]) - if(!is.null(ncol(selection_transmitter[-false_keys]))){ - selection_transmitter <- selection_transmitter[-false_keys] - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } - } - } - - # 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] - } - } - - # 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]]) - download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) - additional_arguments$data <- data - additional_arguments$grouping <- grouping - #additional_arguments$width <- 20 - #additional_arguments$height <- 15 - - return(list("params" = additional_arguments, "data" = download_dt)) - }) -} else { - 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 - } - - additional_arguments$plot.method <- "static" - - # Set values for 'group_by' and 'countTable' - 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 }}] - } - countTable <- {{ env_id }}$countTable - - # 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] - } + # 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]]) - download_dt <- data.table::data.table("features" = rownames(countTable), "factor" = group_by[[1]], countTable) - additional_arguments$data <- data - additional_arguments$grouping <- grouping - #additional_arguments$width <- 20 - #additional_arguments$height <- 15 - return(list("params" = additional_arguments, "data" = download_dt)) - }) -} + } + + # 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) { @@ -237,36 +161,26 @@ output$downloadData_{{ env_id }} <- downloadHandler( } ) -# works as transmitter with brushopt -plot_{{ env_id }} <- shiny::reactive({ - if(!is.null(input$select_subset_{{ env_id }})){ - output_list <- do.call(wilson::create_geneview, df_{{ env_id }}()$params) - dt <- output_list$plot$data - return(dt) - } -}) - +# # Output -output$plot_{{ env_id }} <- renderPlot({ +# +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) - gg <- output_list$plot - gg - #p <- plotly::ggplotly(gg) - #p + plot <- output_list$plot + plot } # convert to plotly object for automatic resizing }) +# # Layout of component +# shiny::fillRow(flex = c(NA, 1), - shinyWidgets::dropdownButton(div(style='max-height: 350px; overflow-x: auto;',do.call(shiny::inputPanel, ui_list)), + dropdownButton(do.call(shiny::inputPanel, ui_list), circle = TRUE, status = "danger", icon = icon("gear"), width = "300px", - tooltip = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), - plotOutput("plot_{{ env_id }}", width = "100%",click = "plot1_click", - brush = brushOpts( - id = "plot1_brush" - )) + 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 index 20b9e62..2947045 100644 --- a/inst/templates/heatmap_wilson.Rmd +++ b/inst/templates/heatmap_wilson.Rmd @@ -12,6 +12,7 @@ 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. @@ -77,8 +78,8 @@ heatmap ``` ```{r, eval=is_shiny} -################ UI #################### ui_list <- list() + # selection field for group_by if ({{ env_id }}$group_by_selection){ ui_list <- rlist::list.append(ui_list, @@ -150,165 +151,106 @@ output$select_columns_{{ env_id }} <- renderUI({ }) -################# Server #################### -# if component is a reciever -if({{ env_id }}$compId %in% edgeTable$reciever){ - - # set variables - reciever_{{ env_id }} <- {{ env_id }}$compId - transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - - # "static" not possible yet - additional_arguments$plot.method <- "interactive" - - # 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 }} - - # sequential (one-sided) color palette - if("color" %ni% names({{ env_id }}$additional_arguments)){ - color <- RColorBrewer::brewer.pal(9, "YlOrRd") - additional_arguments$color <- color - } - - # 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 according to transmitted sample keys - plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) - keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") - selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key - if(!is.null(selection_transmitter)){ - if(all(selection_transmitter %in% colnames(countTable))){ - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } else { - false_keys <- which(!(selection_transmitter %in% colnames(countTable))) - print("The following keys are not in the countTable:") - print(selection_transmitter[false_keys]) - if(!is.null(ncol(selection_transmitter[-false_keys]))){ - selection_transmitter <- selection_transmitter[-false_keys] - countTable <- subset(countTable, select = selection_transmitter) - # subset group_by according to countTable - group_by <- group_by[[1]][which(colnames(countTable) == selection_transmitter)] - group_by <- list("group_by" = group_by) - } - } - } - - # 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] - } + +# +# 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] } - - # create data.table - dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) - - # 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,] + } + # 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] } - key <- NULL - additional_arguments$data <- dt - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) + } + + # 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,] + } - # if compId is not a reciever -} else { + + # 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)) +}) - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - - # "static" not possible yet - additional_arguments$plot.method <- "interactive" - - # 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 }} - - # sequential (one-sided) color palette - if("color" %ni% names({{ env_id }}$additional_arguments)){ - color <- RColorBrewer::brewer.pal(9, "YlOrRd") - additional_arguments$color <- color - } - - # 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] - } - } - - # create data.table - dt <- create_data.table('matrix' = countTable, 'group_by' = group_by[[1]]) - - # 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,] - } - key <- NULL - additional_arguments$data <- dt - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) -} +# +# Download +# +output$downloadData_{{ env_id }} <- downloadHandler( + filename = paste('data-', Sys.Date(), '.csv', sep=''), + content = function(file) { + write.csv(df_{{ env_id }}()$data, file) + } +) -# create plot with wilson +# +# 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$x$source <- "plot_{{ env_id }}" - #heatmap %>% plotly::event_register("plotly_selected") - # no output as transmitter implemented heatmap }) +# # Layout of component +# shiny::fillRow(flex = c(NA, 1), - shinyWidgets::dropdownButton(div(style='max-height: 350px; overflow-x: auto;',do.call(shiny::inputPanel, ui_list)), + 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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), + 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 index 262a114..1f0f3cf 100644 --- a/inst/templates/scatterplot_wilson.Rmd +++ b/inst/templates/scatterplot_wilson.Rmd @@ -3,8 +3,8 @@ - ```{r} -{{ env_id }} <- readRDS("envs/{{ env_id }}.rds") +```{r} +{{ env_id }} = readRDS("envs/{{ env_id }}.rds") is_shiny <- identical(knitr::opts_knit$get("rmarkdown.runtime"), "shiny") ``` @@ -39,21 +39,21 @@ if (!is.null({{ env_id }}$colour_by)){ # 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 + # 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 + # 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 @@ -95,10 +95,6 @@ gg ``` ```{r, eval=is_shiny} -############## -library(magrittr) -############# -################# UI #################### ui_list <- list() # selection field for x if ({{ env_id }}$x_selection){ @@ -126,104 +122,72 @@ 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)) - )) -} - -if ({{ env_id }}$compId %in% edgeTable$transmitter) { - ui_list <- rlist::list.append(ui_list, - tags$div(radioButtons("linking_mode_{{ env_id }}", label = "Select linking mode: ", - choices = list("Subsetting", "Highlighting"), - selected = "Subsetting"))) - ui_list <- rlist::list.append(ui_list, - tags$div(colourpicker::colourInput("col_{{ env_id }}", "Select colour for highlighting:", "red"))) + )) } # Download link ui_list <- rlist::list.append(ui_list, tags$div(tags$br(), downloadButton('downloadData_{{ env_id }}', 'Download data'))) -################# Server #################### -# if compId exists and component is a reciever -if({{ env_id }}$compId %in% edgeTable$reciever){ - # set variables - reciever_{{ env_id }} <- {{ env_id }}$compId - transmitter_to_{{ env_id }} <- edgeTable[reciever=={{ env_id }}$compId]$transmitter - - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - additional_arguments$plot.method <- "static" - - 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"]) - df["colour_by"] <- as.character(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 - } - } - } - } +# +# 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 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 + # if colour_by is factor } else if (is.factor(df[["colour_by"]])){ additional_arguments$categorized <- T - #df["colour_by"] <- droplevels(df["colour_by"]) - df["colour_by"] <- as.character(df[["colour_by"]]) - # if colour_by is numeric + 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 @@ -231,167 +195,50 @@ if({{ env_id }}$compId %in% edgeTable$reciever){ } } } - # 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) - - if("data.labels" %in% names(additional_arguments)){ - dt[[1]] <- additional_arguments$data.labels - } - - # get all and selected keys from transmitter - plot_transmitter_string <- paste0("plot_env_", transmitter_to_{{ env_id }}) - keys_transmitter_string <- paste0("df_env_", transmitter_to_{{ env_id }}, "()$key") - color_transmitter_string <- paste0("input$col_env_", transmitter_to_{{ env_id }}) - color_transmitter <- eval(parse(text = color_transmitter_string)) - linking_mode_transmitter_string <- paste0("input$linking_mode_env_", transmitter_to_{{ env_id }}) - linking_mode_transmitter <- eval(parse(text = linking_mode_transmitter_string)) - all_keys_transmitter <- eval(parse(text = keys_transmitter_string)) - selection_transmitter <- plotly::event_data("plotly_selected", source = plot_transmitter_string)$key - if (!is.null(selection_transmitter)) { - m <- match(selection_transmitter, dt[[1]]) - if(linking_mode_transmitter == "Subsetting"){ - dt <- dt[na.omit(m), ] - } else if (linking_mode_transmitter == "Highlighting") { - additional_arguments$highlight.data <- dt[na.omit(m), ] - additional_arguments$highlight.color <- color_transmitter - } - } - - additional_arguments$data <- dt - - key <- NULL - - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) - # if compId doesn't exists -} else { - # Create reactive data table - df_{{ env_id }} <- shiny::reactive({ - # set parameters for wilson::create_scatterplot() - "%ni%" <- Negate("%in%") - additional_arguments <- {{ env_id }}$additional_arguments - additional_arguments$plot.method <- "static" - - 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 - } + } 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 - } + } + # 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 } - - # Create data.table from data.frame - dt <- data.table::setDT(df) - additional_arguments$data <- dt - - # provide key for linking components - if("data.labels" %in% names(additional_arguments)){ - key <- additional_arguments$data.labels - } else { - key <- dt[[1]] + } else { + # sequential (one-sided) color palettes + if("color" %ni% names({{ env_id }}$additional_arguments)){ + color <- RColorBrewer::brewer.pal(9, "YlOrRd") + additional_arguments$color <- color } + } - return(list("params" = additional_arguments, "data" = dt, "key" = key)) - }) -} + # 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) { @@ -399,24 +246,26 @@ output$downloadData_{{ env_id }} <- downloadHandler( } ) -# create plot with wilson +# +# Output +# output$plot_{{ env_id }} <- plotly::renderPlotly({ - output_list <- do.call(wilson::create_scatterplot, df_{{ env_id }}()$params) - gg <- output_list$plot #ggplot object - gg$mapping$key <- df_{{ env_id }}()$key - gg$label <- "key" - # convert to plotly object for automatic resizing - p <- plotly::ggplotly(gg) - p$x$source <- "plot_{{ env_id }}" - p %>% plotly::event_register("plotly_selected") + 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::fillRow(flex = c(NA, 1), - shinyWidgets::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 = shinyWidgets::tooltipOptions(title = "Click, to change plot settings:")), - plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") +# +shiny::fillCol(flex = c(NA, 1), + do.call(shiny::inputPanel, ui_list), + plotly::plotlyOutput("plot_{{ env_id }}", height = "100%") ) ```