R/tr8.R

In TR8: A Tool for Downloading Functional Traits Data for Plant Species

##
## Class Tr8 is used as a "containter" for all other functions and classes
## Class Tr8
## needed to download traits data from various databases
## 
## @name Tr8
## @rdname Tr8-Class
## @exportClass Tr8
## @slot species_list a list of species for which traits data are to be searched
## @slot results dataframe containing scraped traits
## @slot not_valid species whose name were not present in the Ecoflora database
## @slot double_names species for which more than one name was found
setClass("Tr8",representation =list(species_list="vector",results="data.frame",not_valid="vector",double_names="vector",bibliography="list",reference="data.frame",issues="ANY"))

## Method issues
##
## @name issues
## @rdname Tr8-Class
## @exportMethod issues
setGeneric(name="issues",def=function(.Object){standardGeneric("issues")})

## @rdname Tr8-Class
## @param .Object an object of class Tr8
setMethod(f="issues",
          signature = "Tr8",
          definition = function(.Object){
    check=FALSE
    ## warning for double names
    if(length(.Object@double_names)>0){
        cat("\n")
        cat("\t WARNING\n")
        cat("\n")
        for(sp in .Object@double_names){
            cat(paste("\tFor species",sp," multiple matched names were found\n"))
        }
        cat("\n")
        check=TRUE
    }
    ## warning for missing species
    if(length(.Object@not_valid)>0){
        cat("\n")
        cat("\t WARNING\n")
        cat("\n")
        for(sp in .Object@not_valid){
            cat(paste("\tFor species",sp," no matched names were found\n"))
        }
        cat("\n")
        check=TRUE
    }
    ## advice about potential issues given by Ecoflora
    if(!is.null(.Object@issues)){
        cat(.Object@issues)
        check=TRUE
    }
    if(check){
        cat("\tPlease check that these results are consistent with your orginal dataset!\n")
        ##              return(.Object)
    }else{

        cat("No particular problems were faced in the data retrieval process.\n")

    }
    
}

)


## Method lookup
##
## @name lookup
## @rdname Tr8-Class
## @exportMethod lookup
setGeneric(name="lookup",def=function(.Object){standardGeneric("lookup")})

## @rdname Tr8-Class
## @aliases lookup, Tr8-Class
## @param .Object an object of class Tr8
setMethod(f="lookup",
          signature="Tr8",
          definition = function(.Object){
    REF<-.Object@reference
    RES<-.Object@results
    DF<-REF[REF$short_code%in%names(RES),]

    cat("\n")
    cat("\n")
    cat("*****************************************************************")
    cat("\n")
    cat("To interpret the traits data, please refer to the following table\n")
    cat("\n")
    cat(sprintf("%-30s\t%-40s\t%-40s\n"," code","description","reference database\n"))
    cat(sprintf("%-30s\t%-40s\t%-40s\n"," ----","-----------","------------------\n"))
    for(i in 1:nrow(DF)){
        cat(sprintf("%-30s\t%-40s\t%-30s\n",DF[i,2],DF[i,3],DF[i,4]))
    }
    cat("\n")
    cat(sprintf("%-30s\t%-40s\t%-40s\n"," ****","***********","******************\n"))
    ##tp<-.Object@reference
    ##tp<-tp[,c("short_code","description","db")]
    tp<-DF[,c("short_code","description","db")]
    names(tp)<-revalue(names(tp),c("short_code"="code","db"="reference database"))
    return(invisible(tp))
}
)



## @rdname Tr8-Class
## @aliases show, Tr8-Class
## @param object an object of class Tr8
setMethod(f="show",
          signature="Tr8",
          function(object){
    print(object@results)
}
)


## A method to extract results form a Tr8 object
##
## the slots @results will be returned by the function
setGeneric("extract_traits",def=function(object){standardGeneric("extract_traits")})

setMethod(f="extract_traits",
          signature="Tr8",
          function(object){
    return(object@results)
}
)


## Method bib
                                        #@name bib
                                        #@rdname Tr8-Class
                                        #@exportMethod bib
setGeneric(name="bib",def=function(.Object){standardGeneric("bib")})


