From 25ae6322b88219f0d1ab2a430e06dc92a1836edb Mon Sep 17 00:00:00 2001 From: Julien DIOT Date: Tue, 17 Sep 2024 17:50:28 +0900 Subject: [PATCH] feat(data-viz): initialise data-viz menu --- server.R | 1 + src/fun/func_data-viz.R | 298 ++++++++++++++++++++++++++++++++++ src/server/server_data_viz.R | 124 ++++++++++++++ src/ui/ui_data-viz_loggedIn.R | 50 ++++++ ui.R | 12 ++ 5 files changed, 485 insertions(+) create mode 100644 src/fun/func_data-viz.R create mode 100644 src/server/server_data_viz.R create mode 100644 src/ui/ui_data-viz_loggedIn.R diff --git a/server.R b/server.R index de15411..5778772 100644 --- a/server.R +++ b/server.R @@ -59,6 +59,7 @@ shinyServer(function(input, output, session) { source("src/server/server_plant_material.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_pheno.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_geno.R", local = TRUE, encoding = "UTF-8")$value + source("src/server/server_data_viz.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_eval.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_theory.R", local = TRUE, encoding = "UTF-8")$value source("src/server/server_admin.R", local = TRUE, encoding = "UTF-8")$value diff --git a/src/fun/func_data-viz.R b/src/fun/func_data-viz.R new file mode 100644 index 0000000..4846031 --- /dev/null +++ b/src/fun/func_data-viz.R @@ -0,0 +1,298 @@ +none_value <- "-- None --" + +data_viz_ui <- function(id) { + ns <- NS(id) + div( + div( + selectInput(ns("x_var"), + "X variable", + choices = list(none_value), + multiple = FALSE + ), + selectInput(ns("y_var"), + "Y variable", + choices = list(none_value), + multiple = FALSE + ), + selectInput(ns("col_var"), + "Color variable", + choices = list(none_value), + multiple = FALSE + ) + ), + div( + plotlyOutput(ns("plot")) + ) + ) +} + +data_viz_server <- function(id, plot_data) { + moduleServer(id, function(input, output, session) { + + observe({ + data <- plot_data() + if (is.null(data)) { + updateSelectInput(session, "x_var", + choices = none_value, + ) + updateSelectInput(session, "y_var", + choices = none_value, + ) + updateSelectInput(session, "col_var", + choices = none_value, + ) + return(NULL) + } + + var_list <- colnames(data) + var_list <- c(none_value, var_list) + updateSelectInput(session, "x_var", + choices = var_list, + selected = ifelse(!is_null_var(input$x_var) && input$x_var %in% var_list, input$x_var, var_list[2]) + ) + updateSelectInput(session, "y_var", + choices = var_list, + selected = ifelse(!is_null_var(input$x_var) && input$y_var %in% var_list, input$y_var, var_list[1]) + ) + updateSelectInput(session, "col_var", + choices = var_list, + selected = ifelse(!is_null_var(input$x_var) && input$col_var %in% var_list, input$col_var, var_list[1]) + ) + }) + + output$plot <- renderPlotly({ + data <- plot_data() + if ((input$x_var == none_value && input$y_var == none_value) || is.null(data)) { + return(empty_plot("No data to show")) + } + + if (input$x_var == none_value || input$y_var == none_value) { + return( + plot_1D( + data = data, + x_var = input$x_var, + y_var = input$y_var, + col_var = input$col_var + ) + ) + } + + return( + plot_2D( + data = data, + x_var = input$x_var, + y_var = input$y_var, + col_var = input$col_var + ) + ) + }) + }) +} + +empty_plot <- function(info = "") { + return(plot_ly(type = "scatter", mode = "markers") %>% + add_annotations( + x=0.5, y=0.5, xref = "paper", yref = "paper", + text = info, + xanchor = 'center', + showarrow = FALSE + )) +} + +plot_1D <- function(data, x_var, y_var, col_var) { + var_of_interest <- c(x_var, y_var)[ which(!is_null_var(c(x_var, y_var))) ] + + if (is.numeric(data[, var_of_interest])) { + return(histogram(data, x_var, y_var, col_var)) + } + barplot(data, x_var, y_var, col_var) +} + +plot_2D <- function(data, x_var, y_var, col_var) { + if (is.numeric(data[, x_var]) && is.numeric(data[, y_var])) { + return(scatter_plot(data, x_var, y_var, col_var)) + } + if (any(c(is.numeric(data[, x_var]), is.numeric(data[, y_var])))) { + return(box_plot(data, x_var, y_var, col_var)) + } + empty_plot("Plot for two categorical variables is not implemented.\nYou could rather use one variable as X axis and the other as color.") +} + +scatter_plot <- function(data, x_var, y_var, col_var) { + color <- NULL + if (!is_null_var(col_var)) { + color <- data[, col_var] + } + p <- plot_ly(type = "scatter", + mode = "markers", + data = data, + x = data[, x_var], + y = data[, y_var], + color = color, + hoverinfo = "text", + text = apply(data, 1, function(l) { + paste(names(l), ":", l, collapse = "\n") + })) + p <- layout(p, + yaxis = list(title = y_var), + xaxis = list(title = x_var), + legend = list(title = list(text = col_var)) + ) + p +} + +box_plot <- function(data, x_var, y_var, col_var) { + color <- NULL + if (!is_null_var(col_var)) { + color <- data[, col_var] + } + x_values <- NULL + if (!is_null_var(x_var)) { + x_values <- data[, x_var] + } + y_values <- NULL + if (!is_null_var(y_var)) { + y_values <- data[, y_var] + } + + p <- plot_ly( + type = "box", + data = data, + y = y_values, + x = x_values, + color = color, + boxpoints = "all", + jitter = 0.3, + pointpos = 0, + hoverinfo = "text", + text = apply(data, 1, function(l) { + paste(names(l), ":", l, collapse = "\n") + }) + ) + p <- layout(p, + boxmode = "group", + yaxis = list(title = y_var), + xaxis = list(title = x_var), + legend = list(title = list(text = col_var)) + ) + p +} + +histogram <- function(data, x_var, y_var, col_var) { + hist_axis_title <- "Number of observations" + data_list <- list(data) + + alpha <- 1 + if (!is_null_var(col_var)) { + data_list <- split(data, data[, col_var]) + alpha <- 0.6 + } + + x_values <- NULL + x_axis_title <- hist_axis_title + if (!is_null_var(x_var)) { + x_axis_title <- x_var + } + + y_values <- NULL + y_axis_title <- hist_axis_title + if (!is_null_var(y_var)) { + y_axis_title <- y_var + } + + p <- plot_ly( + type = "histogram", + alpha = alpha + ) + for (data_index in seq_along(data_list)) { + data <- data_list[[data_index]] + x_values <- NULL + if (!is_null_var(x_var)) { + x_values <- data[, x_var] + } + y_values <- NULL + if (!is_null_var(y_var)) { + y_values <- data[, y_var] + } + p <- add_histogram( + p, + data = data, + y = y_values, + x = x_values, + name = names(data_list)[data_index], + marker = list( + line = list(color = 'rgb(235, 237, 235)', width = 1) + ) + ) + } + + p <- layout( + p, + barmode = "overlay", + showlegend = !is_null_var(col_var), + yaxis = list(title = y_axis_title), + xaxis = list(title = x_axis_title), + legend = list(title = list(text = col_var)) + ) + p +} + + +barplot <- function(data, x_var, y_var, col_var) { + hist_axis_title <- "Number of observations" + + data <- data %>% + dplyr::mutate_if(is.character, as.factor) + + if (!is_null_var(col_var)) { + data <- dplyr::group_by(data, !!sym(col_var), .drop = FALSE) + } + + x_axis_title <- hist_axis_title + if (!is_null_var(x_var)) { + data <- dplyr::group_by(data, !!sym(x_var), .add = TRUE, .drop = FALSE) + x_axis_title <- x_var + } + + y_axis_title <- hist_axis_title + if (!is_null_var(y_var)) { + data <- dplyr::group_by(data, !!sym(y_var), .add = TRUE, .drop = FALSE) + y_axis_title <- y_var + } + + plt_data <- as.data.frame(dplyr::summarise(data, n = dplyr::n(), .groups = "drop"), stringsAsFactors = FALSE) + + if (!is_null_var(x_var)) { + x_values <- plt_data[[x_var]] + y_values <- plt_data[["n"]] + } else { + x_values <- plt_data[["n"]] + y_values <- plt_data[[y_var]] + } + + col_values <- NULL + if (!is_null_var(col_var)) { + col_values <- plt_data[[col_var]] + } + + p <- plot_ly(plt_data, + x = x_values, + y = y_values, + color = col_values, + type = 'bar') + + p <- layout( + p, + showlegend = !is_null_var(col_var), + yaxis = list(title = y_axis_title), + xaxis = list(title = x_axis_title), + barmode = 'stack', + legend = list(title = list(text = col_var)) + ) + p +} + +is_null_var <- function(vars) { + sapply(vars, function(var) { identical(var, none_value) }) +} + diff --git a/src/server/server_data_viz.R b/src/server/server_data_viz.R new file mode 100644 index 0000000..6db9e45 --- /dev/null +++ b/src/server/server_data_viz.R @@ -0,0 +1,124 @@ +## Copyright 2015,2016,2017,2018,2019 Institut National de la Recherche Agronomique +## and Montpellier SupAgro. +## +## This file is part of PlantBreedGame. +## +## PlantBreedGame is free software: you can redistribute it and/or modify +## it under the terms of the GNU Affero General Public License as +## published by the Free Software Foundation, either version 3 of the +## License, or (at your option) any later version. +## +## PlantBreedGame is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU Affero General Public +## License along with PlantBreedGame. If not, see +## . + + +## Function +source("src/fun/func_data-viz.R", local = TRUE, encoding = "UTF-8") + + + +###### server for "genotyping" ###### + +## Main UI ---- +output$data_viz_UI <- renderUI({ + if (!gameInitialised()) { + return( + source("src/ui/ui_gameNotInitialised.R", local = TRUE, encoding = "UTF-8")$value + ) + } + + if (breeder() != "No Identification" & breederStatus() != "player") { + return(source("src/ui/ui_data-viz_loggedIn.R", local = TRUE, encoding = "UTF-8")$value) + } + + return( + shinydashboard::box( + width = 12, title = "Content unavailable", + div(p("Sorry, you need the 'game-master' status or the 'tester' status to access this.")) + ) + ) +}) + + +raw_data_from_file <- reactive({ + if (is.null(input$file_data_viz)) { + return(NULL) + } + + df <- utils::read.table( + input$file_data_viz$datapath, + header = TRUE, + sep = "\t", + stringsAsFactors = FALSE + ) + + can_be_numeric_var <- sapply(colnames(df), function(var) { + numeric_values <- as.numeric(df[, var]) + !any(is.na(numeric_values)) + }) + numeric_var <- colnames(df)[can_be_numeric_var] + categ_var <- colnames(df)[!can_be_numeric_var] + + updateSelectInput(session, "quant_variables", + choices = numeric_var, + selected = numeric_var + ) + updateSelectInput(session, "categ_variables", + choices = colnames(df), + selected = categ_var + ) + shinyjs::disable("quant_variables") + df +}) + +# observeEvent(input$quant_variables, { +# # TODO: This part is not greate the observed is called 2 times which is not greate +# if (is.null(input$quant_variables)) { +# return(NULL) +# } +# data <- req(raw_data_from_file()) +# quant_var <- input$quant_variables +# categ_var <- colnames(data)[!colnames(data) %in% quant_var] +# if (!setequal(categ_var, input$categ_variables)) { +# updateSelectInput(session, "categ_variables", +# selected = categ_var +# ) +# } +# }) + +observeEvent(input$categ_variables, { + if (is.null(input$categ_variables)) { + return(NULL) + } + data <- req(raw_data_from_file()) + categ_var <- input$categ_variables + quant_var <- colnames(data)[!colnames(data) %in% categ_var] + if (!setequal(quant_var, input$quant_variables)) { + updateSelectInput(session, "quant_variables", + selected = quant_var + ) + } + +}) + + +data_from_file <- reactive({ + + data <- raw_data_from_file() + for (var in input$quant_variables) { + data[, var] <- as.numeric(data[, var]) + } + for (var in input$categ_variables) { + data[, var] <- as.character(data[, var]) + } + data +}) + +data_viz_server("data-viz_file", data_from_file) + diff --git a/src/ui/ui_data-viz_loggedIn.R b/src/ui/ui_data-viz_loggedIn.R new file mode 100644 index 0000000..6f3f38d --- /dev/null +++ b/src/ui/ui_data-viz_loggedIn.R @@ -0,0 +1,50 @@ +## Copyright 2015,2016,2017,2018,2019 Institut National de la Recherche Agronomique +## and Montpellier SupAgro. +## +## This file is part of PlantBreedGame. +## +## PlantBreedGame is free software: you can redistribute it and/or modify +## it under the terms of the GNU Affero General Public License as +## published by the Free Software Foundation, either version 3 of the +## License, or (at your option) any later version. +## +## PlantBreedGame is distributed in the hope that it will be useful, +## but WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU General Public License for more details. +## +## You should have received a copy of the GNU Affero General Public +## License along with PlantBreedGame. If not, see +## . +library(shiny) + +list( + shinydashboard::tabBox( + width = 12, title = "Data Visualisation", id = "data-viz", side = "left", selected = "From file", + tabPanel( + "From file", + div( + h4("Import file"), + fileInput( + inputId = "file_data_viz", + label = NULL, + multiple = FALSE, + accept = c(".txt", ".tsv", ".txt.gz") + ), + selectInput("quant_variables", + "Quantitative variables", + choices = list("None","var 1", "var 2", "var 3"), + multiple = TRUE + ), + selectInput("categ_variables", + "Categorical variables", + choices = list("var 1", "var 2", "var 3"), + multiple = TRUE + ) + ), + div( + data_viz_ui("data-viz_file") + ) + ) + ) +) diff --git a/ui.R b/ui.R index 63ba8c3..e00f98e 100644 --- a/ui.R +++ b/ui.R @@ -59,6 +59,10 @@ shinyUI( tabName = "geno", icon = icon("dna") ), + menuItem("Data Visualisation", + tabName = "data-viz", + icon = icon("chart-line") + ), menuItem("Evaluation", tabName = "eval", icon = icon("medal") @@ -159,6 +163,14 @@ shinyUI( # encoding = "UTF-8" # )$value, + # ---- Evaluation ---- + tabItem( + tabName = "data-viz", + fluidRow( + uiOutput("data_viz_UI") + ) + ), + # ---- Evaluation ---- tabItem( tabName = "eval",