R/pgMakePts.R

In mablab/rpostgis: R Interface to a 'PostGIS' Database

## pgMakePts

##' Add a POINT or LINESTRING geometry field.
##'
##' Add a new POINT or LINESTRING geometry field.
##'
##' @param conn A connection object.
##' @param name A character string specifying a PostgreSQL schema and
##'     table name (e.g., `name = c("schema","table")`)
##' @param colname A character string specifying the name of the new
##'     geometry column.
##' @param x The name of the x/longitude field.
##' @param y The name of the y/latitude field.
##' @param srid A valid SRID for the new geometry.
##' @param index Logical. Whether to create an index on the new
##'     geometry.
##' @param display Logical. Whether to display the query (defaults to
##'     `TRUE`).
##' @param exec Logical. Whether to execute the query (defaults to
##'     `TRUE`).
##' @return If `exec = TRUE`, returns `TRUE` if the geometry
##'     field was successfully created.
##' @seealso The PostGIS documentation for `ST_MakePoint`:
##'     <http://postgis.net/docs/ST_MakePoint.html>, and for
##'     `ST_MakeLine`:
##'     <http://postgis.net/docs/ST_MakeLine.html>, which are the
##'     main functions of the call.
##' @author Mathieu Basille \email{mathieu@@basille.org} and Adrián Cidre
##' González \email{adrian.cidre@@gmail.com}
##' @export
##' @examples
##' ## Examples use a dummy connection from DBI package
##' conn <- DBI::ANSI()
##'
##' ## Create a new POINT field called 'pts_geom'
##' pgMakePts(conn, name = c("schema", "table"), colname = "pts_geom",
##'     x = "longitude", y = "latitude", srid = 4326, exec = FALSE)

pgMakePts <- function(conn, name, colname = "geom", x = "x",
    y = "y", srid, index = TRUE, display = TRUE, exec = TRUE) {
    ## Check if PostGIS installed (in case of 'exec = TRUE')
    if (exec) {
        dbConnCheck(conn)
        if (!suppressMessages(pgPostGIS(conn))) {
            cli::cli_abort("PostGIS is not enabled on this database.")
        }
    }
    ## Check and prepare the schema.table name
    nameque <- paste(dbTableNameFix(conn,name), collapse = ".")
    ## Prepare column names
    colnameque <- DBI::dbQuoteIdentifier(conn, colname)
    x <- DBI::dbQuoteIdentifier(conn, x)
    y <- DBI::dbQuoteIdentifier(conn, y)
    ## Stop if no SRID
    if (missing(srid))
        cli::cli_abort("A valid SRID should be provided.")
    ## SQL query to add the POINT geometry column
    ## --
    ## ALTER TABLE "<schema>"."<table>" ADD COLUMN "<colname>" geometry(POINT, <srid>);
    ## --
    tmp.query <- paste0("ALTER TABLE ", nameque, " ADD COLUMN ",
        colnameque, " geometry(POINT, ", srid, ");")
    ## Display the query
    if (display) {
        message(paste0("Query ", ifelse(exec, "", "not "), "executed:"))
        message(tmp.query)
        #message("--")
    }
    ## Execute the query
    if (exec)
        dbSendQuery(conn, tmp.query)
    ## Create an index
    if (index) {
        ## The name of the index is enforced
        idxname <- paste(name[length(name)], colname, "idx",
            sep = "_")
        ## SQL query to create the index
        ## --
        ## CREATE INDEX "<table>_<colname>_idx" ON "<schema>"."<table>" USING GIST ("<colname>");
        ## --
        dbIndex(conn = conn, name = name, colname = colnameque,
            idxname = idxname, method = "gist", display = display,
            exec = exec)
    }
    ## SQL query to populate the POINT geometry field
    ## --
    ## UPDATE "<schema>"."<table>"
    ## SET "<colname>" = ST_SetSRID(ST_MakePoint("<x>", "<y>"), <srid>)
    ## WHERE "<x>" IS NOT NULL AND "<y>" IS NOT NULL;
    ## --
    tmp.query <- paste0("UPDATE ", nameque, "\nSET ", colnameque,
        " = ST_SetSRID(ST_MakePoint(", x, ", ", y, "), ", srid,
        ")\nWHERE ", x, " IS NOT NULL AND ", y, " IS NOT NULL;")
    ## Display the query
    if (display) cli::cli_alert_info(tmp.query)
    ## Execute the query
    if (exec) {
        dbSendQuery(conn, tmp.query)
        ## Return TRUE
        cli::cli_alert_success("Query executed")
        return(invisible(TRUE))
    } else {
        cli::cli_alert_danger("Query not executed")
    }
}


