From 233d37d437055cc89a74b63635c969fb9a63095e Mon Sep 17 00:00:00 2001 From: Schultheis Date: Fri, 26 Jul 2019 12:53:16 +0200 Subject: [PATCH] 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%") -) -``` -