diff --git a/DESCRIPTION b/DESCRIPTION index 517410b..569331b 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: fbcheck Title: Web Interface for Data Quality and Processing -Version: 2.0.3 +Version: 2.0.4 Authors@R: c( person("Omar","Benites",,"obacc07@gmail.com",c("aut","cre")) ) diff --git a/R/check_error.R b/R/check_error.R new file mode 100644 index 0000000..06d34d4 --- /dev/null +++ b/R/check_error.R @@ -0,0 +1,52 @@ + +#' Check error in FieldbookApp data +#' +#' @param dfr data frame. FieldbookApp data. +#' @description FieldbookApp data is captured by mobiles phones or tablets. After exporting this information, it should be read in R +#' in order to process, check and curate. +#' @author Omar Benites +#' @export + + +check_fbapp <- function(dfr){ + + #Solgenomic headers + sol_headers<- c("plot_name", "plot_id", "block_number", "plot_number", "rep_number" , "row_number", "col_number", + "accession_name", "is_a_control", "synosyms", "trial_name", "location_name", "year", "pedigree", + "tier", "seedlot_name", "seed_transaction_operator", "num_seed_per_plot", "range_number", "plot_geo_json", + "timestamp", "person" ,"location", "number") + + if(nrow(dfr)){ + message <- paste("The file is empty") + status <- "error" + } else if(!is.element("plot_id", fb_headers)){ #Check #1 + message <- paste("The variable 'plot_id' is missing. Must be included in order to upload into the database") + status <- "error" + } else if(sum(names(exp_cols) %in% sol_headers) != length(names(exp_cols))) { + + #fieldbook headers + fb_headers <- names(dfr) + + #Crop Ontology (CO) headers + co_h_lg <- grepl(pattern = "CO", fb_headers) #logical exp. to detect co_headers + co_cols <- dfr[co_h_lg] #detect Crop ontology columns + + #Experiment columns: -get rid trait variables and retain experimental variables (plot, rep, year, etc) + exp_cols <- dfr[!co_h_lg] + + #ToDo: create two functions for check ontology terms (exist) and exp sol_headers + check_headers <- names(exp_cols) %in% sol_headers + + #Check #2 + non_found<- names(exp_cols)[!check_headers] + message <- paste("The variable(s)", non_found, "was (were) not found in the database. Refine your file before processing.") + status <- "error" + } else { #Check #3 + msg <- paste("Successfully checked!") + status <- "success" + } + + out<- list(msg= msg, status=status) + +} + diff --git a/R/fbcheck_server.R b/R/fbcheck_server.R index 466017e..b679f4d 100755 --- a/R/fbcheck_server.R +++ b/R/fbcheck_server.R @@ -10,9 +10,14 @@ fbcheck_server <- function (input, output, session, values) { + + ############## HIDAP files ################################################################# + volumes <- shinyFiles::getVolumes() + shinyFileChoose(input, "file", roots = volumes, session = session, restrictions = system.file(package = "base"), filetypes = c("xlsx")) + hot_path <- reactive({ req(input$file) if (is.null(input$file)) { @@ -27,6 +32,7 @@ fbcheck_server <- function (input, output, session, values) input$file)$datapath) } }) + hot_bdata <- reactive({ hot_file <- hot_path() print(hot_file) @@ -62,6 +68,7 @@ fbcheck_server <- function (input, output, session, values) hot_bdata } }) + hot_params <- reactive({ hot_file <- hot_path() if (length(hot_file) == 0) { @@ -90,6 +97,7 @@ fbcheck_server <- function (input, output, session, values) hot_psize_baby = hot_psize_baby, hot_pden_baby = hot_pden_baby) } }) + hot_crop <- reactive({ hot_file <- hot_path() if (length(hot_file) == 0) { @@ -101,6 +109,7 @@ fbcheck_server <- function (input, output, session, values) hot_crop <- get_fb_param(hot_param, "Crop") } }) + hot_trial <- reactive({ hot_file <- hot_path() if (length(hot_file) == 0) { @@ -112,6 +121,7 @@ fbcheck_server <- function (input, output, session, values) hot_trial <- get_fb_param(hot_param, "Type_of_Trial") } }) + hot_mgt <- reactive({ hot_file <- hot_path() if (length(hot_file) == 0) { @@ -123,6 +133,7 @@ fbcheck_server <- function (input, output, session, values) hot_mgt } }) + hot_mtl <- reactive({ hot_file <- hot_path() if (length(hot_file) == 0) { @@ -134,6 +145,7 @@ fbcheck_server <- function (input, output, session, values) hot_mtl } }) + shiny::observeEvent(input$calculate, { fb <- hot_bdata() fb_names <- names(fb) @@ -145,11 +157,15 @@ fbcheck_server <- function (input, output, session, values) styleclass = "warning") } }) + output$hot_btable <- renderRHandsontable({ req(input$file) + if (hot_trial() != "Participatory Varietal Selection") { + values <- shiny::reactiveValues(hot_btable = hot_bdata()) DF <- NULL + if (!is.null(input$hot_btable)) { DF = hot_to_r(input$hot_btable) values[["hot_btable"]] = DF @@ -157,6 +173,7 @@ fbcheck_server <- function (input, output, session, values) else if (!is.null(values[["hot_btable"]])) { DF = values[["hot_btable"]] } + if (input$calculate > 0) { hot_plot_size <- as.numeric(hot_params()$hot_plot_size) hot_plant_den <- as.numeric(hot_params()$hot_plant_den) @@ -166,39 +183,71 @@ fbcheck_server <- function (input, output, session, values) plot_size = hot_plot_size, plant_den = hot_plant_den, mgt = hot_mgt(), mtl = hot_mtl(), trial_type = hot_trial()) } + if (!is.null(DF)) { - traits <- get_trait_fb(DF) + traits <- get_trait_fb(DF, dsource = 1) path <- fbglobal::get_base_dir() path <- paste(path, "hot_fieldbook.rds", sep = "\\") saveRDS(DF, path) crop <- hot_crop() trial <- hot_trial() - print("checking with crop ontology") - trait_dict <- get_crop_ontology(crop = crop) + #print("checking with crop ontology") + #print(traits) + + trait_dict <- get_crop_ontology(crop = crop, dsource = 1) + #print(trait_dict) traittools::col_render_trait(fieldbook = DF, - trait = traits, trait_dict = trait_dict) + trait = traits, trait_dict = trait_dict, dsource = 1) } } }) + output$fbcheckSelect_criteria <- shinyTree::renderTree({ out <- selcriteria out }) + output$fbcheck_genofilter <- renderUI({ - ifelse("INSTN" %in% names(hot_bdata()), sel <- "INSTN", - sel <- 1) + ifelse("INSTN" %in% names(hot_bdata()), sel <- "INSTN", sel <- 1) + sel_choices <- names(hot_bdata()) + + if(hot_trial() == "Participatory Varietal Selection"){ + sel_choices <- NULL + } + selectInput(inputId = "sel_fbcheck_genofilter", label = "Select Genotypes", - choices = names(hot_bdata()), multiple = TRUE, selected = sel) + choices = c("Select genotype: ex. 'INSTN'" = "", sel_choices), multiple = FALSE, selected = sel) }) + output$fbcheck_factorfilter <- renderUI({ + + sel_choices <- names(hot_bdata()) + + if(hot_trial() == "Participatory Varietal Selection"){ + sel_choices <- NULL + } + selectInput(inputId = "sel_fbcheck_factorfilter", label = "Summary by", - choices = names(hot_bdata()), multiple = TRUE, selected = 1) + choices = c("Select factor to summarize: ex. 'FACTOR'" = "", sel_choices), multiple = TRUE, selected = 1) }) + + # output$show_standard_filters <- reactive({ + # if(hot_trial() == "Participatory Varietal Selection"){ + # flag<- FALSE #do not show filters + # } else{ + # flag <- TRUE #show filters for standart trials + # } + # print(hot_trial()) + # return(flag) + # }) + + pvs_fb_sheets <- reactive({ hot_file <- hot_path() pvs_sheet <- readxl::excel_sheets(hot_file) pvs_sheet }) + output$hot_f1_btable <- renderRHandsontable({ values <- shiny::reactiveValues(hot_f1_btable = hot_bdata()$F1_selection_criteria) DF <- NULL @@ -464,10 +513,14 @@ fbcheck_server <- function (input, output, session, values) rhandsontable::rhandsontable(data = DF) } }) + + output$hot_td_trait = renderRHandsontable({ td_trait <- orderBy(~ABBR, td_trait) rhandsontable(data = td_trait) }) + + shiny::observeEvent(input$exportButton, { try({ withProgress(message = "Downloading Fieldbook and Applying Format...", @@ -724,13 +777,17 @@ fbcheck_server <- function (input, output, session, values) c("_n", "_Mean", "_sd"), paste, sep = ""))) trait_f5_new <- paste(trait_f5_old, "_baby", sep = "") - setnames(sum_f5, trait_f5_old, trait_f5_new) + data.table::setnames(sum_f5, trait_f5_old, trait_f5_new) } else { sum_f5 <- NULL } print("sum f6") if (!is.null(out_table_f6)) { + + a1<<- out_table_f6 + a2<<- trait_dict + sum_f6 <- trait_summary_join(fieldbook = out_table_f6, genotype = "INSTN", design = "RCBD", trait = c("TEXTURE", "TASTE", "APPEARANCE"), @@ -741,7 +798,7 @@ fbcheck_server <- function (input, output, session, values) c("_n", "_Mean", "_sd"), paste, sep = ""))) trait_f6_new <- paste(trait_f6_old, "_mother", sep = "") - setnames(sum_f6, trait_f6_old, trait_f6_new) + data.table::setnames(sum_f6, trait_f6_old, trait_f6_new) } else { sum_f6 <- NULL @@ -758,7 +815,7 @@ fbcheck_server <- function (input, output, session, values) c("_n", "_Mean", "_sd"), paste, sep = ""))) trait_f7_new <- paste(trait_f7_old, "_baby", sep = "") - setnames(sum_f7, trait_f7_old, trait_f7_new) + data.table::setnames(sum_f7, trait_f7_old, trait_f7_new) } else { sum_f7 <- NULL @@ -772,7 +829,7 @@ fbcheck_server <- function (input, output, session, values) c("_n", "_Mean", "_sd"), paste, sep = ""))) trait_f8_new <- paste(trait_f8_old, "_mother", sep = "") - setnames(sum_f8, trait_f8_old, trait_f8_new) + data.table::setnames(sum_f8, trait_f8_old, trait_f8_new) } else { sum_f8 <- NULL @@ -792,7 +849,7 @@ fbcheck_server <- function (input, output, session, values) c("_n", "_Mean", "_sd"), paste, sep = ""))) trait_f9_new <- paste(trait_f9_old, "_mother", sep = "") - setnames(sum_f9, trait_f9_old, trait_f9_new) + data.table::setnames(sum_f9, trait_f9_old, trait_f9_new) } else { sum_f9 <- NULL @@ -920,24 +977,25 @@ fbcheck_server <- function (input, output, session, values) }) }) - ############## FieldBookApp ############## + ############## end HIDAP files ################################################################# - hot_crop_sbase <- reactive({ + + ############## FieldBookApp files ################################################################# + + fileNameExtFile <- reactive({ - #formatFile <- hot_formatFile_sbase() + servName <- "fbappdatapath.rds" + uploadDate <- as.character(Sys.time(), "%Y%m%d%H%M%S") + ranStr <- stri_rand_strings(1, 15, '[a-zA-Z0-9]') + servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!! + dirNameExtFile <- fbglobal::get_base_dir() #get directory of the file with fileName + fileNameExtFile <- paste0(dirNameExtFile, servName) - # if(formatFile =="HIDAP"){ - # - # hot_file <- hot_path_sbase() - # if(length(hot_file)==0){return (NULL)} - # if(length(hot_file)>0){ - # hot_param <- readxl::read_excel(path=hot_file , sheet = "Minimal") - # hot_crop <- get_fb_param(hot_param,"Crop") - # } - # } + }) + + hot_crop_sbase <- reactive({ - #if(formatFile =="FieldBookApp-SPBase"){hot_crop <- "sweetpotato"} hot_crop <- "sweetpotato" hot_crop @@ -962,128 +1020,220 @@ fbcheck_server <- function (input, output, session, values) dt <- readr::read_csv(file_fbapp$datapath) } - ####### Show Warnings to users ####### if(!is.element("plot_name", names(dt))){ shinysky::showshinyalert(session, "alert_fbapp_warning_sbase", paste("ERROR: The file imported does not has 'plot_name' header."), styleclass = "danger") } else if(nrow(dt)==1){ shinysky::showshinyalert(session, "alert_fbapp_warning_sbase", paste("ERROR: Your data file has only one row of data. Please upload the right one. "), styleclass = "danger") } else { - hot_bdata_sbase2 <- fbapp2hidap(fieldbook = dt) + hot_bdata_sbase2 <- dt #fbapp2hidap(fieldbook = dt) + names(hot_bdata_sbase2) <- gsub("[[:space:]]", "", names(hot_bdata_sbase2)) #remove whitespaces + hot_bdata_sbase2 } - ####### Create Unique ID ######## servName <- "fbappdatapath.rds" uploadDate <- as.character(Sys.time(), "%Y%m%d%H%M%S") ranStr <- stri_rand_strings(1, 15, '[a-zA-Z0-9]') servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!! dirNameExtFile <- fbglobal::get_base_dir() #get directory of the file with fileName + fileNameExtFile <- paste0(dirNameExtFile, servName) + fileNameExtFile<- fileNameExtFile() ####### Reactive values ####### - hot_bdata_sbase <- hot_bdata_sbase2 + hot_bdata_sbase <- hot_bdata_sbase2 + values <- shiny::reactiveValues( hot_btable_fbapp_sbase = hot_bdata_sbase#() ) DF <- NULL - ####### Detect if hot_btable_fbapp_sbase has data ####### - if (!is.null(input$hot_btable_fbapp_sbase)) { - print("if 1") + # ####### Detect if hot_btable_fbapp_sbase has data ####### + # if (!is.null(input$hot_btable_fbapp_sbase)) { + # print("if 1") + # DF = hot_to_r(input$hot_btable_fbapp_sbase) + # #values[["hot_btable_fbapp_sbase"]] = DF + # + # ## Important Note: in case users upload different files, they will see: + # dirNameExtFile <- fbglobal::get_base_dir() + # #fileNameExtFile <- paste(dirNameExtFile, "fbappdatapath.rds") + # fileNameExtFile <- paste0(dirNameExtFile, servName) + # + # #if(file.exists(file.path(dirNameExtFile, "fbappdatapath.rds") )){ + # if(file.exists(fileNameExtFile)) { + # former_datapath <- readRDS(fle = fileNameExtFile) + # if(hot_fbapp_path()!= former_datapath){ + # DF <- hot_bdata_sbase2 + # } + # } + + if(!is.null(input$hot_btable_fbapp_sbase)) { DF = hot_to_r(input$hot_btable_fbapp_sbase) - #values[["hot_btable_fbapp_sbase"]] = DF - ## Important Note: in case users upload different files, they will see: - dirNameExtFile <- fbglobal::get_base_dir() - #fileNameExtFile <- paste(dirNameExtFile, "fbappdatapath.rds") - fileNameExtFile <- paste0(dirNameExtFile, servName) - #if(file.exists(file.path(dirNameExtFile, "fbappdatapath.rds") )){ if(file.exists(fileNameExtFile)) { former_datapath <- readRDS(file = fileNameExtFile) if(hot_fbapp_path()!= former_datapath){ + #if(!identical(hot_bdata_sbase2, DF)){ + #if(flag1) { DF <- hot_bdata_sbase2 } } + ### end important note values[["hot_btable_fbapp_sbase"]] = DF - } else if (!is.null(values[["hot_btable_fbapp_sbase"]])) { DF = values[["hot_btable_fbapp_sbase"]] - print("if 2") } - if(!is.null(DF)){ dsource <- 2 traits <- traittools::get_trait_fb(DF, dsource = dsource) - #print(traits) - path <- fbglobal::get_base_dir() ##begin fbglobal - path <- file.path(path,"hot_fieldbook_sbase.rds") - saveRDS(DF, path) file_fbapp <- input$file_fbapp_sbase value_datapath <- file_fbapp$datapath - datapath <- file.path(fbglobal::get_base_dir(), "fbappdatapath.rds") - saveRDS(value_datapath, file = datapath) + fileNameExtFile <- paste0(dirNameExtFile, servName) #file.path(fbglobal::get_base_dir(), "fbappdatapath.rds") + + saveRDS(value_datapath, file = fileNameExtFile()) crop <- hot_crop_sbase() trait_dict <- get_crop_ontology(crop = crop, dsource = dsource) traittools::col_render_trait(fieldbook = DF, trait = traits , trait_dict = trait_dict, dsource = dsource) } + + + # ####### Import CSV data ####### + # file_fbapp <- input$file_fbapp_sbase + # #print(file_fbapp) + # if (is.null(file_fbapp)) { + # return(NULL) + # } else { + # dt <- readr::read_csv(file_fbapp$datapath) + # } + # + # + # ####### Show Warnings to users ####### + # if(!is.element("plot_name", names(dt))){ + # shinysky::showshinyalert(session, "alert_fbapp_warning_sbase", paste("ERROR: The file imported does not has 'plot_name' header."), styleclass = "danger") + # } else if(nrow(dt)==1){ + # shinysky::showshinyalert(session, "alert_fbapp_warning_sbase", paste("ERROR: Your data file has only one row of data. Please upload the right one. "), styleclass = "danger") + # } else { + # hot_bdata_sbase2 <- fbapp2hidap(fieldbook = dt) + # } + # + # + # ####### Create Unique ID ######## + # servName <- "fbappdatapath.rds" + # uploadDate <- as.character(Sys.time(), "%Y%m%d%H%M%S") + # ranStr <- stri_rand_strings(1, 15, '[a-zA-Z0-9]') + # servName <- paste(uploadDate, ranStr, servName , sep= "-") #nombre sin extensions!!!! + # dirNameExtFile <- fbglobal::get_base_dir() #get directory of the file with fileName + # + # + # ####### Reactive values ####### + # hot_bdata_sbase <- hot_bdata_sbase2 + # values <- shiny::reactiveValues( + # hot_btable_fbapp_sbase = hot_bdata_sbase#() + # ) + # DF <- NULL + # + # ####### Detect if hot_btable_fbapp_sbase has data ####### + # if (!is.null(input$hot_btable_fbapp_sbase)) { + # print("if 1") + # DF = hot_to_r(input$hot_btable_fbapp_sbase) + # #values[["hot_btable_fbapp_sbase"]] = DF + # + # ## Important Note: in case users upload different files, they will see: + # dirNameExtFile <- fbglobal::get_base_dir() + # #fileNameExtFile <- paste(dirNameExtFile, "fbappdatapath.rds") + # fileNameExtFile <- paste0(dirNameExtFile, servName) + # + # #if(file.exists(file.path(dirNameExtFile, "fbappdatapath.rds") )){ + # if(file.exists(fileNameExtFile)) { + # former_datapath <- readRDS(file = fileNameExtFile) + # if(hot_fbapp_path()!= former_datapath){ + # DF <- hot_bdata_sbase2 + # } + # } + # ### end important note + # values[["hot_btable_fbapp_sbase"]] = DF + # + # } else if (!is.null(values[["hot_btable_fbapp_sbase"]])) { + # DF = values[["hot_btable_fbapp_sbase"]] + # print("if 2") + # } + # + # + # if(!is.null(DF)){ + # + # dsource <- 2 + # traits <- traittools::get_trait_fb(DF, dsource = dsource) + # #print(traits) + # path <- fbglobal::get_base_dir() ##begin fbglobal + # path <- file.path(path,"hot_fieldbook_sbase.rds") + # saveRDS(DF, path) + # + # file_fbapp <- input$file_fbapp_sbase + # value_datapath <- file_fbapp$datapath + # datapath <- file.path(fbglobal::get_base_dir(), "fbappdatapath.rds") + # saveRDS(value_datapath, file = datapath) + # + # crop <- hot_crop_sbase() + # trait_dict <- get_crop_ontology(crop = crop, dsource = dsource) + # traittools::col_render_trait(fieldbook = DF, trait = traits , trait_dict = trait_dict, dsource = dsource) + # } + + + }) - #Export button: This event export and show the excel file for FieldBookApp-SPBase connection + #Export button: + #This event export and show the excel file for FieldBookApp-SPBase connection output$downloadData <- downloadHandler( filename = function() { paste('data-', Sys.Date(), '.csv', sep='') }, content = function(con) { - path <- fbglobal::get_base_dir() - #print(path) - shiny::withProgress(message = 'Downloading file', value = 0, { - - # print("datos directos") - # - # print(hot_to_r(input$hot_btable_fbapp_sbase)) - # - # print("datos values") - - incProgress(1/6, detail = paste("Reading HIDAP data...")) - path <- file.path(path,"hot_fieldbook_sbase.rds") - - - #print(path) - #DF <- readRDS(path) # Important note: run local - - DF <- hot_to_r(input$hot_btable_fbapp_sbase) # Important note: run server - - incProgress(2/6, detail = paste("Formatting hidap file...")) - - fb<- hidap2fbApp(fieldbook = DF) - - incProgress(3/6, detail = paste("Downloading FieldBookApp-SPBase file...")) - - incProgress(4/6, detail = paste("Refreshing HIDAP...")) - - Sys.sleep(3) - incProgress(5/6, detail = paste("Refreshing HIDAP...")) - - write.csv(fb, con,row.names = FALSE) - + + shiny::withProgress(message = 'Downloading file', value = 0, { + + incProgress(1/6, detail = paste("Reading HIDAP data...")) + DF <- hot_to_r(input$hot_btable_fbapp_sbase) # Important note: run server + incProgress(2/6, detail = paste("Formatting hidap file...")) + fb<- DF #hidap2fbApp(fieldbook = DF) + + + exportFormat <- input$fbcheck_fbapp_ExportFormat + if(exportFormat=="Simple"){ + names(fb)[1] <- "observationunit_name" + #Remove unncesary columns for simple format + #ToDo: ask if user need 'plot_id' column in 'simple' format for sweetpotatobase + fb$accession_name <- fb$plot_id <- fb$plot_number <- fb$block_number <- fb$is_a_control <- fb$rep_number <- fb$row_number <- fb$col_number <- NULL + fb <- fb + + } else { + fb + } + + incProgress(3/6, detail = paste("Downloading FieldBookApp-SPBase file...")) + incProgress(4/6, detail = paste("Refreshing HIDAP...")) + Sys.sleep(3) + incProgress(5/6, detail = paste("Refreshing HIDAP...")) + write.csv(fb, con,row.names = FALSE) + incProgress(6/6, detail = paste("Refreshing HIDAP...")) Sys.sleep(5) - #shinyjs::js$downloadData() + }) } ) - ############## end FieldBookApp ############## + ############## end FieldBookApp files ############################################################## } diff --git a/R/fbcheck_ui.R b/R/fbcheck_ui.R index 3486e17..fd672dd 100755 --- a/R/fbcheck_ui.R +++ b/R/fbcheck_ui.R @@ -31,6 +31,8 @@ fbcheck_ui <- function (type = "tab", title = "Data Quality and Processing", shiny::fileInput(inputId = "file_fbapp_sbase", label = "Choose CSV File", multiple = FALSE, accept = c("text/csv","text/comma-separated-values,text/plain", ".csv")), + selectInput(inputId = "fbcheck_fbapp_ExportFormat",label = "Spreadsheet format download",choices = c("Simple","Standard"), selected = "Standard"), + #actionButton('reset', 'Reset Input'), HTML('
'), @@ -44,8 +46,7 @@ fbcheck_ui <- function (type = "tab", title = "Data Quality and Processing", br(), tabBox( width = 12, - tabPanel( - "Standard Modules", + tabPanel("Standard Modules", # try(shinyFiles::shinyFilesButton("file","File select", "Please select a file", FALSE)), # shiny::actionButton("calculate","Calculate", icon("play-circle-o")), diff --git a/R/utils.R b/R/utils.R index e962c44..0abcf94 100755 --- a/R/utils.R +++ b/R/utils.R @@ -111,14 +111,14 @@ out_form_table <- function(form){ #Tranform data to tabular form ngen <- ncol(form) #number of evaluated genotyoes (cipnumber or variety) evaluated in organoleptic form - res <- gather(form, "INSTN", "Marks", 4:ngen) + res <- tidyr::gather(form, "INSTN", "Marks", 4:ngen) #---- Extraction of the following parameters: (1) Name of evaluator # (1) Name of evaluator, # (2) Type_of_trial , # (3) Name_of_Evaluator and (4) Sex - org_params<- res[1:4,] %>% select(Variable, Attributes) + org_params<- res[1:4,] %>% dplyr::select(Variable, Attributes) #Transform the long table in a spread table (line table) [variables as headers and parameters as values] - org_params <- org_params %>% spread(Variable, Attributes) %>% as.list() #organoletpic params + org_params <- org_params %>% tidyr::spread(Variable, Attributes) %>% as.list() #organoletpic params #Number of Panelist and Sex of the panelist PanelNo <- org_params$Number_of_panel @@ -127,10 +127,10 @@ out_form_table <- function(form){ #---- Extract x mark data (organoleptic votes for each variety) # Se agrego "NA" y NA para que filtre con esos valores. Hay algunos vectores que continene NA en forma de caracter o logico # (sin comillas) - org_marks <- res %>% filter(Variable %in% c("APPEARANCE","TASTE","TEXTURE","NA",NA)) + org_marks <- res %>% dplyr::filter(Variable %in% c("APPEARANCE","TASTE","TEXTURE","NA",NA)) #the number of genotypes gives us the number of repetation per block - nrow_org_marks <- n_distinct(org_marks$INSTN) + nrow_org_marks <- dplyr::n_distinct(org_marks$INSTN) #Filling the NA character values with the name of the variables org_vars <- c("APPEARANCE","TASTE","TEXTURE") %>% #vector @@ -138,10 +138,10 @@ out_form_table <- function(form){ rep(., nrow_org_marks) #number of repetition for each block ##### BEGIN TEST Add test: number of "x" in organoleptic form number '#' - org_marks <- mutate(org_marks, Marks = tolower(Marks)) + org_marks <- dplyr::mutate(org_marks, Marks = tolower(Marks)) #number of real and hipotetical x marks counted in organoleptic forms. - real_n_xmarks <- org_marks %>% select(Marks) %>% str_count(pattern = "x") + real_n_xmarks <- org_marks %>% dplyr::select(Marks) %>% stringr::str_count(pattern = "x") hipo_n_xmarks <- nrow_org_marks*3 if(real_n_xmarks == hipo_n_xmarks) { message <- paste("continue") @@ -154,12 +154,12 @@ out_form_table <- function(form){ geno_names <- unique(org_marks$INSTN) #Replace the older variable name by org_vars values - org_marks <- mutate(org_marks, Variable = org_vars) %>% - filter(Marks %in% c('x',"X")) %>% - select(-Marks,-Attributes) + org_marks <- dplyr::mutate(org_marks, Variable = org_vars) %>% + dplyr::filter(Marks %in% c('x',"X")) %>% + dplyr::select(-Marks,-Attributes) #Data transformation for analysis - org_marks_table <- org_marks %>% spread(Variable, Grade) %>% mutate(PanelNo, Sex) + org_marks_table <- org_marks %>% tidyr::spread(Variable, Grade) %>% dplyr::mutate(PanelNo, Sex) #If one genotypes have missing data, this code automatically auto-complete the orgaleptic tidy form @@ -332,7 +332,7 @@ hidap2fbApp <- function(fieldbook) { fbdb <- fieldbook # fbdb1 <- fbdb %>% tidyr::unite(plot_name, abbr_user, plot_number, rep, accesion_name, sep = "_") # trait_names <- names(fbdb1)[grepl("CO", x = names(fbdb1))] - # fbdb2 <- fbdb1 %>% gather_("trait", "value", names(fbdb1)[grepl("CO", x = names(fbdb1))]) + # fbdb2 <- fbdb1 %>% tidyr::gather_("trait", "value", names(fbdb1)[grepl("CO", x = names(fbdb1))]) # fbdb2$trait <- str_replace_all(fbdb2$trait, pattern = "-", "|" ) # fbdb2 fbdb1 <- fbdb %>% tidyr::unite(super_plot_name, abbr_user, plot_number, rep, accesion_name , timestamp, person ,location ,number, sep = "--") @@ -359,3 +359,58 @@ rhandsontable_update<- function(fieldbook){ temp <-fb out <- temp } + + +#' Convert FieldbookApp data to json structures +#' +#' @param dfr data.frame +#' @description FieldbookApp files (csv) should be transformed into json files in order to upload into Sol genomics databases. +#' @author Omar Benites +#' @export +# @param database character Choose a database at which you are extracting data. + +fbapp2json <- function(dfr){ + + headers<- c("plot_name", "plot_id", "block_number", "plot_number", "rep_number" , "row_number", "col_number", + "accession_name", "is_a_control", "synosyms", "trial_name", "location_name", "year", "pedigree", + "tier", "seedlot_name", "seed_transaction_operator", "num_seed_per_plot", "range_number", "plot_geo_json", + "timestamp", "person" ,"location", "number") + + #fieldbook headers + fb_headers <- names(dfr) + + #Crop Ontology (CO) headers + co_h_lg <- grepl(pattern = "CO", fb_headers) #logical exp. to detect co_headers + co_cols <- dfr[co_h_lg] #detect Crop ontology columns + + #Experiment columns: -get rid trait variables and retain experimental variables (plot, rep, year, etc) + exp_cols <- dfr[!co_h_lg] + + #continue ensemble the exp_cols and co_cols : fieldbook + fb_h<- c("plot_id", names(co_cols)) #fb_headers + fb<- cbind(exp_cols, co_cols) + fb<- fb[fb_h] + fb <- as.data.frame(fb, stringsAsFactors =FALSE) + names(fb) <- gsub(pattern = ".*\\|",replacement = "", x = names(fb) ) + + #tranpose data + tfb<- fb %>% tidyr::gather(observationVariableDbId, value, 2:ncol(fb)) + tfb[,"value"]<- as.character(tfb[, "value"]) #Brapi format + + #Bryan says: remove Values equal to NA. Only upload complete cases. + tfb <- tfb %>% dplyr::filter(complete.cases(.)) + + #rename first column for: "observationUnitDbID" (brapi standard) + names(tfb)[1] <- "observationUnitDbID" + tfb[,"observationUnitDbID"]<- as.character(tfb[, "observationUnitDbID"]) #Brapi format + + #Include access_token and Observations in the json format + tfb2list <- list(access_token= "RbgKDBRxmkdopsa2f40", Observations = tfb)#pass data.frame as element of the list + #tfb2list <- list(observations = tfb)#pass data.frame as element of the list + + #list To Json + list2json <- jsonlite::toJSON(tfb2list) + +} + +