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%") +) +``` +