setMethod(f="bib",
          signature="Tr8",
          definition = function(.Object){
    env<-new.env(parent = parent.frame())
    data(column_list,envir = env)
    column_list<-get("column_list",envir=env)

    cat("\n")
    cat("Please use the following references for the data you retrieved with tr8()\n")
    cat("\n")
    for(db in names(.Object@bibliography)){
        cat("************************************************\n")
        cat("\n\nFor the following traits:\n\n")
        for(trait in .Object@bibliography[[db]]){
            cat("\t * ",paste(trait),"\n")
        }
        cat("\nplease use:\n\n")
        cat(db,fill=TRUE)
        cat("\n")
    }
    cat("************************************************\n")
}

)

## @rdname Tr8-Class
## @aliases bib, Tr8-Class
## @param .Object an object of class Tr8
## setMethod(f="bib",
##           signature="Tr8",
##           definition = function(.Object){
##               cat("\n")
##               cat("Please use the following references when using data retrieved with tr8()\n")
##               cat("\n")
##               ## cat(sep="\n",strwrap("BIOLFLOR - Eine Datenbank zu biologisch-ökologischen Merkmalen zur Flora von Deutschland. Schriftenreihe für Vegetationskunde 38: 1-333.  (Bundesamt für. Bonn, Bundesamt für Naturschutz)"))
##               ## cat("\n")
##               ## cat(sep="\n",strwrap("Kleyer, M., Bekker, R.M., Knevel, I.C., Bakker, J.P, Thompson, K., Sonnenschein, M., Poschlod, P., Van Groenendael, J.M., Klimes, L., Klimesova, J., Klotz, S., Rusch, G.M., Hermy, M., Adriaens, D., Boedeltje, G., Bossuyt, B., Dannemann, A., Endels, P., G\xf6tzenberger, L., Hodgson, J.G., Jackel, A-K., Kuehn, I., Kunzmann, D., Ozinga, W.A., Römermann, C., Stadler, M., Schlegelmilch, J., Steendam, H.J., Tackenberg, O., Wilmann, B., Cornelissen, J.H.C., Eriksson, O., Garnier, E., Peco, B. (2008): The LEDA Traitbase: A database of life-history traits of Northwest European flora. Journal of Ecology 96: 1266-1274."))
##               ## cat("\n")
##               ## cat(sep="\n",strwrap("Fitter, A . H. and Peat , H. J., 1994, The Ecological Flora Database, J. Ecol., 82, 415-425."))
##               ## cat("\n")
##               ## cat(sep="\n",strwrap("Pignatti S., Menegoni P., Pietrosanti S., 2005, Biondicazione attraverso le piante vascolari. Valori di indicazione secondo Ellenberg (Zeigerwerte) per le specie della Flora d'Italia. Braun-Blanquetia 39, Camerino, pp.  97."))
##               ## cat("\n")
##               ## cat(sep="\n",strwrap("Asem A. Akhmetzhanova, Nadejda A. Soudzilovskaia, Vladimir G. Onipchenko, Will K. Cornwell, Vladimir A. Agafonov, Ivan A. Selivanov, and Johannes H. C. Cornelissen. 2012. A rediscovered treasure: mycorrhizal intensity database for 3000 vascular plants species across the former Soviet Union. Ecology 93:689. URL: http://esapubs.org/Archive/ecol/E093/059/default.htm"))
##               ## cat("\n")
##           }
##           )