## pgMakeStp

##' @rdname pgMakePts
##' @param dx The name of the dx field (i.e. increment in x
##'     direction).
##' @param dy The name of the dy field (i.e. increment in y
##'     direction).
##' @importFrom DBI dbQuoteIdentifier
##' @export
##' @examples
##'
##' ## Create a new LINESTRING field called 'stp_geom'
##' pgMakeStp(conn, name = c("schema", "table"), colname = "stp_geom",
##'     x = "longitude", y = "latitude", dx = "xdiff", dy = "ydiff",
##'     srid = 4326, exec = FALSE)

pgMakeStp <- function(conn, name, colname = "geom", x = "x",
    y = "y", dx = "dx", dy = "dy", srid, index = TRUE, display = TRUE,
    exec = TRUE) {
    if (exec) {
        dbConnCheck(conn)
        if (!suppressMessages(pgPostGIS(conn))) {
            cli::cli_abort("PostGIS is not enabled on this database.")
        }
    }
    ## Check and prepare the schema.table name
    nameque <- paste(dbTableNameFix(conn,name), collapse = ".")
    ## Prepare column names
    colnameque <- DBI::dbQuoteIdentifier(conn, colname)
    x <- DBI::dbQuoteIdentifier(conn, x)
    y <- DBI::dbQuoteIdentifier(conn, y)
    dx <- DBI::dbQuoteIdentifier(conn, dx)
    dy <- DBI::dbQuoteIdentifier(conn, dy)
    ## Stop if no SRID
    if (missing(srid))
        cli::cli_abort("A valid SRID should be provided.")
    ## SQL query to add the LINESTRING geometry column
    ## --
    ## ALTER TABLE "<schema>"."<table>" ADD COLUMN "<colname>" geometry(LINESTRING, <srid>);
    ## --
    tmp.query <- paste0("ALTER TABLE ", nameque, " ADD COLUMN ",
        colnameque, " geometry(LINESTRING, ", srid, ");")
    ## Display the query
    if (display) {
        cli::cli_alert_info(tmp.query)
    }
    ## Execute the query
    if (exec)
        dbSendQuery(conn, tmp.query)
    ## Create an index
    if (index) {
        ## The name of the index is enforced
        idxname <- paste(name[length(name)], colname, "idx",
            sep = "_")
        ## SQL query to create the index
        ## --
        ## CREATE INDEX "<table>_<colname>_idx" ON "<schema>"."<table>" USING GIST ("<colname>");
        ## --
        dbIndex(conn = conn, name = name, colname = colnameque,
            idxname = idxname, method = "gist", display = display,
            exec = exec)
    }
    ## SQL query to populate the LINESTRING geometry field
    ## --
    ## UPDATE "<schema>"."<table>"
    ## SET "<colname>" = ST_SetSRID(ST_MakeLine(
    ##     ARRAY[ST_MakePoint("<x>", "<y>"),
    ##           ST_MakePoint("<x>" + "<dx>", "<y>" + "<dy>")]
    ##     ), <srid>)
    ## WHERE "<x>" IS NOT NULL AND "<y>" IS NOT NULL;
    ## --
    tmp.query <- paste0("UPDATE ", nameque, "\nSET ", colnameque,
        " = ST_SetSRID(ST_MakeLine(\n    ARRAY[ST_MakePoint(",
        x, ", ", y, "), ", "\n          ST_MakePoint(", x, " + ",
        dx, ", ", y, " + ", dy, ")]\n    ), ", srid, ")\nWHERE ",
        dx, " IS NOT NULL AND ", dy, " IS NOT NULL;")
    ## Display the query
    if (display) {
        cli::cli_alert_info(tmp.query)
    }
    ## Execute the query
    if (exec) {
        dbSendQuery(conn, tmp.query)
        ## Return TRUE
        cli::cli_alert_success("Query executed")
        return(invisible(TRUE))
    } else {
        cli::cli_alert_danger("Query not executed")
    }
}