R_old/vegtable2/db2vegtable.R

In kamapu/vegtableDB: Handling Vegetation Data Sets (Advanced Features)

#' @name db2vegtable
#'
#' @title Import PostgreSQL databases into vegtable objects
#'
#' @description
#' Import and adaption of Postgres tables into objects of class
#' [vegtable-class].
#'
#' In the case that some schemas are not mentioned, the function assumes such
#' tables are located in the same schema as the table header. Thus for
#' databases placed in just one schema, this need to be set only in argument
#' `header_schema`.
#'
#' @param conn A database connection provided by [dbConnect()].
#' @param header,samples Character vectors indicating the schema and table
#'     containing header and samples information, respectively.
#' @param sql_header SQL statement to be used instead of `header`.
#' @param layers,coverconvert Lists of vectors for the respective slots,
#'     each containing schema and name of required table.
#' @param relations A list of vectors indicating the schema and table in the
#'     database, excluding 'data_source'.
#' @param geometry Name of the variable in header containing the geometry of
#'     the plots.
#' @param description Named vector with metadata.
#' @param as_list Logical value indicating whether a list or an object of class
#'     [vegtable-class] should be returned.
#' @param get_data_sources Logical argument whether references should be
#'     imported as data sources or not.
#' @param bib_args List of arguments passed to [biblio::read_bib()].
#' @param taxon_names,taxon_relations,taxon_traits,taxon_views,taxon_levels,names2concepts
#'     Arguments passed to [db2taxlist()].
#' @param ... Further arguments passed to [db2taxlist()].
#' @param get_countries Logical argument, specific for the databases
#'     'sudamerica' and 'SWEA-Dataveg', indicating whether country information
#'     should be reimported from integrated map.
#' @param head_cols Character vector indicating the header variables to be
#'     imported (except the coordinates).
#' @param samples_cols Character vector indicating the samples variables to be
#'     imported.
#'
#' @rdname db2vegtable
#'
#' @export
db2vegtable <- function(conn, ...) {
  UseMethod("db2vegtable", conn)
}

#' @rdname db2vegtable
#' @export
db2vegtable.PostgreSQLConnection <- function(conn, header, sql_header, samples,
                                             relations, layers, coverconvert,
                                             geometry, description,
                                             as_list = FALSE,
                                             ...) {
  veg_obj <- list()
  # description
  if (!missing(description)) {
    veg_obj$description <- description
  } else {
    veg_obj$description <- c(remark = "Object imported by 'db2vegtable()'.")
  }
  # species
  veg_obj$species <- db2taxlist(conn = conn, ...)
  # header
  message("Importing vegtable body...")
  if (missing(sql_header) & missing(geometry)) {
    Query <- paste0(
      "SELECT *\n",
      "FROM \"", paste0(header, collapse = "\".\""), "\";\n"
    )
    veg_obj$header <- dbGetQuery(conn, Query)
  } else {
    if (!missing(sql_header)) {
      if (!missing(geometry)) {
        warning("Argument in parameter 'geometry' will be ignored!")
      }
      veg_obj$header <- dbGetQuery(conn, sql_header)
    } else {
      Query <- paste0(
        "SELECT *\n",
        "FROM information_schema.columns\n",
        "WHERE table_schema = '", header[1], "'\n",
        "AND table_name = '", header[2], "';\n"
      )
      header_cols <- dbGetQuery(conn, Query)$column_name
      # Import with geometry
      Query <- paste0(
        "SELECT \"",
        paste0(header_cols[header_cols != geometry],
          collapse = "\",\""
        ),
        "\",ST_X(\"", geometry, "\") longitude,ST_Y(\"", geometry,
        "\") latitude\n",
        "FROM \"", paste(header, collapse = "\".\""), "\";\n"
      )
      veg_obj$header <- dbGetQuery(conn, Query)
    }
  }
  # samples
  Query <- paste0(
    "SELECT *\n",
    "FROM \"", paste(samples, collapse = "\".\""), "\"\n",
    "WHERE releve_id IN (", paste0(veg_obj$header$releve_id,
      collapse = ","
    ), ");\n"
  )
  veg_obj$samples <- dbGetQuery(conn, Query)
  # layers
  if (!missing(layers)) {
    veg_obj$layers <- list()
    for (i in names(layers)) {
      Query <- paste0(
        "SELECT *\n",
        "FROM \"", paste(layers[[i]], collapse = "\".\""), "\";\n"
      )
      veg_obj$layers[[i]] <- dbGetQuery(conn, Query)
    }
  }
  # relations
  if (!missing(relations)) {
    veg_obj$relations <- list()
    for (i in names(relations)) {
      Query <- paste0(
        "SELECT *\n",
        "FROM \"", paste(relations[[i]], collapse = "\".\""),
        "\";\n"
      )
      veg_obj$relations[[i]] <- dbGetQuery(conn, Query)
    }
  }
  # coverconvert
  if (!missing(coverconvert)) {
    veg_obj$coverconvert <- new("coverconvert")
    for (i in names(coverconvert)) {
      Query <- paste0(
        "SELECT *\n",
        "FROM \"", paste(coverconvert[[i]], collapse = "\".\""),
        "\";\n"
      )
      cover_tab <- dbGetQuery(conn, Query)
      veg_obj$coverconvert@value[[i]] <- with(
        cover_tab,
        factor(symbol, levels = symbol)
      )
      veg_obj$coverconvert@conversion[[i]] <- with(
        cover_tab,
        c(bottom[1], top)
      )
    }
  }
  # replace names
  colnames(veg_obj$header) <- replace_x(colnames(veg_obj$header),
    old = "releve_id", new = "ReleveID"
  )
  colnames(veg_obj$samples) <- replace_x(colnames(veg_obj$samples),
    old = c("releve_id", "taxon_usage_id"),
    new = c("ReleveID", "TaxonUsageID")
  )
  # final output
  message("DONE!\n")
  if (as_list) {
    invisible(veg_obj)
  } else {
    veg_obj <- new("vegtable",
      description = clean_strings(veg_obj$description),
      samples = veg_obj$samples,
      header = clean_strings(veg_obj$header),
      species = veg_obj$species,
      relations = veg_obj$relations,
      coverconvert = veg_obj$coverconvert
    )
    return(veg_obj)
  }
}

