fbanalysis: Statistical Analysis for Breeding Data in HiDAP

Documented in single_hdagrofims_server

#' Server for Single Environment analysis for HIDAP-AgroFIMS
#'
#' @param input shinyserver input
#' @param output shinyserver output
#' @param session shinyserver session
#' @param values reactive values
#' @importFrom shiny reactive tabPanel renderUI selectInput icon h2 uiOutput radioButtons actionButton br column fluidRow
#' @importFrom shinydashboard infoBox tabBox infoBoxOutput renderInfoBox
#' @importFrom shinyFiles parseFilePaths
#' @import pepa
#' @import st4gi
#' @author Omar Benites
#' @export

single_hdagrofims_server <- function(input, output, session, values){
 
  
  hot_path_agrofims <- reactive ({
    
    #validate(
    #  need(input$file != "", label = "Please enter an XLSX file. XLS files are forbidden")
    #)
    
    if(is.null(input$file_single)==0){return(NULL)}
    if(!is.null(input$file_single_agrofims)>0){
      hot_file <- input$file_single_agrofims
    }
   
  })
  
  hot_fb_agrofims <- reactive({
    
    inFile <- hot_path_agrofims()
    if(is.null(inFile)) return(NULL)
    print(inFile$datapath)
    print(inFile$name)
    try({
      file.copy(from = inFile$datapath, 
                to = file.path("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/import-kdxfiles/kdxfiles/"),
                overwrite = TRUE)
      
      file.rename(from = paste0("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/import-kdxfiles/kdxfiles/0.zip"),
                  to = paste0("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/import-kdxfiles/kdxfiles/",inFile$name))
      
    
    #Import Marie's library
    #reticulate::source_python("/home/obenites/agrofims_modules/kdsmart_integration/kdxtoagro.py")
    reticulate::source_python("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/import-kdxfiles/kdxfiles/kdxtoagro2.py")
    #kdx2agrofims(zip_name="/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/PURI1567089918,celine_aubert,2019-09-04_102712[1] - Copy.zip", 
    
    #cd <- getwd()
    #setwd("/home/obenites/AGROFIMS/kdsmart/")
    kdx2agrofims(zip_name=paste0("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/import-kdxfiles/kdxfiles/",inFile$name), 
                 excel_name = get_agrofims_file( "/home/obenites/AGROFIMS/kdsmart/", file_name = strsplit(inFile$name,split = ",")[[1]][1])
                 #excel_name= "/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/kdx2agro/CRD_rice.xlsx")
                 #excel_name= "/home/obenites/AGROFIMS/kdsmart/"
    )
    #setwd(cd)
    
    print("paso 3")
    
    #### FOR DEPLOYMENT #########
    #PURI1567089918,celine_aubert,2019-09-04_102712[1] - Copy.zip"
    fname <- strsplit(inFile$name,split = ",")[[1]][1]
    #fb <- readxl::read_excel("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/PURI1567089918.xlsx",
    fb <- readxl::read_excel(paste0("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/",fname,".xlsx"),
                             sheet = "Crop_measurements")
    ### END FOR DEPLOYRMENT #####
    fb <- clean_fb(fb)
    
    })
    #### FOR TES #####
    #fb <- readxl::read_excel("/home/obenites/HIDAP_SB_1.0.0/fbanalysis/inst/app_trend/PURI1567089918.xlsx",
    #                           sheet = "Crop_measurements")
    #Detect and remove empty columns
    # isFilled <-purrr::map(.x = fb, function(x) (all(!is.na(x)==TRUE)) )
    # fb <- fb[,unlist(isFilled)]
    # #Remove TIMESTAMP columns
    # fb<- fb[,!stringr::str_detect(names(fb),"TIMESTAMP_")]
    # #fb <- fb %>% as.data.frame(stringsAsFactors=FALSE)
    # #Change whitespaces with "_"
    # names(fb) <-  stringr::str_replace_all(string= names(fb) , pattern =  "[[:space:]]", replacement = "_")
    # #Change // for "_" to readable traits
    # names(fb) <- gsub("([//])","_", names(fb))
    # ### END FOR TEST
    # print("paso 4")
    # fb<- fb %>% as.data.frame(stringsAsFactors=FALSE)
    
  })
  
  hot_fbsample_agrofims <- reactive({
    
    design <- input$design_single_agrofims
    trait <- input$trait_single_agrofims
    fb<- hot_fb_agrofims()
    
    fb <- get_fbsubsample(fb=fb, design=design, trait=trait )
  })
  
  hot_traits <- reactive({
    
    if(class(hot_fb_agrofims())=="try-error"){
      traits <- c("")
    }else {
      traits <- names(hot_fb_agrofims()[,stringr::str_detect(names(hot_fb_agrofims()),"__")])
    }
    traits
    #traits <- stringr::str_replace_all(traits,pattern = "__[:digit:]+","") %>% unique()

  })
  
  hot_treatment <- reactive({
    
    if(class(hot_fb_agrofims())=="try-error"){
      treatment <- c("")
    }else {
      treatment <- names(hot_fb_agrofims()[,!stringr::str_detect(names(hot_fb_agrofims()),"__")]) #hot_treatment()
    }
    treatment

  })
  
  hot_metadata <- reactive({
    
      inFile <- hot_path_agrofims()
      if(is.null(inFile)) return(NULL)
      file.rename(inFile$datapath, paste(inFile$datapath, ".xlsx", sep=""))
      out<- readxl::read_excel(paste(inFile$datapath, ".xlsx", sep=""),sheet = "Metadata") 
      out
    
  })
  
  hot_rep <- reactive({
    if(class(hot_fb_agrofims())=="try-error"){
      treatment <- c("")
    }else {
      treatment <- names(hot_fb_agrofims()[,!stringr::str_detect(names(hot_fb_agrofims()),"__")]) #hot_treatment()
    }
    treatment
    
  })
  
  ###Update Design (select Input)  ------------------------------------------------------------------
  
  # observe({
  #   
  #   # <- hot_fb_sbase()
  #   design <- try(hot_metadata()$stat_design) #the statistical design from the SweetPotatoBase
  #   nrow_fb <- try(nrow(hot_fb_sbase()$fb))
  #   
  #   if(str_detect(design,"error")){
  #     design <- NULL
  #   }
  #   x <- input$design_single_sbase #the statistical design from the single env UI
  #   
  #   # Can use character(0) to remove all choices
  #   #if (is.null(x)|| length(design)==0){
  #   if (is.null(x) || length(design)==0 ){
  #     
  #     x <- "Completely Randomized Design (CRD)"
  #     shinysky::showshinyalert(session, "alert_single_sbase_done", paste("This study does not have data."), styleclass = "danger")
  #     
  #   } else {
  #     
  #     if(design == "CRD")  {x <- "Completely Randomized Design (CRD)"}
  #     if(design == "RCBD") {x <- "Randomized Complete Block Design (RCBD)"}
  #     if(design == "ABD")  {x <-"Augmented Block Design (ABD)"}
  #     if(design == "Alpha")   {x <-"Alpha design"}
  #     #if(design == "CRD")  {choice_design<-"Factorial Two-Way Design in CRD (F2CRD)"}
  #     #if(design == "CRD")  {choice_design<-"Factorial Two-Way Design in RCBD (F2RCBD)"}
  #     
  #   }
  #   x <- x
  #   
  #   # Can also set the label and select items
  #   updateSelectInput(session, "design_single_sbase",
  #                     label = 'Select statistical design of your experiment',
  #                     choices = x,
  #                     #"Split Plot with Plots in CRD (SPCRD)",
  #                     #"Split Plot with Plots in RCBD (SPRCBD)"),
  #                     selected = x
  #   )
  # })
  
  ## end update design select  ------------------------------------------------------------------
  
  
  output$trt_single_agrofims  <- renderUI({ #genotypes
    #selectInput('trt_single_agrofims', 'Select Treatments', c(Choose='', names(hot_fb_agrofims()) ),
    selectInput('trt_single_agrofims', 'Select Treatments', c(Choose='', hot_treatment()), selected = "TREATMENT",
                  selectize=TRUE)
   
  })
  
  output$rep_single_agrofims  <- renderUI({ #repetition
    selectInput('rep_single_agrofims', 'Select Blocks/Replications', c(Choose='', names(hot_fb_agrofims())), 
                selectize=TRUE) 
  })
  
  output$trait_single_agrofims <- renderUI({ #trait
    #selectInput('trait_single_agrofims', 'Select Trait(s)', c(Choose='', names(hot_fb_agrofims())),
    selectInput('trait_single_agrofims', 'Select Trait(s)', c(Choose='', names(hot_fb_agrofims())),   #hot_traits()  ),
                selectize=TRUE, multiple = FALSE)
  })
  
  output$factor_single_agrofims  <- renderUI({ #factor 1
    selectInput('factor_single_agrofims', 'Select Factors', c(Choose='', names(hot_fb_agrofims()) ),
                selectize=TRUE,multiple = TRUE)
  })
  
  output$block_single_agrofims  <- renderUI({ #block
    selectInput('block_single_agrofims', 'Select Block', c(Choose='', names(hot_fb_agrofims()) ),selected = "BLOCK",
                selectize=TRUE)
  })
  
  
  ### SPLIT PLOT ########################################################################################3
  
  output$mainplot_single_agrofims  <- renderUI({ #block
    selectInput('mainplot_factor_agrofims', 'Select Main Plot Factor', c(Choose='', names(hot_fb_agrofims()) ),
                selectize=TRUE)
  })
  
  output$subplot_single_agrofims  <- renderUI({ #block
    selectInput('subplot_factor_agrofims', 'Select Sub Plot Factor', c(Choose='', names(hot_fb_agrofims()) ),
                selectize=TRUE)
  })
  
  output$subsubplot_single_agrofims  <- renderUI({ #block
    selectInput('subsubplot_factor_agrofims', 'Select Sub Sub PLot Factor', c(Choose='', names(hot_fb_agrofims()) ),
                selectize=TRUE)
  })
  ####### END SUBPLOT ##############################################################################33
  
  
  output$k_single_agrofims  <- renderUI({ #block size
    shiny::numericInput('k_single_agrofims', 'Select Block Size',   value =2, min=2, max = 100)
  })    
  
  output$file_message_single_agrofims <- renderInfoBox({
    
    hot_file <- hot_path_agrofims()
    #p1 <<- hot_path_agrofims()
    fb_fill <- hot_fb_agrofims()
    print("-hot file message--")
    print(fb_fill)
    print(class(fb_fill))
    
    if(is.null(hot_file)){
    #if(class(fb_fill())=="try-error"){
      shinydashboard::infoBox(title="Select fieldbook file", subtitle=
                paste("Choose your fieldbook file"), icon = icon("upload", lib = "glyphicon"),
              color = "blue",fill = TRUE, width = NULL)
    # } {
    #   shinydashboard::infoBox(title="Error", subtitle=
    #                             paste("We could not match the excel file in the database. Please upload the correct file"), icon = icon("upload", lib = "glyphicon"),
    #                           color = "red",fill = TRUE, width = NULL)
    } else if(class(fb_fill)=="try-error") {
        shinydashboard::infoBox(title="Error", subtitle=
                                  paste("We could not match the KDSmart with the excel file into the database. Please check for the correct name or the content of the KDSmart file"), icon = icon("warning-sign", lib = "glyphicon"),
                                color = "red",fill = TRUE, width = NULL)
    }  else {
      hot_file <- hot_file$name
      #hot_file <- paste(hot_file, collapse = ", ")
      shinydashboard::infoBox(title="GREAT!", subtitle = paste(" Fieldbook selected: ", hot_file),  
                              icon = icon("ok", lib = "glyphicon"),
                              color = "green",fill = TRUE, width = NULL)
    }
    
  })
  
  
  output$downloadagrofims_single_report <- downloadHandler(
    filename =  paste0("report", "_", as.character(Sys.time(), "%Y%m%d%H%M%S"), '.docx'),
    content = function(con) {
      
      shiny::withProgress(message = "Opening single Report...",value= 0,{
        
        shiny::incProgress(1/5, detail = paste("Downloading Analysis..."))  
        
        #
        #bb1 <<- hot_fbsample_agrofims()
          
        if(is.null(input$trait_single_agrofims)){
          shinyalert("Oops!", "Select trait(s) to perform analysis", type = "error")
          
        } else {
        
        #if(input$type_single_agrogims=="Subsample"){
        #  fieldbook <- hot_fbsample_agrofims_test()
            
        #} else {
          
          #fieldbook <- hot_fb_agrofims() #DEPLOY CODE
          fb <- hot_fbsample_agrofims()
          
          fb <- as.data.frame(fb,stringsAsFactors=FALSE)
          #TEST DATA
          
          ###DEPLOY CODE
          #names(fb) <-  stringr::str_replace_all(string= names(fb) , pattern =  "[[:space:]]", replacement = "_")
          #trait <-  stringr::str_replace_all(string= input$trait_single_agrofims, pattern =  "[[:space:]]", replacement = "_")
          #pos<- match(input$trait_single_agrofims,names(fb))
          #names(fb)[pos]<- trait 
          #End DEPLOY CODE
          
        #}
          trait <- input$trait_single_agrofims
          rep <- input$rep_single_agrofims
          trt <- input$trt_single_agrofims
          #block <- input$block_single_agrofims
          k <- input$k_single_agrofims #
          #factors <- input$factor_single_agrofims # factor 1
          factors<- stringr::str_replace_all(string= input$factor_single_agrofims, pattern =  "[[:space:]]", replacement = "_")
          #factor2_single <- input$factor_single_agrofims2 #factor 2
          mplot<- input$main_plot_factor
          subplot<- input$sub_plot_factor
          subsubplot<- input$subsub_plot_factor
           #type of document
          format <- "word" #paste(input$format_single_agrofims, sep="")
          design <- input$design_single_agrofims
        
        
          incProgress(2/5, detail = paste("Downloading Analysis..."))
          
          if(design == "Randomized Complete Block Design (RCBD)"){
            
            servName =   "rcbd"
            serverFileDir <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/files/"
            serverService <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/getFileUpload.php"
            
            uploadDate  <- as.character(Sys.time(), "%Y%m%d%H%M%S")
            ranStr <-  stringi::stri_rand_strings(1, 15,  '[a-zA-Z0-9]')
            servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!!
            
            dirName <- fbglobal::get_base_dir()
            print(dirName)
            path <- paste0(dirName, servName, ".docx")
            
            if(is.null(rep)){
              shinyalert("Oops!", "Select blocks/repetitions to perform analysis", type = "error")
              
            } else{
            
            # try(pepa::repo.rcbd(traits = trait, trt = trt, rep = rep, format = format, dfr = fb, server =TRUE, server_dir_name = dirName,
            #                     server_file_name = servName))

            try(pepa::repo.rcbd(traits = trait,rep = "BLOCK",  trt = trt, trt.lab = "treatment",  format = format, dfr = fb, eu="PLOT",
                                server =TRUE, server_dir_name = dirName, server_file_name = servName))
            params <- list(
              dataRequest = "uploadFile",
              fileServerName = paste0(servName, ".docx"),
              filedata= httr::upload_file(path, "text/csv")
            )
            
            
            var <- httr::POST(serverService, body=params)
            code <- httr::content(var, "text")
            
            
            }
            
            if (code == "200")
              print("uploaded")
            else
              print("Not uploaded")
            
            
          }
          
          if(design == "Completely Randomized Design (CRD)"){
            
            #if(input$type_single_agrogims=="Subsample"){
              #trait <- names(fb)[6] #Sith column is for analysis
              #print(trait)
              #factors <- c("PLOT", "ROW", "COL", "TREATMENT")
              #fb <- st4gi::docomp(do = "mean", traits = trait, factors = factors ,dfr=fb)
              #aa1 <<- fb
            #}
            
            #servName =   "crd.docx"
            servName =   "crd"
            
            serverFileDir <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/files/"
            serverService <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/getFileUpload.php"
            
            uploadDate  <- as.character(Sys.time(), "%Y%m%d%H%M%S")
            ranStr <-  stringi::stri_rand_strings(1, 15,  '[a-zA-Z0-9]')
            servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!!
            
            #dirfiles <- system.file(package = "pepa")
            
            dirName <- fbglobal::get_base_dir()
            path <- paste0(dirName, servName, ".docx")
            print(path)
            
            #aa1<<- fb
            
            try(pepa::repo.crd(traits = trait, trt = trt, trt.lab = "treatment", format = format, dfr = fb, eu="PLOT",
                               server =TRUE, server_dir_name = dirName, server_file_name = servName))
            
            print("paso pepa")
            params <- list(
              dataRequest = "uploadFile",
              fileServerName = paste0(servName, ".docx"),
              filedata= httr::upload_file(path, "text/csv")
              
            )
            
            var <- httr::POST(serverService, body=params, timeout(1000))
            code <- httr::content(var, "text")
            
            print("paso 2")
            
            if (code == "200")
              print("uploaded")
            else
              print("Not uploaded")
            
          }
          # 
          if(design == "Factorial with CRD"){
            
            
            if(is.null(factors)){
              shinyalert("Oops!", "Select factors to perform analysis", type = "error")
              
            } else {
            
              if(length(factors)==2){
                servName =  "2fcrd"  
              }else{
                servName =  "factorial"
              }
              
              serverFileDir <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/files/"
              serverService <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/getFileUpload.php"
              
              uploadDate  <- as.character(Sys.time(), "%Y%m%d%H%M%S")
              ranStr <-  stringi::stri_rand_strings(1, 15,  '[a-zA-Z0-9]')
              servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!!
              
              dirName <- fbglobal::get_base_dir()
              print(dirName)
              path <- paste0(dirName, servName, ".docx")
              
              pepa::repo.f(dfr = fb, traits = trait, rep= NULL,
                           factors= factors , format = format, 
                           server =TRUE, server_dir_name = dirName, server_file_name = servName )
              
              
              params <- list(
                dataRequest = "uploadFile",
                fileServerName = paste0(servName, ".docx"),
                filedata= httr::upload_file(path, "text/csv")
              )
              
              var <- httr::POST(serverService, body=params)
              code <- httr::content(var, "text")
                
            }  
            
            
            
            if (code == "200")
              print("uploaded")
            else
              print("Not uploaded")
            
          }
          
          if(design == "Factorial with RCBD"){
            
            
            if(is.null(factors)){
              shinyalert("Oops!", "Select factors to perform analysis", type = "error")
              
            } else {
            
              #servName =   "2fcrd"
              if(length(factors)==2){
                servName =  "2frcbd"  
              }else{
                servName =  "factorial"
              }
              serverFileDir <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/files/"
              serverService <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/getFileUpload.php"
              
              uploadDate  <- as.character(Sys.time(), "%Y%m%d%H%M%S")
              ranStr <-  stringi::stri_rand_strings(1, 15,  '[a-zA-Z0-9]')
              servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!!
              
              dirName <- fbglobal::get_base_dir()
              print(dirName)
              path <- paste0(dirName, servName, ".docx")
              
              pepa::repo.f(dfr = fb, traits = trait, factors= factors,
                           rep = rep, format = format, 
                           server =TRUE, server_dir_name = dirName, server_file_name = servName )
              
              
              params <- list(
                dataRequest = "uploadFile",
                fileServerName = paste0(servName, ".docx"),
                filedata= httr::upload_file(path, "text/csv")
              )
              
              var <- httr::POST(serverService, body=params)
              code <- httr::content(var, "text")
              
                
            }
            
            if (code == "200")
              print("uploaded")
            else
              print("Not uploaded")
            
          }
       
          if(design == "Split plot Design"){
  
            #servName =   "2fcrd"
            ##
            servName =  "spld"  
            #}
            #TODO: identificar cuando seleccionan split split plot
            
            
            serverFileDir <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/files/"
            serverService <-"https://research.cip.cgiar.org/gtdms/hidap/hidap_sbase_reports/getFileUpload.php"
            
            uploadDate  <- as.character(Sys.time(), "%Y%m%d%H%M%S")
            ranStr <-  stringi::stri_rand_strings(1, 15,  '[a-zA-Z0-9]')
            servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!!
            
            dirName <- fbglobal::get_base_dir()
            print(dirName)
            path <- paste0(dirName, servName, ".docx")
            
            mplot<- input$main_plot_factor
            subplot<- input$sub_plot_factor
            subsubplot<- input$subsub_plot_factor
            
            pepa::repo.spld(dfr = fb, traits = trait, 
                          mpf= mplot,spf=subplot ,sspf=subsubplot,
                          rep = rep, format = format, 
                          server =TRUE, server_dir_name = dirName, server_file_name = servName )
            
            
            params <- list(
              dataRequest = "uploadFile",
              fileServerName = paste0(servName, ".docx"),
              filedata= httr::upload_file(path, "text/csv")
            )
            
            var <- httr::POST(serverService, body=params)
            code <- httr::content(var, "text")
            
            
            
            if (code == "200")
              print("uploaded")
            else
              print("Not uploaded")
            
          }
        
        }
        
        
        Sys.chmod(path, mode = "0777", use_umask = TRUE)
        #getOption('timeout')
        #options(timeout=1000000000000)
        
        download.file(paste0(serverFileDir, servName, ".docx"), con, method = "curl")
        
        incProgress(4/5, detail = paste("Formattting in ", "MS Word",sep= ""))
        incProgress(5/5, detail = paste("Downloading Analysis..."))
        
      })
      
    }
  )
  
  output$downloadagrofims_single_rowdata <- downloadHandler(
    filename = paste("RowData.xlsx") , #function() paste0(input$uniqueId,"-",input$fieldbookId, ".xlsx") ,#paste0(FbFileName(),".xlsx"),#"fileNameBook.xlsx",
    content = function(file) {
    
     inFile<-  hot_path_agrofims()
      
     fp<- paste0("/home/obenites/AGROFIMS/hagrofims/inst/hidap_agrofims/", file_name = strsplit(inFile$name,split = ",")[[1]][1], ".xlsx")
     print("--1--")
     print(fp)
     #Sys.chmod(path, mode = "0777", use_umask = TRUE)
     #getOption('timeout')
     #options(timeout=1000000000000)
     file.copy(fp, file)
     #download.file(url = paste0(fp), con, method = "curl")
     
       
    } ,
    contentType="application/xlsx"
  )

}