R/data_access.R

In MalditoBarbudo/tidyNFI: Tidy access to the National Forest Inventory data for Catalonia

#' Creating a connection to the NFI SQL database
#'
#' Wrapper of \code{\link{dbPool}} to connect to the NFI database
#'
#' By default (no arguments supplied) it allows to access as a guest to the
#' database
#'
#' @param user character with database user, default to "guest"
#' @param password character woth the user password, default to "guest"
#' @param dbname character with the database address
#' @param idleTimeout Idle time in seconds before the connection expires
#'
#' @importFrom magrittr %>%
#'
#' @export
nfi_connect <- function(
  user = 'guest',
  password = 'guest',
  dbname = 'tururu',
  idleTimeout = 3600000,
  host = NULL,
  port = NULL
) {
  db_conn <- pool::dbPool(
    drv = RPostgreSQL::PostgreSQL(),
    user = user,
    password = password,
    dbname = dbname,
    idleTimeout = idleTimeout,
    host = host,
    port = port
  )

  return(db_conn)
}

#' Closing connection to the NFI SQL database
#'
#' Wrapper of \code{\link{poolClose}} to close the connection
#'
#' @param conn connection object as generated by \code{\link{nfi_connect}}
#'
#' @export
nfi_close <- function(
  conn
) {
  pool::poolClose(conn)
}

#' Retrieve NFI data as tbl
#'
#' Get the results data by plot (with or without breakdown)
#'
#' Data is retrieved from the postgreSQL db in tbl form
#'
#' @section Functional groups:
#' \code{functional_group} parameter allows to retrieve the table of plots
#'   broken down by the desired group. Allowed values are:
#'   \itemize{
#'     \item{\code{"none"} (No breakdown)}
#'     \item{\code{"species"}}
#'     \item{\code{"simpspecies"}}
#'     \item{\code{"genus"}}
#'     \item{\code{"dec"} (Deciduous/Esclerophyllous/Conifer)}
#'     \item{\code{"bc"} (Broadleaf/Conifer)}
#'   }
#'
#' @param conn pool object to access the tables, as obtained from
#'   \code{\link{nfi_connect}}
#' @param nfi character indicating the nfi version
#' @param functional_group Functional group to retrieve table for,
#'   Default to 'none' (no functional group). See details for more information
#' @param diameter_classes logical indicating if diameter classes are required
#'   (breaking down the table by diameter classes). Default to FALSE.
#' @param .collect Logical indicating if the tbl must be collected locally.
#'   Default to TRUE
#'
#' @export
nfi_results_data <- function(
  conn,
  nfi = c(
    'nfi_2', 'nfi_3', 'nfi_4',
    'nfi_2_nfi_3', 'nfi_3_nfi_4',
    'nfi_2_shrub', 'nfi_3_shrub', 'nfi_4_shrub',
    'nfi_2_regen', 'nfi_3_regen', 'nfi_4_regen'
  ),
  functional_group = "none",
  diameter_classes = FALSE,
  .collect = TRUE
) {

  # nfi version
  nfi <- switch(
    nfi,
    nfi_2 = 'NFI_2',
    nfi_3 = 'NFI_3',
    nfi_4 = 'NFI_4',
    nfi_2_nfi_3 = 'COMP_NFI2_NFI3',
    nfi_3_nfi_4 = 'COMP_NFI3_NFI4',
    nfi_2_shrub = 'SHRUB_NFI_2_INFO',
    nfi_3_shrub = 'SHRUB_NFI_3_INFO',
    nfi_4_shrub = 'SHRUB_NFI_4_INFO',
    nfi_2_regen = 'REGENERATION_NFI_2',
    nfi_3_regen = 'REGENERATION_NFI_3',
    nfi_4_regen = 'REGENERATION_NFI_4'
  )

  # shrub and regeneration are independent of anything else
  if (nfi %in% c(
    'SHRUB_NFI_2_INFO', 'SHRUB_NFI_3_INFO', 'SHRUB_NFI_4_INFO',
    'REGENERATION_NFI_2', 'REGENERATION_NFI_3', 'REGENERATION_NFI_4'
  )) {
    table_name <- nfi
    res <- dplyr::tbl(conn, table_name)
  } else {
    # the other tables follows the natural way (diam classes, functional group...)
    # diameter classes switch
    if (isTRUE(diameter_classes)) {
      dc <- 'DIAMCLASS_'
    } else {
      dc <- ''
    }

    # functional group
    functional_group <- switch(
      functional_group,
      none = 'PLOT',
      species = 'SPECIES',
      simpspecies = 'SIMPSPECIES',
      genus = 'GENUS',
      dec = 'DEC',
      bc = 'BC',
      plot = 'PLOT'
    )

    # table name
    table_name <- glue::glue(
      "{functional_group}_{nfi}_{dc}RESULTS"
    )

    res <- dplyr::tbl(conn, table_name)# %>%
    # dplyr::left_join(
    #   dplyr::tbl(conn, 'PLOTS') %>%
    #     dplyr::select(plot_id, dplyr::starts_with('admin_'))
    # )
  }

  # collect?
  if (isTRUE(.collect)) {
    res <- res %>% dplyr::collect()
  }

  # attribute settings
  attr(res, 'nfi') <- nfi
  # attr(res, 'diamclass') <- diameter_classes

  return(res)

}