#' @rdname db2vegtable
#'
#' @aliases import_swea
#'
#' @export
import_swea <- function(conn,
                        header = c("swea_dataveg", "header"),
                        samples = c("swea_dataveg", "samples"),
                        relations = list(
                          globe_plots = c("swea_dataveg", "globe_plots"),
                          swea1_code = c("swea_dataveg", "swea1_code"),
                          soil_moisture = c("swea_dataveg", "soil_moisture"),
                          soil_texture = c("swea_dataveg", "soil_texture"),
                          community_type = c("commons", "community_type"),
                          naturalness = c("swea_dataveg", "naturalness"),
                          record_type = c("swea_dataveg", "record_type")
                        ),
                        layers = list(
                          veg_layer = c("swea_dataveg", "veg_layer"),
                          spec_miguel = c("specimens", "specimens_miguel")
                        ),
                        coverconvert = list(
                          br_bl = c("coverconvert", "br_bl"),
                          b_bbds = c("coverconvert", "b_bbds"),
                          ordinal = c("coverconvert", "ordinal")
                        ),
                        geometry = "plot_centroid",
                        get_countries = TRUE,
                        get_data_sources = TRUE,
                        bib_args = list(),
                        taxon_names = c("tax_commons", "taxon_names"),
                        taxon_relations = c("swea_dataveg", "taxon_concepts"),
                        taxon_traits = c("swea_dataveg", "taxon_attributes"),
                        taxon_views = c("bib_references", "main_table"),
                        taxon_levels = c("tax_commons", "taxon_levels"),
                        names2concepts = c("swea_dataveg", "names2concepts"),
                        ...) {
  # Final object
  message("Importing vegtable body...")
  suppressMessages(veg_obj <- db2vegtable(
    conn = conn, header = header,
    samples = samples, relations = relations, layers = layers,
    coverconvert = coverconvert, geometry = geometry,
    taxon_names = taxon_names,
    taxon_relations = taxon_relations,
    taxon_traits = taxon_traits, taxon_views = taxon_views,
    taxon_levels = taxon_levels,
    names2concepts = names2concepts, ...
  ))
  # Adding Country codes
  message("Importing country codes...")
  if (get_countries) {
    Query <- paste0(
      "SELECT releve_id,adm0_a3\n",
      "FROM \"", paste0(header, collapse = "\".\""),
      "\",commons.countries_map\n",
      "WHERE ST_Intersects(commons.countries_map.unit,\"",
      paste0(header, collapse = "\".\""), "\".plot_centroid);\n"
    )
    Countries <- dbGetQuery(conn, Query)
    veg_obj@header$country_code <- with(
      Countries,
      adm0_a3[match(veg_obj@header$ReleveID, releve_id)]
    )
    Countries <- dbGetQuery(conn, "SELECT * FROM commons.countries;")
    colnames(Countries) <- c(
      "country_code", "name_short", "name_long",
      "population", "sov_code_1", "sov_code_2", "sov_state", "continent"
    )
    veg_obj@relations$country_code <- Countries
  }
  # Adding Data sources
  message("Importing data sources...")
  if (get_data_sources) {
    data_source <- do.call(read_pg, c(
      conn = conn, name = "bib_references",
      bib_args
    ))
    data_source <- data_source[data_source$bibtexkey %in%
      veg_obj$bibtexkey, ]
    data_source$data_source <- seq_along(data_source$bibtexkey)
    veg_obj$data_source <- with(
      veg_obj@header,
      data_source$data_source[match(
        bibtexkey,
        data_source$bibtexkey
      )]
    )
    # Delete bibtexkey from header
    veg_obj@header <- veg_obj@header[, colnames(veg_obj@header) !=
      "bibtexkey"]
    # Delete empty columns
    data_source <- data_source[, apply(
      data_source, 2,
      function(x) !all(is.na(x))
    )]
    # Insert to relations
    veg_obj@relations$data_source <- data_source[, c(
      "data_source",
      colnames(data_source)[colnames(data_source) !=
        "data_source"]
    )]
  }
  message("DONE!\n")
  return(veg_obj)
}