#' \code{tr8}: a function for retrieving functional traits data from various
#' databases. 
#' 
#' \code{tr8} makes use of other function provided by the \code{TR8} package in
#' order to query various databases and provide the user with a dataframe
#' containing traits data for the species of interest. 
#' 
#' @param species_list a vector containing names of the plant species for which
#' traits data want to be extracted.
#' @param download_list a 
#' @param gui_config if set to TRUE a GUI for selecting traits of interest is shown (default is TRUE)
#' @return data.frame containing various traits data for the species of interest
#' @author Gionata Bocci <boccigionata@@gmail.com>
#' @seealso \code{\link{available_traits}}, \code{\link{ecoflora}}, \code{\link{leda}}, \code{\link{biolflor}},\code{\link{pignatti_f}}
#' @references Please always use the following citations any time you use trait
#' data retrieved with \code{tr8}
#' 
#' \bold{BiolFlor}
#'
#' BIOLFLOR - Eine Datenbank zu biologisch-ökologischen Merkmalen zur Flora von Deutschland. Schriftenreihe für Vegetationskunde 38: 1-333.  (Bundesamt für. Bonn, Bundesamt für Naturschutz)
#' 
#' \bold{Ecoflora}
#' 
#' Fitter, A . H. and Peat , H. J., 1994, The Ecological Flora Database, J.
#' Ecol., 82, 415-425.  \samp{http://www.ecoflora.co.uk}
#' 
#' \bold{LEDA traitbase}
#' Kleyer, M., Bekker, R.M., Knevel, I.C., Bakker, J.P, Thompson, K., Sonnenschein, M., Poschlod, P.,
#' Van Groenendael, J.M., Klimes, L., Klimesova, J., Klotz, S., Rusch, G.M., Hermy, M., Adriaens, D.,
#' Boedeltje, G., Bossuyt, B., Dannemann, A., Endels, P., Götzenberger, L., Hodgson, J.G., Jackel, A-K.,
#' Kühn, I., Kunzmann, D., Ozinga, W.A., Römermann, C., Stadler, M., Schlegelmilch, J., Steendam, H.J.,
#' Tackenberg, O., Wilmann, B., Cornelissen, J.H.C., Eriksson, O., Garnier, E., Peco, B. (2008):
#' The LEDA Traitbase: A database of life-history traits of Northwest European flora.
#' Journal of Ecology 96: 1266-1274.
#'
#' \bold{Akhmetzhanova et al, 2012}
#' 
#' Asem A. Akhmetzhanova, Nadejda A. Soudzilovskaia, Vladimir G. Onipchenko,
#' Will K. Cornwell, Vladimir A. Agafonov, Ivan A. Selivanov, and Johannes H. C. Cornelissen. 2012.
#' A rediscovered treasure: mycorrhizal intensity database for 3000 vascular plants
#' species across the former Soviet Union. Ecology 93:689.
#' URL: http://esapubs.org/Archive/ecol/E093/059/default.htm
#'
#' 
#' \bold{Pignatti et al., 2005}
#' 
#' Pignatti S., Menegoni P., Pietrosanti S., 2005, Biondicazione attraverso le piante vascolari.
#' Valori di indicazione secondo Ellenberg (Zeigerwerte) per le specie della Flora d'Italia.
#' Braun-Blanquetia 39, Camerino, pp.  97.
#'
#' #' @examples \dontrun{
#' #My_traits<-tr8(species_list=c("Abies alba"),download_traits=c("le_area","h_max","h_min"))
#' }
#' @export tr8
tr8<-function(species_list,download_list=NULL,gui_config=FALSE,synonyms=FALSE,catminat_alternatives=FALSE, allow_persistent=NULL){

    ## if(tryCatch(nsl("www.cran.r-project.org"), error =function(e){return(FALSE)},warning=function(w){return(FALSE)})==FALSE){
    ##     stop("You need a working internet connection to use tr8()")
    ## }
    
    ## get column_list dataset
    env<-new.env(parent = parent.frame())
    data(column_list,envir = env)
    column_list<-get("column_list",envir=env)
    ## load lookup table
    ## convert it to a data frame
    temp_dframe<-ldply(column_list)
    names(temp_dframe)<-c("long_code","short_code","description","db")

    op<-options()
    options("guiToolkit"="tcltk")
    ## rest is used for Sys.sleep in all the retrieving functions
    rest=0.01

    ## dir.create does not seem to work under windows, thus
    ## TR8 will not try to create its own subdirectory any more
    ## but will simply use the standard user_data_dir
    ## appname <- "TR8"
    ## appauthor <- "GioBo"
    ## directory<-user_data_dir(appname, appauthor)
  
    if(is.null(allow_persistent)){
 
      risp <- ""
      cat("\nStoring downloaded data in persistent files will\n")
      cat("allow faster future queries.\n\n")
      risp <- readline("Do you allow tr8 to store data in a persistent file(s)?\n (answer y/n; Enter to abort): \n")
      cat("\n\n To avoid this message, set the 'allow_persistent' parameter to\n")
      cat("either FALSE (tr8 will use temporary files that will be deleted at\n")
      cat("the end of the session) or TRUE, e.g.:\n")
      cat("\n 'tr8(species_list=\"Salix alba\", download_list=c(\"h_max\"), allow_persistent=TRUE)'\n\n")
        
      
      if(!risp%in%c("n","y")){
        cat("Please rerun tr8 and select one between y or n or,\n")
        return()
      }

                                        #
      if(risp=="n" ){
        ## use tempdir
        directory <- tempdir()
        allow_persistent <- FALSE
      }
      if(risp=="y"){
        directory<-user_data_dir()
        allow_persistent <- TRUE}
    }
    if(allow_persistent){
      directory<-user_data_dir()}else if(!allow_persistent){
                                  directory <- tempdir() }    


  
    

    
    if(missing(species_list)||!is.character(species_list)){
        message("\ntr8() accepts only a list of plant species names \nplease read help(tr8)\n")
    }else{
        traits_list<-list()
        ## if the user wants to manually sets the parameters to download
        if(gui_config)
        {
            ##gmessage(title="TR8 reminder!","Please always use the appropriate citations for the downloaded data.\n
            ##\n Run the bib() function on the downloaded data to get the correct bibliographic citations to be used.\n")
            ## run the gui
            traits_list<-tr8_config()
        }else{
            for(db in c("BiolFlor","LEDA","Ecoflora","Pignatti","AMF","Catminat","BROT","PLANTS","EFlora_Cal","Imkerbond")){
                                        #db<-temp_dframe$db[temp_dframe$short_code==i]
                data_db<-temp_dframe[temp_dframe$db==db,]
                if(sum(data_db$short_code%in%download_list)>0){
                    code<-data_db$long_code[data_db$short_code%in%download_list]
                    traits_list[db]<-list(code)
                }else{code<-NULL}
            }
        }
        
        if(length(species_list) > length(unique(species_list))){
            duplicates <- names(which(table(species_list)>1))
            message("\nDouble entries were found for the following species: \n")
            for(i in duplicates){cat("\n \t *",i,"\n")}
            message("\nBeware that tr8() will remove double entries from the search.\n")
            
            species_list <- unique(species_list)
        }
        
        if(synonyms==TRUE){
            
            ## check_names<-tnrs(species_list,verbose=FALSE)
            ## check_names<-check_names[,c("submittedname","acceptedname","matchedname")]
            
            ## reference_names<-lapply(species_list,function(x){
                
            ##     sp_names<-check_names[check_names$submittedname==x,]
            ##     sp_names<-unique(unlist(sp_names))
            ##     sp_names<-sp_names[grep("^\\w+ \\w+.*$",sp_names)]
            ##     return(sp_names)

            ## }
            ## )
            ## names(reference_names)<-species_list
            ## species_list<-unique(as.vector(unlist(reference_names)))

            warning("The synonyms option is deprecated in current version of TR8")

        }
        
        
        ## retrieve traits from ecolora function
        local_ecoflora<-file.path(directory,"ECOFLORA_df.Rda")
        if(file.exists(local_ecoflora)){
          load(local_ecoflora)}else{
                                  if(length(traits_list$Ecoflora)>0){
                                    
                                    local_storage(db="Ecoflora",directory)
                                    load(local_ecoflora)
                                  }
                                }
        eco_traits<-ecoflora(species_list,TRAITS=traits_list$Ecoflora,rest=rest)
        
        ## check if an already downloaded version of the LEDA database
        ## exists and, if so, use it otherwise download a copy, but only
        ## if at least one LEDA trait is needed
        local_leda<-file.path(directory,"leda_database.Rda")
        if(file.exists(local_leda)){
            rearranged<-get(load(local_leda))}else{
            if(length(traits_list$LEDA)>0){
              
                ## unfortunately nls() does not work on Windows, thus I think it's better to remove that
                ## if(tryCatch(nsl("www.cran.r-project.org"), error =function(e){return(FALSE)},warning=function(w){return(FALSE)})==FALSE){
                ##     stop("You neither have a working internet connection nor locally stored LEDA files.\n  Please re-run tr8() function when your internet connection is working.")
                ## }
                ##url_leda="http://www.uni-oldenburg.de/en/landeco/research/projects/LEDA/Data-Files/"
                url_leda="https://www.uni-oldenburg.de/fileadmin/user_upload/biologie/ag/landeco/download/LEDA/Data_files/branching.txt"
                ##url_leda="http://www.uni-oldenburg.de/en/landeco/research/projects/LEDA/Data%20Files/"
                if(tryCatch(url.exists(url_leda), error =function(e){return(FALSE)},warning=function(w){return(FALSE)})==FALSE){
                    stop("\n\n LEDA website is probably down.\n Please re-run tr8() without selecting LEDA as a source of data \n (or re-try later).\n\n")
                }
              
                local_storage(db="LEDA",directory)
                rearranged<-get(load(local_leda))
            }else{rearranged<-NULL}
        }
        leda_traits<-leda(species_list,TRAITS=traits_list$LEDA,rearranged=rearranged)
        
        ## retrieve data from BiolFlor
        biolflor_traits<-biolflor(species_list,TRAITS=traits_list$BiolFlor,rest=rest,directory=directory)
        
        ## retrieve data from Pignatti
        pignatti_traits<-pignatti_f(species_list,TRAITS=traits_list$Pignatti)

        ## retrieve flowering periods for Italy
        it_flowering<-get_italian_flowering(species_list,TRAITS=traits_list$Pignatti,rest=rest)
        
        ## add AMF
        ## if AMF is not already downloaded, local_storage is run (but only
        ## if this trait is requred
        TRAIT_AK="Akhmetzhanova"
        ##is the user interested in downloadin Akhmetzhanova?
        if("Myco_infection"%in%traits_list$AMF){
            ## then check if the dataset has already been downloaded
            local_amf<-file.path(directory,"myco.Rda")
            if(file.exists(local_amf)){
                load(local_amf)}else{
                ##  ## otherwise download it now
                ## if(tryCatch(nsl("www.cran.r-project.org"), error =function(e){return(FALSE)},warning=function(w){return(FALSE)})==FALSE){
                ##      stop("You neither have a working internet connection nor locally stored files from Akhmetzhanova et al.\n  Please re-run tr8() function when your internet connection is working.")
                ##  }

                local_storage(db="Akhmetzhanova",directory)
                load(local_amf)
            }
        }else{myco<-NULL
            TRAIT_AK<-NULL
        }
        
        amf_traits<-retrieve_amf(species_list,TRAITS=TRAIT_AK,rest=rest,data_myco=myco)

        ## check&download mycoflor

        TRAIT_MYC="MycoFlor"
        ##is the user interested in downloadin MycoFlor?
        if("MycoFlor"%in%traits_list$AMF){
            ## then check if the dataset has already been downloaded
            local_amf<-file.path(directory,"MycoFlor.Rda")
            if(file.exists(local_amf)){
                load(local_amf)}else{
                ## ## otherwise download it now
                ## if(tryCatch(nsl("www.cran.r-project.org"), error =function(e){return(FALSE)},warning=function(w){return(FALSE)})==FALSE){
                ##     stop("You neither have a working internet connection nor locally stored files from MycoFlor.\n  Please re-run tr8() function when your internet connection is working.")
                ## }

                local_storage(db="MycoFlor",directory)
                load(local_amf)
            }
        }else{
            MycoFlor<-NULL
            TRAIT_MYC<-NULL
        }

        amf_MycoFlor<-retrieve_MycoFlor(species_list,TRAITS=TRAIT_MYC,rest=rest,data_myco=MycoFlor)


        ## Imkerbond


        Imkerbond_traits <- imkerbond_get(species_list,TRAITS=traits_list$Imkerbond)
        
        ## check if an already downloaded version of the Catminat database
        ## exists and, if so, use it otherwise download a copy, but only
        ## if at least one Catminat trait is needed
        local_Catminat<-file.path(directory,"catminat.Rda")
        if(file.exists(local_Catminat)){
            load(local_Catminat)}else{
            if(length(traits_list$Catminat)>0){
                local_storage(db="Catminat",directory)
                load(local_Catminat)
            }else{catminat_df<-NULL}
        }
        ##        leda_traits<-leda(species_list,TRAITS=traits_list$LEDA,rearranged=rearranged)
        catminat_traits<-catminat(species_list,TRAITS=traits_list$Catminat,catminat_df,similar=catminat_alternatives)
        
        ## check if an already downloaded version of the BROT database
        ## exists and, if so, use it otherwise download a copy, but only
        ## if at least one BROT trait is needed
        local_BROT<-file.path(directory,"BROT.Rda")
        if(file.exists(local_BROT)){
            load(local_BROT)}else{
            if(length(traits_list$BROT)>0){
                local_storage(db="BROT",directory)
                load(local_BROT)
            }else{BROT_df<-NULL}
        }
        
        brot_traits <- brot_data(species_list,TRAITS=traits_list$BROT)
        
        ## download traits from Electronic Flora of Californa
        efloracal_traits<-eflora(species_list,TRAITS=traits_list$efloracal)
        
        ## check if an already downloaded version of the PLANTS database
        ## exists and, if so, use it otherwise download a copy, but only
        ## if at least one BROT trait is needed
        local_PLANTS<-file.path(directory,"PLANTS.Rda")
        if(file.exists(local_PLANTS)){
            load(local_PLANTS)}else{
            if(length(traits_list$PLANTS)>0){
                local_storage(db="PLANTS",directory)
                load(local_PLANTS)
            }else{PLANTS_df<-NULL}
        }
        
        PLANT_traits <- PLANTS(species_list,TRAITS=traits_list$PLANTS)
        
        
        ## merge the results
        tr8_traits<-data.frame(species_list,row.names=species_list)
        bibliography=list()
        potential_issues<-c()
        for(i in c(eco_traits,biolflor_traits,leda_traits,pignatti_traits,it_flowering,amf_traits,amf_MycoFlor,catminat_traits,brot_traits,PLANT_traits,efloracal_traits,Imkerbond_traits)){
            ## merge the dataframes only if they contain data
            if(!is.null(i@results))
            {
                ## clean dataframe column names
                i@results<-column_conversion(i@results)
                ## update the bibliography (Adding the required sources
                
                bibliography[[i@bibliography]]=names(i@results)
                tr8_traits=merge(tr8_traits,i@results,by.x=0,by.y=0,all=TRUE)
                row.names(tr8_traits)<-tr8_traits$Row.names
                tr8_traits<-tr8_traits[,-1,drop=FALSE]
                potential_issues<-c(potential_issues,i@issues)
            }
        }

        ## remove column species_list
        row_names<-row.names(tr8_traits)
        ## names_columns<-names(tr8_traits)[!(names(tr8_traits)%in%c("Row.names","species_list"))]
        ## names(tr8_traits)<-names_columns
        ## tr8_traits<-as.data.frame(tr8_traits[,names_columns],row.names = row_names)
        tr8_traits<-tr8_traits[,!(names(tr8_traits)%in%c("Row.names","species_list")),drop=FALSE]
        
        obj<-new("Tr8")
        ##    obj@double_names<-unique(c(eco_traits@double_names,leda_traits@double_names))
        ##    obj@not_valid<-intersect(intersect(eco_traits@not_valid,leda_traits@not_valid),pignatti_traits@not_valid)

        ## biolflor_clean is not needed any more
        ## tr8_traits<-biolflor_clean(tr8_traits)
        tr8_traits<-column_conversion(tr8_traits)
        
        
        if(synonyms==TRUE){
            
            ## reference_names<-ldply(lapply(reference_names,ldply))
            ## names(reference_names)<-c("original_names","synonyms")
            ## tr8_traits<-merge(reference_names,tr8_traits,by.x="synonyms",by.y=0,all=T)
            cat("\nPlease note: the synonyms option is deprecated in current version of TR8\n\n")
            ## warning("The synonyms option deprecated in current version of TR8")


            ## in this case, where synonyms are required, then
            ## row names is left with "numbers" since many strange coincidences may
            ## happen (eg. two different species may have been found under the
            ## same synonym, eg. using them as row.names would rais an error (and orginal
            ## names cannot be used for the very same reason)
            ##row.names(tr8_traits)<-tr8_traits$synonyms
            ##tr8_traits<-tr8_traits[,names(tr8_traits)!="synonyms"]
        }


        obj@reference<-temp_dframe
        obj@results<-tr8_traits
        obj@bibliography<-bibliography
        obj@issues<-potential_issues
        
                                        #    issues(obj)
        ##return(obj)
                                        #    return(tr8_traits)

        options(op)
        remove(list=c("column_list"), envir = env)    
        return(obj)
    }
}