# ltraj2pgtraj
#' Export ltraj object from R to a PostGIS database.
#'
#' \code{ltraj2pgtraj} exports an ltraj to the a database pgtraj,
#' creating a new pgtraj schema if it doesn't exist. The time zone and
#' projection information stored in the ltraj is transferred to the
#' database.
#'
#' @param conn A connection object.
#' @param ltraj An object of class \code{ltraj}.
#' @param schema Character. Name of the schema that stores or will
#' store the pgtraj data model.
#' @param pgtraj Character. Name of the new \code{pgtraj}. Defaults
#' to the name of the provided \code{ltraj}.
#' @param note Character. A note that will be stored with the
#' \code{pgtraj} in the database.
#' @param overwrite Logical. Use if a \code{pgtraj} with the same
#' name as the provided \code{ltraj} already exists in the
#' database: If \code{TRUE}, the existing \code{pgtraj} is
#' deleted and the provided \code{ltraj} is inserted. If
#' \code{FALSE}, the function exits. Note that \code{overwrite}
#' requires an exact match among the \code{pgtraj} names
#' otherwise it is ignored.
#' @param infolocs Logical. Whether to write infolocs to database.
#' @return \code{TRUE} on success.
#' @seealso \code{\link{asPgtraj}} to create a \code{pgtraj} with
#' data already stored in the database.
#' @aliases writeTraj
#' @author Balázs Dukai \email{balazs.dukai@@gmail.com}
#' @export
#' @examples
#' \dontrun{
#' # create pgtraj from ltraj "ibex" in schema "traj_t2"
#' ltraj2pgtraj(conn, ibex, "traj_t2")
#' }
ltraj2pgtraj <-
function(conn,
ltraj,
schema = "traj",
pgtraj = NULL,
note = NULL,
overwrite = FALSE,
infolocs = TRUE) {
## check PostgreSQL connection and PostGIS
dbConnCheck(conn)
if (!suppressMessages(pgPostGIS(conn))) {
stop("PostGIS is not enabled on this database.")
}
## 'pgtraj' defaults to the name of ltraj
if (is_blank(pgtraj)) {
pgtraj <- deparse(substitute(ltraj))
}
## only allow pgtraj names that begin with letters or numbers
if (!grepl("^[0-9A-Za-z]", pgtraj)) {
stop("Invalid pgtraj name. Valid pgtraj names must begin with a letter or number.")
}
## Check/create pgtraj schema ('pgtrajSchema' has its own
## transaction control)
x <- pgtrajSchema(conn, schema)
## If schema creation unsuccessful
if (!isTRUE(x)) {
stop("Traj schema couldn't be created, returning from function.")
}
## Checks if 'pgtraj' already exists
sql_query <-
paste0("SELECT pgtraj_name FROM ",
dbQuoteIdentifier(conn,
schema),
".pgtraj;")
pgt <- dbGetQuery(conn, sql_query)
if (pgtraj %in% pgt$pgtraj_name) {
## If 'overwrite', drop 'pgtraj', else stop
if (overwrite) {
pgtrajDrop(conn, pgtraj, schema, full_clean = FALSE)
} else {
stop(
paste0(
"The pgtraj '",
pgtraj,
"' already exists in the schema '",
schema,
"'"
)
)
}
}
## Otherwise the column 'note' won't be appended to 'dframe'
## below
if (is_blank(note)) {
note <- NA
}
## Set projection
srs <- attr(ltraj, "proj4string")
if (is.null(srs)) {
srid <- 0
srs <-
NA # not sure this is necessary with updated adehabitatLT (0.3.21)
} else {
srid <- suppressMessages(pgSRID(
conn = conn,
crs = srs,
create.srid = TRUE,
new.srid = NULL
))
srs <- srs@projargs
}
## Get time zone
time_zone <- attr(ltraj[[1]]$date, "tzone")
if (is_blank(time_zone)) {
time_zone <- NA
}
## Convert ltraj to data frame
dframe <- ld_opt(ltraj)
## Get time zone, srs, proj4string, note, pgtraj
dframe$.time_zone <- time_zone
dframe$.srid <- srid
dframe$.proj4string <- srs
dframe$.pgtraj <- pgtraj
dframe$.note <- note
dframe$.burst_order <-
as.integer(ordered(dframe$burst, burst(ltraj)))
## Format date to include time zone that Postgres recognizes, or exclude
## 'date' column if the ltraj is of Type I
type <- attr(ltraj, "typeII") # TRUE if Type II
if (type) {
dframe$date <- sapply(dframe$date, function(x)
strftime(
x,
format = "%Y-%m-%d %H:%M:%S",
tz = "",
usetz = TRUE
))
} else {
dframe$date <- NA
dframe$dt <- NA
# TODO: workaround in ltraj_insert.sql
# It would be more elegant to exclude these columns from the temporary
# table since the beginning, but the current import procedure in
# 'insert_ltraj.sql' does not support that. One potential solution
# that I found is to use the CASE conditional to check if the 'date'
# column exists in the temporary table and if so insert its value,
# else insert NULL. However, CASE cannot check for non-existing
# columns...So a workaround could be build along these answers:
# http://dba.stackexchange.com/questions/66741/why-cant-i-use-a-case-statement-to-see-if-a-column-exists-and-not-select-from-i
# http://stackoverflow.com/questions/11472790/postgres-analogue-to-cross-apply-in-sql-server#35873193
}
## Parameters to exclude on input
params <- c("dist", "abs.angle")
## Begin transaction block and input to postgres
invisible(dbExecute(conn, "BEGIN TRANSACTION;"))
## Set database search path
current_search_path <- dbGetQuery(conn, "SHOW search_path;")
sql_query <-
paste0("SET search_path TO ",
dbQuoteIdentifier(conn,
schema),
",public;")
invisible(dbExecute(conn, sql_query))
## Import data frame into a temporary table
res <- tryCatch({
invisible(dbWriteTable(
conn,
name = "zgaqtsn_temp",
value = dframe[,-which(names(dframe) %in% params)],
row.names = FALSE
))
TRUE
}, warning = function(x) {
message(x)
message(". Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
}, error = function(x) {
message(x)
message(". Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
})
## Run the SQL import script to insert the data from the
## temporary table into the traj schema
res2 <- tryCatch({
pgtraj_insert_file <- system.file("sql/insert_ltraj.sql", package = "rpostgisLT")
pif <- readLines(pgtraj_insert_file, encoding = "UTF-8")
pif[pif == ""] <- "%SPLITHERE%"
pif <- paste(pif, collapse = "\n")
sql_query <- unlist(strsplit(pif, "%SPLITHERE%", fixed = TRUE))
for (sq in sql_query) {
invisible(dbExecute(conn, sq))
}
TRUE
}, warning = function(x) {
message(x)
message(" . Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
}, error = function(x) {
message(x)
message(". Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
})
res <- c(res, res2)
## Drop temporary table
invisible(dbExecute(conn, "DROP TABLE zgaqtsn_temp;"))
## Create parameter and geometry views
res3 <- tryCatch({
pgTrajViewParams(conn, schema, pgtraj, srid, db = FALSE)
## TODO create view if doesn't exist
pgTrajViewStepGeom(conn, schema, pgtraj)
}, warning = function(x) {
message(x)
message(" . Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
}, error = function(x) {
message(x)
message(" . Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
})
res <- c(res, res3)
## Commit transaction and restore search path
tryCatch({
if (all(res)) {
dbCommit(conn)
message(
paste0(
"The ltraj '",
pgtraj,
"' has been successfully inserted into the database schema '",
schema,
"'."
)
)
## Vacuum the tables
suppressMessages(pgtrajVacuum(conn, schema))
## infolocs writing
if (infolocs) {
info <- NULL
try(info <- writeInfoFromLtraj(conn, ltraj, pgtraj,
schema))
if (is.null(info))
message("Infolocs writing for pgtraj '",
pgtraj,
"' failed.")
}
## Restore database search path
sql_query <-
paste0("SET search_path TO ", current_search_path,
";")
invisible(dbExecute(conn, sql_query))
return(TRUE)
} else {
dbRollback(conn)
stop("Ltraj insert failed.")
}
}, warning = function(x) {
message(x)
message(" . Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
}, error = function(x) {
message(x)
message(". Rolling back transaction")
dbRollback(conn)
stop("Returning from function")
})
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.