R/export.R

In mchevalier2/crestr: A Probabilistic Approach to Reconstruct Past Climates Using Palaeoecological Datasets

#' Export the results
#'
#' Export the results generated by the reconstruction
#'
#' @inheritParams crestObj
#' @param dataname The name of the site (default: \code{x$misc$site_info$site_name})
#' @param climate The climate data to export. Data for all climate variables are
#'        saved by default.
#' @param loc The path where to export the data (default: working directory)
#' @param as.csv Boolean to indicate if the data should be exported as csv (\code{TRUE}) or xlsx (\code{FALSE}, default)
#' @param fullUncertainties A boolean to export the full climate uncertainty distribution (default \code{FALSE})
#' @param loo A boolean to export the leave-one-out data if they exist (default \code{FALSE})
#' @param weights A boolean to export the weights derived from the percentages (default \code{FALSE})
#' @param pdfs A boolean to export the taxa's \code{pdfs} (default \code{FALSE})
#' @return No return value, function called to export the results.
#' @export
#' @examples
#' \dontrun{
#'   data(crest_ex)
#'   data(crest_ex_pse)
#'   data(crest_ex_selection)
#'   reconstr <- crest(
#'     df = crest_ex, pse = crest_ex_pse, taxaType = 0,
#'     site_info = c(7.5, 7.5),
#'     climate = c("bio1", "bio12"), bin_width = c(2, 20),
#'     shape = c("normal", "lognormal"),
#'     selectedTaxa = crest_ex_selection, dbname = "crest_example",
#'     leave_one_out = TRUE
#'   )
#'   #> Replace 'tempdir()' by the location where the sample should be saved (e.g. 'getwd()')
#'   export(reconstr, dataname='crest_example',
#'          fullUncertainties=TRUE, weights=TRUE, loo=TRUE, pdfs=TRUE,
#'          loc=tempdir())
#' }
#'
export <- function( x, dataname = x$misc$site_info$site_name,
                    climate = x$parameters$climate,
                    loc = getwd(), as.csv = FALSE,
                    fullUncertainties = FALSE,
                    loo = FALSE,
                    weights = FALSE,
                    pdfs = FALSE) {

    if(base::missing(x)) x

    if (is.crestObj(x)) {
        if (length(x$reconstructions) == 0) {
            stop("No reconstruction available for export.\n")
        }

        err <- c()
        for(clim in climate) {
            if(! clim %in% x$parameters$climate) err <- c(err, clim)
        }
        if(length(err) > 0) {
            stop(paste0("The following variables are not available in your crestObj: '", paste(err, collapse="', '"), "'\n\n"))
            return(invisible(NA))
        }

        if(is.na(dataname)) dataname <- 'crest_outputs'
        if (!base::file.exists(base::file.path(loc, dataname))){
            base::dir.create(base::file.path(loc, dataname), showWarnings = TRUE)
        }

        if ((!'loo' %in% names(x$reconstructions[[climate[1]]])) & loo) {
            loo <- FALSE
            warning("Leave-one-out data not available. Look at loo() for more details.\n")
        }

        save2<-function(recon, ...) { save(recon, ...)}
        save2(x, file = base::file.path(loc, dataname, paste0(dataname, '.RData')))

        if(!as.csv) {
            if (!requireNamespace("openxlsx", quietly = TRUE)) {
                as.csv <- TRUE
                warning("The package 'openxlsx' is required to export the data as excel spreadsheets. The data have been exported as csv.\n\n")
            }
        }

        loo.exist <- loo
        for (clim in climate) {
            base::dir.create(base::file.path(loc, dataname, clim), showWarnings = TRUE)

            if ((!'loo' %in% names(x$reconstructions[[clim]])) & loo) {
                loo.exist <- FALSE
                warning(paste0("Leave-one-out data not available for '", clim,"'. Look at loo() for more details.\n"))
            }

            df <- rep(NA, 5)
            df <- rbind(df, c(paste0('NAME OF THE DATASET: ', x$misc$site_info$site_name), NA, NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c(paste('LAST UPDATE:', base::date()), NA, NA, NA, NA))
            df <- rbind(df, c('CONTRIBUTOR:', NA, NA, NA, NA))
            df <- rbind(df, c('CONTACT:', NA, NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c('ORIGINAL REFERENCE:', NA, NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c('DESCRIPTION:', NA, NA, NA, NA))
            df <- rbind(df, c(NA, 'Parameters: List of parameters used in this study', NA, NA, NA))
            df <- rbind(df, c(NA, 'Reconstruction: The reconstructed values for each samples and the levels of uncertainties', NA, NA, NA))
            if(fullUncertainties)  df <- rbind(df, c(NA, 'fullUncertainties: The distribution of uncertainties for each sample', NA, NA, NA))
            df <- rbind(df, c(NA, 'taxa_percentage: The percentage data used to generate the reconstructions', NA, NA, NA))
            if(weights)  df <- rbind(df, c(NA, 'taxa_weights: The weights derived from the percentage', NA, NA, NA))
            if(loo & loo.exist)  df <- rbind(df, c(NA, 'leave_one_out: Results of the leave-one-out analysis', NA, NA, NA))
            df <- rbind(df, c(NA, 'selectedTaxa: List of taxa identified in the study and which ones are selected.', NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            refs <- cite_crest(x, verbose=FALSE)
            df <- rbind(df, c('ADDITONNAL REFERENCES (these references must be included if you are publishing your reconstructions to support data/methods providers)', NA, NA, NA, NA))
            df <- rbind(df, c(NA, 'Method: ', NA, NA, NA))
            df <- rbind(df, c(NA, NA, refs$method[1], NA, NA))
            if(length(refs$method) > 1) {
                df <- rbind(df, c(NA, 'Curated calibration dataset: ', NA, NA, NA))
                for(i in 2:length(refs$method))  df <- rbind(df, c(NA, NA, refs$method[i], NA, NA))
            }
            if ('climate' %in% names(refs)) {
                df <- rbind(df, c(NA, 'Climate data: ', NA, NA, NA))
                for(i in 1:length(refs$climate))  df <- rbind(df, c(NA, NA, refs$climate[i], NA, NA))
            }
            if ('distrib' %in% names(refs)) {
                df <- rbind(df, c(NA, 'Distribution data: ', NA, NA, NA))
                for(i in 1:length(refs$distrib))  df <- rbind(df, c(NA, NA, refs$distrib[i], NA, NA))
            }

            if(as.csv) {
                utils::write.table(df, base::file.path(loc, dataname, clim, 'ReadMe.txt'), col.names=FALSE, row.names=FALSE, quote=FALSE, na='', sep='\t')
            } else {
                wb <- openxlsx::createWorkbook()
                openxlsx::addWorksheet(wb, "ReadMe")
                openxlsx::writeData(wb, sheet = "ReadMe", x = df, colNames=FALSE)
            }


            df <- rep(NA, 5)
            df <- rbind(df, c('SITE INFO:', NA, NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Longitude: ', x$misc$site_info$long, ' \u00B0E'), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Latitude: ', x$misc$site_info$lat, ' \u00B0N'), NA, NA, NA))
            df <- rbind(df, c(NA, paste0(clim, ' modern value: ', x$misc$site_info$climate[clim]), NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c('DEFINITION OF THE STUDY AREA:', NA, NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Longitude: ', x$parameters$xmn, ' - ', x$parameters$xmx, ' \u00B0E'), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Latitude: ', x$parameters$ymn, ' - ', x$parameters$ymx, ' \u00B0N'), NA, NA, NA))
            if(x$parameters$taxaType > 0) { # Nothing necessary for the example or private data.
                if(!is.na(x$parameters$elev_min) | !is.na(x$parameters$elev_max)) df <- rbind(df, c(NA, paste0('Elevation: ', x$parameters$elev_min, ' - ', x$parameters$elev_max, ' m'), NA, NA, NA))
                if(!is.na(x$parameters$elev_range))df <- rbind(df, c(NA, paste0('Elevation range: ', x$parameters$elev_range, ' m'), NA, NA, NA))
                if(!is.na(x$parameters$year_min) | !is.na(x$parameters$year_max)) df <- rbind(df, c(NA, paste0('Date of observations: ', x$parameters$year_min, ' - ', x$parameters$year_max), NA, NA, NA))
                if(!is.na(x$parameters$nodate)) df <- rbind(df, c(NA, paste0('Inclusion of undated observations: ', x$parameters$nodate), NA, NA, NA))
                dbname <- .exampleDB()
                res <- dbRequest("SELECT * FROM typeofobservations ORDER BY type_of_obs", dbname)
                df <- rbind(df, c(NA, paste0('Type of observations included: ', paste(base::trimws(res[x$parameters$type_of_obs, 2]), collapse=', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$continents))) df <- rbind(df, c(NA, paste0('Data restricted to the following continent(s): ', paste(x$parameters$continents, collapse = ', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$countries))) df <- rbind(df, c(NA, paste0('Data restricted to the following country(ies): ', paste(x$parameters$countries, collapse = ', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$basins))) df <- rbind(df, c(NA, paste0('Data restricted to the following basin(s): ', paste(x$parameters$basins, collapse = ', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$sectors))) df <- rbind(df, c(NA, paste0('Data restricted to the following sector(s): ', paste(x$parameters$sectors, collapse = ', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$realms))) df <- rbind(df, c(NA, paste0('Data restricted to the following realm(s): ', paste(x$parameters$realms, collapse = ', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$biomes))) df <- rbind(df, c(NA, paste0('Data restricted to the following biome(s): ', paste(x$parameters$biomes, collapse = ', ')), NA, NA, NA))
                if(!unique(is.na(x$parameters$ecoregions))) df <- rbind(df, c(NA, paste0('Data restricted to the following ecoregion(s): ', paste(x$parameters$ecoregions, collapse = ', ')), NA, NA, NA))
            }
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c('DEFINITION OF THE PDFS:', NA, NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Minimum number of presence records: ', x$parameters$minGridCells), NA, NA, NA))
            if (is.null(nrow(x$inputs$pse))) df <- rbind(df, c(NA, paste0('Weighted presence records: ', ifelse(x$parameters$weightedPresences, 'Yes', 'No')), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Climate Space Weighting: ', ifelse(x$parameters$climateSpaceWeighting, 'Yes', 'No')), NA, NA, NA))
            if (x$parameters$climateSpaceWeighting) df <- rbind(df, c(NA, paste0('     - Using correction: ', x$parameters$climateSpaceWeighting.type), NA, NA, NA))
            if (x$parameters$climateSpaceWeighting) df <- rbind(df, c(NA, paste0('     - Bin width: ', x$parameters$bin_width[clim, ]), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Restricting climate space to grid cells with observation: ', ifelse(x$parameters$climateWithObs, 'Yes', 'No')), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Species weighted by abundance: ', ifelse(x$parameters$geoWeighting, 'Yes', 'No')), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Shape of the species pdfs: ', x$parameters$shape[clim, ]), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Number of points: ', x$parameters$npoints), NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c('RECONSTRUCTION OPTIONS:', NA, NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Presence threshold: ', x$parameters$presenceThreshold), NA, NA, NA))
            df <- rbind(df, c(NA, paste0('Weighting approach: ', x$parameters$taxWeight), NA, NA, NA))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, rep(NA, 5))
            df <- rbind(df, c(paste0('DATABASE USED: ', x$misc$dbname), NA, NA, NA, NA))

            if(as.csv) {
                utils::write.table(df, base::file.path(loc, dataname, clim, 'Parameters.txt'), col.names=FALSE, row.names=FALSE, quote=FALSE, na='', sep='\t')
            } else {
                openxlsx::addWorksheet(wb, "Parameters")
                openxlsx::writeData(wb, sheet = "Parameters", x = df, colNames=FALSE)
            }


            df <- cbind(x$reconstructions[[clim]]$optima[, -3], x$reconstructions[[clim]]$uncertainties[, -1], stringsAsFactors=FALSE)
            if(as.csv) {
                utils::write.csv(df, base::file.path(loc, dataname, clim, 'Reconstruction.csv'), row.names=FALSE, quote=FALSE, na='')
            } else {
                openxlsx::addWorksheet(wb, "Reconstruction")
                openxlsx::writeData(wb, sheet = "Reconstruction", x = df)
            }


            if (fullUncertainties) {
                df <- cbind(t(x$reconstructions[[clim]]$likelihood))
                colnames(df) <- c(clim, x$inputs$x)
                if(as.csv) {
                    utils::write.csv(df, base::file.path(loc, dataname, clim, 'fullUncertainties.csv'), row.names=FALSE, quote=FALSE, na='')
                } else {
                    openxlsx::addWorksheet(wb, "fullUncertainties")
                    openxlsx::writeData(wb, sheet = "fullUncertainties", x = df)
                }
            }

            df <- cbind(x$inputs$x, x$inputs$df, stringsAsFactors=FALSE)
            colnames(df)[1] <- c(x$inputs$x.name)
            if(as.csv) {
                utils::write.csv(df, base::file.path(loc, dataname, clim, 'taxa_percentage.csv'), row.names=FALSE, quote=FALSE, na='')
            } else {
                openxlsx::addWorksheet(wb, "taxa_percentage")
                openxlsx::writeData(wb, sheet = "taxa_percentage", x = df)
            }

            if (weights) {
                df <- cbind(x$inputs$x, x$modelling$weights, stringsAsFactors=FALSE)
                colnames(df)[1] <- c(x$inputs$x.name)
                if(as.csv) {
                    utils::write.csv(df, base::file.path(loc, dataname, clim, 'taxa_weights.csv'), row.names=FALSE, quote=FALSE, na='')
                } else {
                    openxlsx::addWorksheet(wb, "taxa_weights")
                    openxlsx::writeData(wb, sheet = "taxa_weights", x = df)
                }
            }

            if (loo & loo.exist) {
                df <- x$inputs$x
                for (tax in names(x$reconstructions[[clim]]$loo)) {
                    if (unique(is.na(as.vector(x$reconstructions[[clim]]$loo[[tax]])))) {
                        df <- cbind(df, rep(NA, length(x$inputs$x)))
                    } else {
                        df <- cbind(df, x$reconstructions[[clim]]$loo[[tax]][, 'optima'])
                    }
                }
                colnames(df) <- c(x$inputs$x.name, names(x$reconstructions[[clim]]$loo))
                if(as.csv) {
                    utils::write.csv(df, base::file.path(loc, dataname, clim, 'leave_one_out.csv'), row.names=FALSE, quote=FALSE, na='')
                } else {
                    openxlsx::addWorksheet(wb, "leave_one_out")
                    openxlsx::writeData(wb, sheet = "leave_one_out", x = df)
                }
            }


            if (is.null(nrow(x$inputs$pse))) {
                df <- data.frame(ProxyName = x$inputs$taxa.name,
                                 Selected = rep('Yes', length(x$inputs$taxa.name)),
                                 Comment = rep(NA, length(x$inputs$taxa.name)),
                                 stringsAsFactors = FALSE)

                for (tax in x$inputs$taxa.name) {
                    if (x$input$selectedTaxa[tax, clim] == 0) {
                        df[df[, 'ProxyName'] == tax, 5:6] <- rep(c('No', paste0('Not sensitive to ', clim)), each=sum(tmp))
                    }
                }

            } else {
                df <- data.frame(ProxyName = x$inputs$taxa.name,
                                 Family = rep(NA, length(x$inputs$taxa.name)),
                                 Genus = rep(NA, length(x$inputs$taxa.name)),
                                 Species = rep(NA, length(x$inputs$taxa.name)),
                                 Selected = rep('Yes', length(x$inputs$taxa.name)),
                                 Comment = rep(NA, length(x$inputs$taxa.name)),
                                 stringsAsFactors = FALSE)

                for (tax in x$inputs$taxa.name) {
                    tmp <- x$inputs$pse[, 'ProxyName'] == tax
                    if(sum(tmp) > 1) {
                        row = df[df[, 'ProxyName'] == tax, ]
                        for(i in 2:sum(tmp)) {
                            df <- rbind(df, row)
                        }
                    }
                    df[df[, 'ProxyName'] == tax, 2] <- as.character(x$inputs$pse[x$inputs$pse[, 'ProxyName'] == tax, 2])
                    df[df[, 'ProxyName'] == tax, 3] <- as.character(x$inputs$pse[x$inputs$pse[, 'ProxyName'] == tax, 3])
                    df[df[, 'ProxyName'] == tax, 4] <- as.character(x$inputs$pse[x$inputs$pse[, 'ProxyName'] == tax, 4])
                    if (x$input$selectedTaxa[tax, clim] == 0) {
                        df[df[, 'ProxyName'] == tax, 5:6] <- rep(c('No', paste0('Not sensitive to ', clim)), each=sum(tmp))
                    }
                }

                for(n in names(x$misc$taxa_notes)) {
                    list_of_tax <- x$misc$taxa_notes[[n]]
                    if(is.data.frame(list_of_tax))  list_of_tax <- list_of_tax[, 5]

                    for(tax in list_of_tax) {
                        if(tax %in% unique(x$inputs$pse[, 'ProxyName'])) {
                            for(w in which(x$inputs$pse[, 'ProxyName'] == tax)) {
                                df <- rbind(df,
                                            c(tax,
                                              as.character(x$inputs$pse[w, 2]),
                                              as.character(x$inputs$pse[w, 3]),
                                              as.character(x$inputs$pse[w, 4]),
                                              'No',
                                              n), stringsAsFactors=FALSE)
                            }
                        } else {
                            df <- rbind(df, c(tax, NA, NA, NA, 'No', n), stringsAsFactors=FALSE)
                        }
                    }
                }
            }

            df <- df[with(df, order(Selected, Comment, ProxyName)), ]
            if(as.csv) {
                utils::write.csv(df, base::file.path(loc, dataname, clim, 'selectedTaxa.csv'), row.names=FALSE, quote=FALSE, na='')
            } else {
                openxlsx::addWorksheet(wb, "selectedTaxa")
                openxlsx::writeData(wb, sheet = "selectedTaxa", x = df)
            }

            if(!as.csv) openxlsx::saveWorkbook(wb, file.path(loc, dataname, clim, paste0(clim, '.xlsx')), overwrite = TRUE)

            if(pdfs) export_pdfs(x, dataname, climate, taxa=x$inputs$taxa.name, loc, as.csv)
        }
    } else {
        cat("'\ncrestr::export()' is only availble for crestObj objects.\n\n")
    }
    invisible(x)
}