inst/Genetic_Variability_Parameters/app.R

In TBA: Collection of 'shiny' Apps for Tree Breeding Analysis

library(shiny)
library(readxl)
library(shinybusy)
Genetic_variability_parameters <- function(data) {

  # Convert the first two columns to factor type

  data[, 1:2] <- lapply(data[, 1:2], as.factor)

  # Convert the remaining columns to numeric

  data[, -c(1, 2)] <- lapply(data[, -c(1, 2)], as.numeric)

  # Extract trait names (excluding the first two columns)

  traits <- names(data)[-c(1, 2)][sapply(data[-c(1, 2)], is.numeric)]

  results <- data.frame(Parameter = c("Grand Mean", "Phenotypic Variance", "Genotypic Variance",

                                      "Phenotypic Coefficient of Variation ( % )", "Genotypic Coefficient of Variation ( % )",

                                      "Broad-Sense Heritability ( % )", "Genetic Advance", "Genetic Advance as Percentage of Mean ( % )", "Standard Error of Mean"),
                        stringsAsFactors = FALSE)


  for (i in 1:length(traits)) {

    trait <- traits[i]


    # Perform linear regression

    formula <- as.formula(paste0("`", trait, "` ~ `", names(data)[1], "` + `", names(data)[2], "`"))

    model <- lm(formula, data = data)

    # Perform ANOVA

    anova_result <- anova(model)

    # Calculate means

    grand_mean <- mean(data[[trait]])

    replication_levels <- nlevels(data[[1]])

    # Calculate genotypic variance

    genotypic_variance <- round((anova_result$`Mean Sq`[2] - anova_result$`Mean Sq`[3]) / replication_levels,4)

    # Calculate phenotypic variance

    phenotypic_variance <- round(genotypic_variance + anova_result$`Mean Sq`[3],4)


    # Calculate coefficients of variation

    phenotypic_coefficient_of_variation <- round((sqrt(phenotypic_variance) / grand_mean) * 100,4)

    genotypic_coefficient_of_variation <- round((sqrt(genotypic_variance) / grand_mean) * 100,4)


    # Calculate heritability

    heritability <- round((genotypic_variance / phenotypic_variance) * 100,4)


    # Calculate genetic advance

    genetic_advance <- round((genotypic_variance / sqrt(phenotypic_variance)) * 2.06,4)


    # Calculate genetic advance as percentage of mean

    genetic_advance_as_percentage_of_mean <- round((genetic_advance / grand_mean) * 100,4)


    # Calculate standard error of mean

    standard_error_of_mean <- round(sqrt(anova_result$`Mean Sq`[3] / replication_levels),4)


    # Store results in data frame

    results[[trait]] <- c(grand_mean, phenotypic_variance, genotypic_variance,

                          phenotypic_coefficient_of_variation, genotypic_coefficient_of_variation,

                          heritability, genetic_advance, genetic_advance_as_percentage_of_mean,

                          standard_error_of_mean)
  }


  # Return the results
  return(results)
}


ui <- fluidPage(

  sidebarLayout(
    sidebarPanel(
      h3("Genetic Variability Parameters", style = "color: blue; font-weight: bold;font-size: 30px;"),
      h3("Upload the data file", style = "font-weight: bold"),
      fileInput("file_genetic", "Choose Excel File (.xlsx , .xls)", accept = c(".xlsx", ".xls")),
      actionButton("analyze_genetic", "Analyze",
                   style = "color: #FFFFFF; background-color: #007BFF; border-color: #007BFF;margin-bottom: 10px;"),
      p("Instructions for data format:", style = "color: orange; font-weight: bold;font-size: 16px;"),
      p("Excel file name should not contain spaces (e.g., use 'Sample_Data.xlsx' instead of 'Sample Data.xlsx')", style = "color: red;font-weight: bold;font-size: 14px;"),
      p("First column: Replication", style = "color: red;font-weight: bold;font-size: 14px;"),
      p("Second column: Genotypes", style = "color: red;font-weight: bold;font-size: 14px;"),
      p("Subsequent columns: Trait values (e.g., DBH, PH, FW, SW, KW, OC)", style = "color: red;font-weight: bold;font-size: 14px;"),
      p("Trait names should be short (e.g., 'DBH' for Diameter at Breast Height)", style = "color: red;font-weight: bold;font-size: 14px;"),
      p("Note: The analysis is based on the Randomized Block Design (RBD)", style = "color: purple; font-weight: bold;font-size: 16px;"),
      downloadButton("download_gvp_example", "Download Example Data",
                     style = "color: #FFFFFF; background-color: #28A745; border-color: #28A745; margin-bottom: 10px;"),
      p("The example dataset includes:170 genotypes, 3 replications for each genotype and 6 traits", style = "color: red;font-weight: bold;font-size: 14px;"),
       h3("Download Results", style = "font-weight: bold"),
      downloadButton("download_genetic", "Genetic Variability Parameters (CSV)",
                     style = "color: #00008B; font-weight: bold; width: 100%;white-space: normal;margin-bottom: 10px;"),
      # Feedback message
      p("For feedback, queries or suggestions,   email:  tbacafri@gmail.com",style = "color: darkgreen; font-weight: bold; font-size: 14px; width: 100%; white-space: normal;")
    ),
    mainPanel(

      uiOutput("genetic_title"),
      div(style = "overflow-y: auto; overflow-x: auto; height: 400px;",  # Adjust height as needed
          tableOutput("genetic_results")
      )
    )
  )
)
server <- function(input, output, session) {

  output$download_gvp_example <- downloadHandler(
    filename = function() {
      "Genetic_Variability_Data.xlsx"  # Desired file name for user
    },
    content = function(file) {
      # Use system.file to get the path of the example data within the package
      example_path <- system.file("Genetic_Variability_Parameters", "example_GVP_data.xlsx", package = "TBA")

      # Copy the file to the download location
      file.copy(example_path, file)
    }
  )

  genetic_params <- reactiveVal()

  analyzeGeneticParams <- function(file) {
    req(file)
    data <- readxl::read_excel(file$datapath)
    res_raw <- Genetic_variability_parameters(data)
    res <- res_raw
    res[, -1] <- round(res_raw[, -1], 4)  # Only round numeric columns
    genetic_params(res)
    return(res)
  }

  # Reset previous outputs when a new file is uploaded
  observeEvent(input$file_genetic, {
    genetic_params(NULL)  # Clear the analysis results
    output$genetic_results <- renderUI(NULL)  # Clear results
    output$genetic_title <- renderUI(NULL)  # Clear titles
  })

  observeEvent(input$analyze_genetic, {
    show_modal_spinner(
      spin = "circle",
      color = "#007BFF",
      text = "Analyzing, please wait..."   # (Optional text under spinner)
    )

    res <- analyzeGeneticParams(input$file_genetic)

    remove_modal_spinner()

    output$genetic_results <- renderTable({
      if (!is.null(genetic_params())) {
        df <- genetic_params()

        # Apply rounding and remove trailing zeroes
        df[, -1] <- lapply(df[, -1], function(x) as.character(round(x, 4)))

        df
      }
    }, rownames = TRUE)

    output$genetic_title <- renderUI({
      tagList(
        h3("Genetic Variability Parameters", style = "color: purple; font-weight: bold;")
      )
    })
  })

  output$download_genetic <- downloadHandler(
    filename = function() {
      paste("genetic_variability_parameters", Sys.Date(), ".csv", sep = "")
    },
    content = function(file) {
      write.csv(genetic_params(), file, row.names = FALSE)

    }
  )

}
shinyApp(ui, server)