#' @rdname db2vegtable
#'
#' @aliases import_sam
#'
#' @export
import_sam <- function(conn,
                       header = c("sudamerica", "header"),
                       samples = c("sudamerica", "samples"),
                       relations = list(
                         community_type = c("commons", "community_type")
                       ),
                       layers = list(
                         spec_miguel = c("specimens", "specimens_miguel")
                       ),
                       coverconvert = list(
                         br_bl = c("coverconvert", "br_bl"),
                         b_bbds = c("coverconvert", "b_bbds"),
                         ordinal = c("coverconvert", "ordinal")
                       ),
                       geometry = "plot_centroid",
                       get_countries = TRUE,
                       get_data_sources = TRUE,
                       bib_args = list(),
                       taxon_names = c("tax_commons", "taxon_names"),
                       taxon_relations = c("sudamerica", "taxon_concepts"),
                       taxon_traits = c("sudamerica", "taxon_attributes"),
                       taxon_views = c("bib_references", "main_table"),
                       taxon_levels = c("tax_commons", "taxon_levels"),
                       names2concepts = c("sudamerica", "names2concepts"),
                       ...) {
  # Final object
  veg_obj <- import_swea(
    conn = conn, header = header, samples = samples,
    relations = relations, layers = layers,
    coverconvert = coverconvert, geometry = geometry,
    taxon_names = taxon_names,
    taxon_relations = taxon_relations,
    taxon_traits = taxon_traits, taxon_views = taxon_views,
    taxon_levels = taxon_levels,
    names2concepts = names2concepts, get_countries = get_countries,
    get_data_sources = get_data_sources, bib_args = bib_args, ...
  )
}

#' @rdname db2vegtable
#'
#' @aliases import_bernice
#'
#' @export
import_bernice <- function(conn,
                           description = c(
                             Title = "Parthenium survey in Lake Baringo",
                             Author = "Bernice Mereina Sainepo",
                             Source = "SWEA-Dataveg (GIVD-AF-00-006)",
                             Version = Sys.Date()
                           ),
                           head_cols = c(
                             "releve_id", "code_trr228", "original_number",
                             "record_date", "plot_size", "data_source",
                             "elevation"
                           ),
                           samples_cols = c(
                             "record_id", "releve_id", "quadrant",
                             "taxon_usage_id", "misspelled_name",
                             "cover_percentage", "frequency"
                           ),
                           ...) {
  # header
  sql_header <- paste0(
    "SELECT \"", paste(head_cols, collapse = "\", \""),
    "\", ST_X(plot_centroid) longitude, ST_Y(plot_centroid) latitude\n",
    "FROM swea_dataveg.header\n", "WHERE data_source  =  98;\n"
  )
  veg_obj <- import_swea(
    conn = conn, description = description,
    sql_header = sql_header, ...
  )
  veg_obj@samples <- veg_obj@samples[, colnames(veg_obj@samples) %in%
    samples_cols]
  return(veg_obj)
}