diff --git a/R/mod_PCA.R b/R/mod_PCA.R index 9c871ba..e58cb44 100644 --- a/R/mod_PCA.R +++ b/R/mod_PCA.R @@ -20,13 +20,24 @@ mod_PCA_ui <- function(id){ fluidRow( useShinyjs(), inlineCSS(list(.borderred = "border-color: red", .redback = "background: red")), - + column(width = 3, box( title = "Inputs", width = 12, solidHeader = TRUE, status = "info", p("* Required"), fileInput(ns("dosage_file"), "Choose VCF File*", accept = c(".csv",".vcf",".gz")), - fileInput(ns("passport_file"), "Choose Passport File (Sample IDs in first column)", accept = c(".csv")), + #passport data header + radioGroupButtons(inputId = ns("passportImportType"), "Passport Data", choices = c("File Upload" = 1, "BrAPI" = 2), selected = 1), + #selection buttons + conditionalPanel(condition=("input.passportImportType==1"), + fileInput(ns("passport_file"), "Choose Passport File (Sample IDs in first column)", accept = c(".csv")), + ns=ns + ), + conditionalPanel(condition=("input.passportImportType==2"), + textInput(ns("brapi_token"), "Access Token"), + actionButton(ns("submit_token"), "Submit Token"), + ns=ns + ), #Dropdown will update after passport upload numericInput(ns("pca_ploidy"), "Species Ploidy*", min = 2, value = NULL), actionButton(ns("pca_start"), "Run Analysis"), @@ -93,6 +104,10 @@ mod_PCA_ui <- function(id){ DTOutput(ns('passport_table')), style = "overflow-y: auto; height: 480px" ), + box(title = "Passport Data BrAPI", width = 12, solidHeader = TRUE, collapsible = TRUE, status = "info", collapsed = FALSE, + DTOutput(ns('passport_table_brapi')), + style = "overflow-y: auto; height: 480px" + ), box( title = "PCA Plots", status = "info", solidHeader = FALSE, width = 12, height = 550, maximizable = T, bs4Dash::tabsetPanel( @@ -116,17 +131,43 @@ mod_PCA_ui <- function(id){ #' @importFrom shinyjs toggleClass #' #' @noRd -mod_PCA_server <- function(input, output, session, parent_session){ +#' +library(brapirv2) +mod_PCA_server <- function(input, output, session, parent_session){ + ns <- session$ns - + + brapi_data <- reactiveValues( + dftest = NULL + ) + #PCA reactive values pca_data <- reactiveValues( pc_df_pop = NULL, variance_explained = NULL, my_palette = NULL ) - + + + #Pull in BrAPI data when token entered + passport_table_brapi <- reactive({ + + validate( + need(!(input$brapi_token=='' && !is.null(brapi_data$dftest)), "Enter BrAPI token to access results in this section."), + ) + + brapi_data$dftest + + }) + + output$passport_table_brapi <- renderDT({ + passport_table_brapi()}, + options = list(scrollX = TRUE, + autoWidth = FALSE, + pageLength = 4)) + + # Update dropdown menu choices based on uploaded passport file passport_table <- reactive({ validate( @@ -134,35 +175,83 @@ mod_PCA_server <- function(input, output, session, parent_session){ ) info_df <- read.csv(input$passport_file$datapath, header = TRUE, check.names = FALSE) info_df[,1] <- as.character(info_df[,1]) #Makes sure that the sample names are characters instead of numeric - + updateSelectInput(session, "group_info", choices = colnames(info_df)) info_df }) - + output$passport_table <- renderDT({ passport_table()}, options = list(scrollX = TRUE, autoWidth = FALSE, pageLength = 4)) - + #PCA specific category selection observeEvent(input$group_info, { #updateMaterialSwitch(session, inputId = "use_cat", status = "success") - + # Get selected column name selected_col <- input$group_info - + # Extract unique values from the selected column unique_values <- unique(passport_table()[[selected_col]]) - + #Add category selection updateVirtualSelect("cat_color", choices = unique_values, session = session) - + }) - + + #BrAPI event + observeEvent(input$submit_token, { + validate( + need(!(input$brapi_token==''), "Enter BrAPI token to access results in this section."), + ) + + connection <- brapi_connect( + db = "localhost", + port = 8081, + secure = FALSE, + apipath = "v1/", + token = input$brapi_token, + ) + + print(brapi_checkCon(connection, verbose = FALSE)) + + #TODO still need to be able to retrieve program id associated with token + #may need to fork brapir as brapi_get_programs is not pinging the endpoint we need + #browser() + #retrieve new api path from program id + #df0 <- brapi_get_programs(con = connection) + #print(df0) + + newapipath <- paste('v1/programs', '3c150628-1788-4241-9785-9a53e917a5ad', sep='/') + + connection['apipath'] <- newapipath + + #TODO need better checks, this just tests if initial connection params work, need something to verify token + #as is, if GET fails it just crashes with an unhelpful error cause there's no catch alongside the try, so it gives an unhelpful object 'out' not found error + #because out object created in try statement and then accessed afterward + #validate( + # need(brapirv1::brapi_checkCon(connection, verbose = FALSE), "BrAPI connection failed. Check token."), + #) + + #retrieve samples + #browser() + df1 <- brapi_get_samples(con = connection) + brapi_data$dftest <- df1 + #TODO need to filter samples, as is pinging the endpoint is bringing in samples outside the program + #extra samples show up when using bruno to ping endpoint + #determine whether to modify api call or filter downstream + #"referenceSource": "breedinginsight.org/samples" filter + + #TODO filter table columns + #TODO determine if data should be wiped/replaced when swapping between brapi and file upload or just when submitting + } + ) + #PCA events observeEvent(input$pca_start, { - + # Missing input with red border and alerts toggleClass(id = "pca_ploidy", class = "borderred", condition = is.na(input$pca_ploidy)) if (is.null(input$dosage_file)) { @@ -182,30 +271,30 @@ mod_PCA_server <- function(input, output, session, parent_session){ ) } req(input$pca_ploidy, input$dosage_file$datapath) - + # Get inputs geno <- input$dosage_file$datapath g_info <- as.character(input$group_info) output_name <- input$output_name ploidy <- input$pca_ploidy - + #Notification showNotification("PCA analysis in progress...") - + #Import genotype info if genotype matrix format if (grepl("\\.csv$", geno)) { genomat <- read.csv(geno, header = TRUE, row.names = 1, check.names = FALSE) } else{ - + #Import genotype information if in VCF format vcf <- read.vcfR(geno) - + #Get items in FORMAT column info <- vcf@gt[1,"FORMAT"] #Getting the first row FORMAT - + # Apply the function to the first INFO string info_ids <- extract_info_ids(info[1]) - + #Get the genotype values if the updog dosage calls are present if ("UD" %in% info_ids) { genomat <- extract.gt(vcf, element = "UD") @@ -218,13 +307,13 @@ mod_PCA_server <- function(input, output, session, parent_session){ rm(vcf) #Remove VCF } } - + #Start analysis - + # Passport info if (!is.null(input$passport_file$datapath) && input$passport_file$datapath != "") { info_df <- read.csv(input$passport_file$datapath, header = TRUE, check.names = FALSE) - + # Check for duplicates in the first column duplicated_samples <- info_df[duplicated(info_df[, 1]), 1] if (length(duplicated_samples) > 0) { @@ -244,57 +333,57 @@ mod_PCA_server <- function(input, output, session, parent_session){ ) req(length(duplicated_samples) == 0) # Stop the analysis if duplicates are found } - + } else { info_df <- data.frame(SampleID = colnames(genomat)) } - + # Print the modified dataframe row.names(info_df) <- info_df[,1] - + #Plotting #First build a relationship matrix using the genotype values G.mat.updog <- Gmatrix(t(genomat), method = "VanRaden", ploidy = as.numeric(ploidy), missingValue = "NA") - + #PCA prin_comp <- prcomp(G.mat.updog, scale = TRUE) eig <- get_eigenvalue(prin_comp) round(sum(eig$variance.percent[1:3]),1) - + ###Simple plots # Extract the PC scores pc_scores <- prin_comp$x - + # Create a data frame with PC scores pc_df <- data.frame(PC1 = pc_scores[, 1], PC2 = pc_scores[, 2], PC3 = pc_scores[, 3], PC4 = pc_scores[, 4], PC5 = pc_scores[, 5], PC6 = pc_scores[, 6], PC7 = pc_scores[, 7], PC8 = pc_scores[, 8], PC9 = pc_scores[, 9], PC10 = pc_scores[, 10]) - - + + # Compute the percentage of variance explained for each PC variance_explained <- round(100 * prin_comp$sdev^2 / sum(prin_comp$sdev^2), 1) - - + + # Retain only samples in common row.names(info_df) <- info_df[,1] info_df <- info_df[row.names(pc_df),] - + #Add the information for each sample pc_df_pop <- merge(pc_df, info_df, by.x = "row.names", by.y = "row.names", all.x = TRUE) - - + + # Ignore color input if none is entered by user if (g_info != "") { pc_df_pop[[g_info]] <- as.factor(pc_df_pop[[g_info]]) } else { g_info <- NULL } - + #Update global variable pca_dataframes <- pc_df_pop - + # Generate a distinct color palette if g_info is provided if (!is.null(g_info) && g_info != "") { unique_countries <- unique(pc_df_pop[[g_info]]) @@ -304,23 +393,23 @@ mod_PCA_server <- function(input, output, session, parent_session){ unique_countries <- NULL my_palette <- NULL } - + # Store processed data in reactive values pca_data$pc_df_pop <- pc_df_pop pca_data$variance_explained <- variance_explained pca_data$my_palette <- my_palette - + #End of PCA section }) - + ##2D PCA plotting pca_2d <- reactive({ validate( need(!is.null(pca_data$pc_df_pop), "Input Genotype file, Species ploidy, and run the analysis to access results in this section.") ) - + # Generate colors if (!is.null(pca_data$my_palette)) { unique_countries <- unique(pca_data$pc_df_pop[[input$group_info]]) @@ -330,25 +419,25 @@ mod_PCA_server <- function(input, output, session, parent_session){ unique_countries <- NULL my_palette <- NULL } - + # Define a named vector to map input labels to grey values label_to_value <- c("Light Grey" = "grey80", "Grey" = "grey60", "Dark Grey" = "grey40", "Black" = "black") - + # Get the corresponding value based on the selected grey selected_grey <- label_to_value[[input$grey_choice]] - + #Set factor if (!input$use_cat && is.null(my_palette)) { print("No Color Info") }else{ pca_data$pc_df_pop[[input$group_info]] <- as.factor(pca_data$pc_df_pop[[input$group_info]]) } - + # Similar plotting logic here - + cat_colors <- c(input$cat_color, "grey") plot <- {if(!is.null(input$group_info) & input$group_info != "") ggplot(pca_data$pc_df_pop, aes(x = pca_data$pc_df_pop[[input$pc_X]], @@ -373,57 +462,57 @@ mod_PCA_server <- function(input, output, session, parent_session){ y = paste0(input$pc_Y, "(", pca_data$variance_explained[as.numeric(substr(input$pc_Y, 3, 3))], "%)"), color = input$group_info ) - + plot # Assign the plot to your reactiveValues }) - + #Plot the 2d plot output$pca_plot_ggplot <- renderPlot({ pca_2d() }) - + #3D PCA plotting pca_plot <- reactive({ #Plotly validate( need(!is.null(pca_data$pc_df_pop), "Input Genotype file, Species ploidy, and run the analysis to access results in this section.") ) - + #Generate colors unique_countries <- unique(pca_data$pc_df_pop[[input$group_info]]) palette <- brewer.pal(length(unique_countries),input$color_choice) my_palette <- colorRampPalette(palette)(length(unique_countries)) - + tit = paste0('Total Explained Variance =', sum(pca_data$variance_explained[1:3])) - + fig <- plot_ly(pca_data$pc_df_pop, x = ~PC1, y = ~PC2, z = ~PC3, color = pca_data$pc_df_pop[[input$group_info]], colors = my_palette) %>% add_markers(size = 12, text = paste0("Sample:",pca_data$pc_df_pop$Row.names)) - + fig <- fig %>% layout( title = tit, scene = list(bgcolor = "white") ) - + fig # Return the Plotly object here }) - + output$pca_plot <- renderPlotly({ pca_plot() }) - + pca_scree <- reactive({ #PCA scree plot validate( need(!is.null(pca_data$variance_explained), "Input Genotype file, Species ploidy, and run the analysis to access the results in this section.") ) - + var_explained <- pca_data$variance_explained - + # Create a data frame for plotting plot_data <- data.frame(PC = 1:10, Variance_Explained = var_explained[1:10]) - + # Use ggplot for plotting plot <- ggplot(plot_data, aes(x = PC, y = Variance_Explained)) + geom_bar(stat = "identity", fill = "lightblue", alpha = 0.9, color = "black") + # Bars with some transparency @@ -443,7 +532,7 @@ mod_PCA_server <- function(input, output, session, parent_session){ ) plot }) - + #Scree plot output$scree_plot <- renderPlot({ pca_scree() @@ -512,7 +601,7 @@ mod_PCA_server <- function(input, output, session, parent_session){ } ) - + #Download figures for PCA output$download_pca <- downloadHandler( filename = function() { @@ -526,7 +615,7 @@ mod_PCA_server <- function(input, output, session, parent_session){ }, content = function(file) { req(input$pca_figure) - + if (input$pca_image_type == "jpeg") { jpeg(file, width = as.numeric(input$pca_image_width), height = as.numeric(input$pca_image_height), res = as.numeric(input$pca_image_res), units = "in") } else if (input$pca_image_type == "png") { @@ -534,18 +623,18 @@ mod_PCA_server <- function(input, output, session, parent_session){ } else { tiff(file, width = as.numeric(input$pca_image_width), height = as.numeric(input$pca_image_height), res = as.numeric(input$pca_image_res), units = "in") } - + # Plot based on user selection if (input$pca_figure == "2D Plot") { print(pca_2d()) } else if (input$pca_figure == "Scree Plot") { print(pca_scree()) } - + dev.off() } ) - + output$download_vcf <- downloadHandler( filename = function() { paste0("BIGapp_VCF_Example_file.vcf.gz") @@ -554,7 +643,7 @@ mod_PCA_server <- function(input, output, session, parent_session){ ex <- system.file("iris_DArT_VCF.vcf.gz", package = "BIGapp") file.copy(ex, file) }) - + output$download_pheno <- downloadHandler( filename = function() { paste0("BIGapp_passport_Example_file.csv") @@ -563,7 +652,7 @@ mod_PCA_server <- function(input, output, session, parent_session){ ex <- system.file("iris_passport_file.csv", package = "BIGapp") file.copy(ex, file) }) - + } ## To be copied in the UI