Nothing
# ld_opt
#' Quick Conversion of Objects of Class ltraj from and to data frames
#'
#' Faster versions of \code{\link[adehabitatLT]{ld}} and
#' \code{\link[adehabitatLT]{dl}}.
#'
#' @param ltraj An object of class \code{ltraj}.
#' @param x A data frame
#' @param rnames Whether to preserve row names from the data frame to the
#' ltraj
#' @return \code{ld_opt} returns a data frame with all trajectory
#' parameters as columns; \code{dl_opt} returns an object of class
#' \code{ltraj}.
#' @keywords internal
#' @seealso See \code{\link[adehabitatLT]{ld}} for further details on the
#' function and all available arguments.
#' @author Modified by Mathieu Basille \email{basille@@ufl.edu},
#' Balázs Dukai \email{balazs.dukai@@gmail.com}
ld_opt <- function(ltraj) {
if (!inherits(ltraj, "ltraj"))
stop("ltraj should be of class ltraj")
## Equivalent of hab::ld(strict = FALSE)
df <- data.frame(
x = unlist(lapply(ltraj, function(x) x$x)),
y = unlist(lapply(ltraj, function(x) x$y)),
date = unlist(lapply(ltraj, function(x) x$date)),
dx = unlist(lapply(ltraj, function(x) x$dx)),
dy = unlist(lapply(ltraj, function(x) x$dy)),
dist = unlist(lapply(ltraj, function(x) x$dist)),
dt = unlist(lapply(ltraj, function(x) x$dt)),
R2n = unlist(lapply(ltraj, function(x) x$R2n)),
abs.angle = unlist(lapply(ltraj, function(x) x$abs.angle)),
rel.angle = unlist(lapply(ltraj, function(x) x$rel.angle)),
id = rep(id(ltraj), sapply(ltraj, nrow)),
burst = rep(burst(ltraj), sapply(ltraj, nrow)),
r.row.names = unlist(lapply(ltraj, function(x) rownames(x)))
)
# set date column to POSIX with tz
class(df$date) <- c("POSIXct", "POSIXt")
attr(df$date, "tzone") <- attr(ltraj[[1]]$date, "tzone")
# infolocs handled in separate function
return(df)
}
# dl
#' @rdname ld_opt
dl_opt <- function(x, rnames = TRUE) {
if (!inherits(x, "data.frame"))
stop("x should be of class data.frame")
## Equivalent of hab::dl(strict = FALSE)
trajnam <- c("x", "y", "date", "dx", "dy", "dist", "dt",
"R2n", "abs.angle", "rel.angle")
## Check if type I/II
if (class(x$date)[1] == "integer") {
type2<-FALSE
} else {
type2<-TRUE
}
## Order bursts by table order
x$burst<- factor(x$burst, levels=unique(x$burst))
idd <- tapply(as.character(x$id), x$burst, unique)
traj <- split(x[, names(x) %in% trajnam], x$burst)
## + Split row names by burst
## infolocs handled in seperate function
if (rnames) {
traj_rname <- split(x[, "r.row.names"], x$burst)
names(traj) <- NULL
class(traj) <- c("ltraj", "list")
attr(traj, "typeII") <- type2
attr(traj, "regular") <- is.regular(traj)
for (i in (1:length(traj))) {
attr(traj[[i]], "id") <- as.character(idd[i])
attr(traj[[i]], "burst") <- names(idd[i])
## + Add r.row.names
rownames(traj[[i]]) <- traj_rname[[i]]
}
return(traj)
} else {
names(traj) <- NULL
class(traj) <- c("ltraj", "list")
attr(traj, "typeII") <- type2
attr(traj, "regular") <- is.regular(traj)
for (i in (1:length(traj))) {
attr(traj[[i]], "id") <- as.character(idd[i])
attr(traj[[i]], "burst") <- names(idd[i])
attr(traj[[i]], "row.names") <- rownames(traj[[i]])
}
return(traj)
}
}
# pgTrajDB2TempT
#' Insert relocations from a source table into the table 'zgaqtsn_temp',
#' used in asPgtraj
#'
#' If relocations are given as X,Y coordinates, they are converted into
#' a POINT geometry in PostGIS.
#'
#' @param conn Connection object created with RPostgreSQL
#' @param schema String. Name of the schema that stores or will store
#' the pgtraj data model.
#' @param relocations_table String. Name of the table that stores the
#' relocations, e.g. c("schema","relocations")
#' @param pgtrajs String. Name of the pgtraj or name of the field that
#' stores the pgtraj names.
#' @param animals String. Name of the animal or name of the field that
#' stores the animal names.
#' @param bursts String. Name of the burst or name of the field that
#' stores the burst names.
#' @param timestamps String. Name of the field in relocations_table
#' that contains the timestamps.
#' @param rids String. Name of the field in relocations_table that
#' contains the numeric IDs of relocations.
#' @param relocations Vector of string(s). Name of the field(s) that
#' contains the relocations in relocations_table. If relocations are
#' stored as pairs of (X,Y) or (long, lat) coordinates, the coordinates
#' should be separated in two fields and referenced accordingly.
#' @param srid Numeric. The PostGIS SRID of the CRS of 'relocations'.
#' @param proj4string String. The PROJ4 string to be inserted into
#' \code{pgtraj} table.
#' @param note String. Comment on the pgtraj. The comment is only used
#' in the database and not transferred into an ltraj.
#' @param clauses String. Additional SQL to modify select query from
#' relocations_table
#' @param time_zone String. Time zone to be inserted into \code{pgtraj}
#' table.
#'
#' @author Balázs Dukai
#' @keywords internal
pgTrajDB2TempT <- function(conn, schema, relocations_table, pgtrajs, animals,
bursts = NULL, relocations, timestamps, rids, srid, proj4string,
note, clauses, time_zone) {
# check table name
relocations_table_q <- paste(dbTableNameFix(conn,relocations_table),
collapse = ".")
# sanitize schema, rids, relocations
schema_q <- dbQuoteIdentifier(conn,schema)
rids_q<- dbQuoteIdentifier(conn,rids)
relocations_q<- dbQuoteIdentifier(conn,relocations)
# Test for correct inputs
test_input(pgtrajs, animals, relocations, bursts)
# Set DB search path for the schema
current_search_path <- dbGetQuery(conn, "SHOW search_path;")
sql_query <- paste0("SET search_path TO ", schema_q, ",public;")
invisible(dbExecute(conn, sql_query))
# Populate 'zgaqtsn_temp'
# Insert relocations if trajectory Type I
if (is.null(timestamps)) {
# Relocations provided as point geometry
if (length(relocations) == 1) {
sql_query <- paste0("INSERT INTO zgaqtsn_temp (id, geom)
SELECT ",rids_q,",",relocations_q,"::geometry
FROM ",relocations_table_q," ",
clauses,
" ORDER BY ",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
t <- c(t, dbExecute(conn, sql_query))
} else if (length(relocations) == 2) {
# Relocations provided as a coordinate pair
x <- relocations_q[1]
y <- relocations_q[2]
sql_query <- paste0("INSERT INTO zgaqtsn_temp (id, geom)
SELECT ",rids_q,", ST_SetSRID(ST_MakePoint(",x,", ",y,"), ",srid,")
FROM ",relocations_table_q," ",
clauses,
" ORDER BY ",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
}
# If trajectory Type II
} else {
# sanitize timestamps
timestamps_q<-dbQuoteIdentifier(conn,timestamps)
if (length(relocations) == 1) {
# Relocations provided as point geometry
sql_query <- paste0("INSERT INTO zgaqtsn_temp (id, geom, relocation_time)
SELECT ",rids_q,",",relocations_q,"::geometry, ",timestamps_q,"
FROM ",relocations_table_q," ",
clauses,
" ORDER BY ",timestamps_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
} else if (length(relocations) == 2) {
# relocations provided as a coordinate pair
x <- relocations_q[1]
y <- relocations_q[2]
sql_query <- paste0("INSERT INTO zgaqtsn_temp (id, geom, relocation_time)
SELECT ",rids_q,", ST_SetSRID(ST_MakePoint(",x,", ",y,"), ",srid,"), ",timestamps_q,"
FROM ",relocations_table_q," ",
clauses,
" ORDER BY ",timestamps_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
}
}
# maybe analyze table here (to speed up updates)
fields <- dbTableInfo(conn, relocations_table)$column_name
# Insert pgtraj
# sanitize pgtraj
pgtrajs_q<-dbQuoteIdentifier(conn, pgtrajs)
if (pgtrajs %in% fields) {
# use the field values for pgtraj
sql_query <- paste0("UPDATE zgaqtsn_temp
SET pgtraj_name = a.",pgtrajs_q,"
FROM (
SELECT ",rids_q,", ",pgtrajs_q,"
FROM ",relocations_table_q," ", clauses,"
) a
WHERE zgaqtsn_temp.id = a.",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
} else {
# use the string
# only allow pgtraj names that begin with letters or numbers
if (!grepl("^[0-9A-Za-z]", pgtrajs)) {
stop("Invalid pgtraj name. Valid pgtraj names must begin with a letter or number.")
}
sql_query <- paste0("UPDATE zgaqtsn_temp SET pgtraj_name = ", dbQuoteString(conn,pgtrajs), ";")
invisible(dbExecute(conn, sql_query))
}
# Insert animal
# sanitizes animals
animals_q<-dbQuoteIdentifier(conn,animals)
if (animals %in% fields) {
# Use the field values for animal
sql_query <- paste0("UPDATE zgaqtsn_temp
SET animal_name = a.",animals_q,"
FROM (
SELECT ",rids_q,", ",animals_q,"
FROM ",relocations_table_q," ", clauses,"
) a
WHERE zgaqtsn_temp.id = a.",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
} else {
# Use the string
sql_query <- paste("UPDATE zgaqtsn_temp SET animal_name = ",dbQuoteString(conn,animals), ";")
invisible(dbExecute(conn, sql_query))
}
# Insert burst
if (is_blank(bursts) & (animals %in% fields)) {
# Use animal name as default burst name
sql_query <- paste0("UPDATE zgaqtsn_temp
SET burst_name = a.",animals_q,"
FROM (
SELECT ",rids_q,", ",animals_q,"
FROM ",relocations_table_q," ", clauses,"
) a
WHERE zgaqtsn_temp.id = a.",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
} else if (is_blank(bursts) & length(animals) == 1) {
sql_query <- paste0("UPDATE zgaqtsn_temp SET burst_name = ",dbQuoteString(conn,animals),";")
invisible(dbExecute(conn, sql_query))
} else if (bursts %in% fields) {
# sanitize bursts
bursts_q<-dbQuoteIdentifier(conn,bursts)
# Use the field values for bursts
sql_query <- paste0("UPDATE zgaqtsn_temp
SET burst_name = a.",bursts_q,"
FROM (
SELECT ",rids_q,", ",bursts_q,"
FROM ",relocations_table_q," ", clauses,"
) a
WHERE zgaqtsn_temp.id = a.",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
} else {
# Use the string
sql_query <- paste("UPDATE zgaqtsn_temp SET burst_name = ", dbQuoteString(conn,bursts), ";")
invisible(dbExecute(conn, sql_query))
}
# Insert note
if (is_blank(note)) {
# Set to NULL
sql_query <- paste0("UPDATE zgaqtsn_temp SET note = NULL;")
invisible(dbExecute(conn, sql_query))
} else if (note %in% fields) {
note_q<-dbQuoteIdentifier(conn,note)
# use the values for note
sql_query <- paste0("UPDATE zgaqtsn_temp
SET note = a.",note_q,"
FROM (
SELECT ",rids_q,", ",note_q,"
FROM ",relocations_table_q," ", clauses,"
) a
WHERE zgaqtsn_temp.id = a.",rids_q,";")
sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
invisible(dbExecute(conn, sql_query))
} else {
# Use the string
sql_query <- paste0("UPDATE zgaqtsn_temp SET note = ",dbQuoteString(conn,note),";")
invisible(dbExecute(conn, sql_query))
}
# Insert proj4string and time zone
if (!is_blank(proj4string)) {
sql_query <- paste0("UPDATE zgaqtsn_temp
SET proj4string = ",dbQuoteString(conn, proj4string),";")
invisible(dbExecute(conn, sql_query))
}
if (!is_blank(time_zone)) {
sql_query <- paste0("UPDATE zgaqtsn_temp
SET time_zone = ",dbQuoteString(conn, time_zone),";")
invisible(dbExecute(conn, sql_query))
}
# Reset DB search path to the public schema
sql_query <- paste0("SET search_path TO ", current_search_path, ";")
invisible(dbExecute(conn, sql_query))
return(TRUE)
}
# pgTrajTempT
#' Creates a temporary table in the 'traj' schema.
#'
#' @description
#' Used by \code{pgTrajDB2TempT} and \code{pgTrajR2TempT} to create a
#' temporary table which will be populated by these functions. The
#' temporary table's name is a random string to avoid collation with
#' user generated tables.
#'
#' @param conn Connection object created with RPostgreSQL
#' @param schema String. Name of the schema that stores or will store
#' the pgtraj data model
#'
#' @return TRUE on success, otherwise warning/error
#'
#' @author Balázs Dukai \email{balazs.dukai@@gmail.com}
#' @keywords internal
#'
#' @examples
#' \dontrun{pgTrajTempT(conn, "traj_1")}
pgTrajTempT <- function(conn, schema) {
# Check if table already exists
sql_query <- paste0("SELECT * FROM pg_tables WHERE schemaname = ", dbQuoteString(conn,schema), ";")
tables <- invisible(dbGetQuery(conn, sql_query))
if ('zgaqtsn_temp' %in% tables$tablename) {
acr <- NA
while(is.na(acr) | !(acr %in% "y" | acr %in% "n")) {
acr <- readline(paste("A table named 'zgaqtsn_temp' already exists in the schema", schema,
". Do you want to delete it? [y/n]"))
acr <- ifelse(grepl("y|n", acr), acr, as.character(acr))
}
if (acr %in% "n") {
return(FALSE)
} else {
sql_query <- paste0("DROP TABLE IF EXISTS ", dbQuoteIdentifier(conn,schema), ".zgaqtsn_temp;")
invisible(dbExecute(conn, sql_query))
}
}
# Create 'zgaqtsn_temp' table
sql_query <- paste0("CREATE TEMPORARY TABLE zgaqtsn_temp (
id serial,
pkey text,
geom geometry,
relocation_time timestamptz,
burst_name text,
animal_name text,
pgtraj_name text,
proj4string text,
time_zone text,
note text
) ON COMMIT DROP;")
create_sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
res <- tryCatch({
invisible(dbExecute(conn, create_sql_query))
return(TRUE)
}, warning = function(war) {
message("WARNING in creating the temporary table:")
message(war)
return(war)
}, error = function(err) {
message("ERROR in creating the temporary table:")
message(err)
return(err)
})
return(res)
}
# pgTrajViewParams
#' Computes the trajectory parameters (as in ltraj) for a pgtraj and
#' creates a view for the pgtraj. The views are always named as
#' 'parameters_<pgtraj_name>'.
#'
#' @author Balázs Dukai
#'
#' @param conn Connection object created with RPostgreSQL
#' @param schema String. Name of the schema that stores or will store the
#' pgtraj data model.
#' @param pgtraj String. Name of the pgtraj.
#' @param epsg Numeric. EPSG code of the relocation geometry.
#' @param db Boolean. A switch that controls the parameters view creation
#' depending on source of data (R or PostgreSQL). If TRUE, raw data input
#' from a database table is assumed. In this case all parameters will be
#' computed. If FALSE, it is assumed that an ltraj was input from R with
#' already computed parameters. In this case R2n and rel.angle will not
#' be recomputed, but reused from the ltraj.
#'
#' @return TRUE on success, otherwise warning/error
#'
#' @keywords internal
#'
pgTrajViewParams <- function(conn, schema, pgtraj, epsg, db = TRUE) {
current_search_path <- dbGetQuery(conn, "SHOW search_path;")
sql_query <- paste0("SET search_path TO ", dbQuoteIdentifier(conn,schema), ",public;")
invisible(dbExecute(conn, sql_query))
view <- dbQuoteIdentifier(conn,paste0("parameters_",pgtraj))
if (db) {
sql_query <- paste0(
"CREATE OR REPLACE VIEW ",view," AS
WITH step_geom AS (
SELECT
s.id AS step_id,
ST_Makeline(r1.geom, r2.geom) AS step_geom,
r1.relocation_time,
s.dt,
s.r_rowname,
r1.geom AS relocation1_geom,
r2.geom AS relocation2_geom,
ab.id as burst_order,
ab.burst_name,
ab.animal_name,
p.pgtraj_name,
ab.id AS ab_id
FROM step s
JOIN relocation r1 ON s.relocation_id_1 = r1.id
LEFT JOIN relocation r2 ON s.relocation_id_2 = r2.id
JOIN s_b_rel rel ON rel.step_id = s.id
JOIN animal_burst ab ON ab.id = rel.animal_burst_id
JOIN pgtraj p ON p.id = ab.pgtraj_id
WHERE p.pgtraj_name = ",dbQuoteString(conn,pgtraj),"
),
step_shape AS (
SELECT
t.step_id,
t.step_geom,
t.relocation_time,
t.dt,
t.r_rowname,
t.dx,
t.dy,
t.relocation1_geom,
t.relocation2_geom,
t.burst_name,
t.burst_order,
t.animal_name,
t.pgtraj_name,
t.ab_id,
t.dist,
CASE
WHEN t.dist < 1e-07 THEN NULL
WHEN t.dist >= 1e-07 THEN atan2(t.dy, t.dx)
END AS abs_angle
FROM (SELECT
step_id,
step_geom,
relocation_time,
dt,
r_rowname,
relocation1_geom,
relocation2_geom,
burst_name,
burst_order,
animal_name,
pgtraj_name,
ab_id,
ST_length(step_geom) AS dist,
ST_X(relocation2_geom) - ST_X(relocation1_geom) AS dx,
ST_Y(relocation2_geom) - ST_Y(relocation1_geom) AS dy
FROM step_geom
) AS t
),
step_parameters AS (
SELECT
a.step_id,
a.r_rowname,
ST_x(a.relocation1_geom) AS x,
ST_y(a.relocation1_geom) AS y,
a.relocation_time AS date,
a.dx,
a.dy,
a.dist,
extract(epoch FROM a.dt) AS dt,
ST_Distance(startp.relocation1_geom, a.relocation1_geom)^2 AS r2n,
a.abs_angle,
a.animal_name,
a.burst_name AS burst,
a.burst_order AS burst_order,
a.pgtraj_name AS pgtraj
FROM step_shape AS a
JOIN (SELECT
ab_id,
relocation1_geom
FROM step_shape
WHERE step_id IN (SELECT MIN(step_id)
FROM step_shape
GROUP BY ab_id)
) AS startp
ON startp.ab_id = a.ab_id
),
r_angle AS (
SELECT
s2.step_id,
CASE
WHEN s.dist < 1e-07 THEN s2.abs_angle - (SELECT sub.abs_angle
FROM step_shape AS sub
WHERE sub.step_id <= s.step_id
AND sub.dist >= 1e-07
ORDER BY sub.step_id DESC
LIMIT 1)
ELSE s2.abs_angle - s.abs_angle
END AS rel_angle
FROM step_shape AS s
LEFT OUTER JOIN LATERAL (SELECT *
FROM step_shape c
WHERE s.step_id < c.step_id
AND s.burst_name = c.burst_name
LIMIT 1
) AS s2
ON TRUE
)
SELECT
p.step_id,
p.r_rowname,
p.x,
p.y,
p.date,
p.dx,
p.dy,
p.dist,
p.dt,
p.r2n,
p.abs_angle,
CASE
WHEN r_angle.rel_angle <= -pi() THEN 2 * pi() + r_angle.rel_angle
WHEN r_angle.rel_angle > pi() THEN r_angle.rel_angle - 2 * pi()
ELSE r_angle.rel_angle
END AS rel_angle,
p.animal_name,
p.burst,
p.pgtraj
FROM step_parameters AS p
LEFT OUTER JOIN r_angle
ON r_angle.step_id = p.step_id
ORDER BY p.burst_order, p.step_id;"
)
create_sql_query <- gsub(pattern = '\\s', replacement = " ",
x = sql_query)
res <- tryCatch({
invisible(dbExecute(conn, create_sql_query))
message(paste0("View 'parameters_",pgtraj,"' created in schema '",
schema, "'."))
return(TRUE)
}, warning = function(war) {
message(paste0("WARNING in creating view 'parameters_",pgtraj,"' :"))
message(war)
return(war)
}, error = function(err) {
message(paste0("ERROR in creating view 'parameters_",pgtraj,"' :"))
message(err)
return(err)
})
} else {
sql_query <- paste0(
"CREATE OR REPLACE VIEW ",view," AS
WITH step_geom AS (
SELECT
s.id AS step_id,
ST_Makeline(r1.geom, r2.geom) AS step_geom,
r1.relocation_time,
s.dt,
s.r_rowname,
r1.geom AS relocation1_geom,
r2.geom AS relocation2_geom,
s.r2n,
s.rel_angle,
ab.burst_name,
ab.id as burst_order,
ab.animal_name,
p.pgtraj_name,
ab.id AS ab_id
FROM step s
JOIN relocation r1 ON s.relocation_id_1 = r1.id
LEFT JOIN relocation r2 ON s.relocation_id_2 = r2.id
JOIN s_b_rel rel ON rel.step_id = s.id
JOIN animal_burst ab ON ab.id = rel.animal_burst_id
JOIN pgtraj p ON p.id = ab.pgtraj_id
WHERE p.pgtraj_name = ",dbQuoteString(conn,pgtraj),"
)
SELECT t.step_id,
t.r_rowname,
ST_x(t.relocation1_geom) AS x,
ST_y(t.relocation1_geom) AS y,
t.relocation_time AS date,
t.dx,
t.dy,
t.dist,
extract(epoch FROM t.dt) AS dt,
t.r2n,
CASE
WHEN t.dist < 1e-07 THEN NULL
WHEN t.dist >= 1e-07 THEN atan2(t.dy, t.dx)
END AS abs_angle,
t.rel_angle,
t.animal_name,
t.burst_name AS burst,
t.pgtraj_name AS pgtraj
FROM (SELECT step_id,
relocation_time,
dt,
r_rowname,
relocation1_geom,
relocation2_geom,
burst_name,
burst_order,
animal_name,
pgtraj_name,
ST_length(step_geom) AS dist,
ST_X(relocation2_geom) - ST_X(relocation1_geom) AS dx,
ST_Y(relocation2_geom) - ST_Y(relocation1_geom) AS dy,
r2n,
rel_angle
FROM step_geom
) AS t
ORDER BY t.burst_order, t.step_id;")
create_sql_query <- gsub(pattern = '\\s', replacement = " ",
x = sql_query)
res <- tryCatch({
invisible(dbExecute(conn, create_sql_query))
message(paste0("View 'parameters_",pgtraj,"' created in schema '",
schema, "'."))
return(TRUE)
}, warning = function(war) {
message(paste0("WARNING in creating view 'parameters_",pgtraj,"' :"))
message(war)
return(war)
}, error = function(err) {
message(paste0("ERROR in creating view 'parameters_",pgtraj,"' :"))
message(err)
return(err)
})
}
sql_query <- paste0("SET search_path TO ", current_search_path, ";")
invisible(dbExecute(conn, sql_query))
return(res)
}
# pgTrajViewStepGeom
#' Creates a view of the step geometries for visualization.
#'
#' @param conn Connection object created with RPostgreSQL
#' @param schema String. Name of the schema that stores or will store the
#' pgtraj data model.
#' @param pgtraj String. Name of the pgtraj.
#'
#' @return TRUE on success, otherwise warning/error
#'
#' @author Balázs Dukai
#' @keywords internal
#'
pgTrajViewStepGeom <- function(conn, schema, pgtraj) {
current_search_path <- dbGetQuery(conn, "SHOW search_path;")
sql_query <- paste0("SET search_path TO ", dbQuoteIdentifier(conn,schema), ",public;")
invisible(dbExecute(conn, sql_query))
sql_query <- paste0(
"SELECT public.st_srid(r.geom)
FROM relocation r
JOIN step s ON s.relocation_id_1 = r.id
JOIN s_b_rel rel ON rel.step_id = s.id
JOIN animal_burst ab ON ab.id = rel.animal_burst_id
JOIN pgtraj p ON p.id = ab.pgtraj_id
WHERE p.pgtraj_name = ",dbQuoteString(conn,pgtraj),"
AND r.geom NOTNULL
LIMIT 1;")
srid <- dbGetQuery(conn, sql_query)[1, 1]
view <- dbQuoteIdentifier(conn,paste0("step_geometry_",pgtraj))
sql_query <- paste0(
"CREATE OR REPLACE VIEW ",view," AS
SELECT
s.id AS step_id,
ST_Makeline(r1.geom, r2.geom)::geometry(LINESTRING,",srid,") AS step_geom,
r1.relocation_time,
s.dt,
s.r_rowname,
ab.burst_name,
ab.animal_name,
p.pgtraj_name,
ab.id AS ab_id
FROM step s
JOIN relocation r1 ON s.relocation_id_1 = r1.id
JOIN relocation r2 ON s.relocation_id_2 = r2.id
JOIN s_b_rel rel ON rel.step_id = s.id
JOIN animal_burst ab ON ab.id = rel.animal_burst_id
JOIN pgtraj p ON p.id = ab.pgtraj_id
WHERE p.pgtraj_name = ",dbQuoteString(conn,pgtraj),"
ORDER BY ab.id, s.id;"
)
create_sql_query <- gsub(pattern = '\\s', replacement = " ", x = sql_query)
res <- tryCatch({
invisible(dbExecute(conn, create_sql_query))
message(paste0("View 'step_geometry_",pgtraj,"' created in schema '", schema, "'."))
return(TRUE)
}, warning = function(war) {
message(paste0("WARNING in creating view 'step_geometry_",pgtraj,"' :"))
message(war)
return(war)
}, error = function(err) {
message(paste0("ERROR in creating view 'step_geometry_",pgtraj,"' :"))
message(err)
return(err)
})
sql_query <- paste0("SET search_path TO ", current_search_path, ";")
invisible(dbExecute(conn, sql_query))
return(res)
}
# test_input
#' Test inputs for the functions pgTrajDB2TempT()
#'
#' @param pgtrajs String. Name of the pgtraj or name of the field that
#' stores the pgtraj names.
#' @param animals String. Name of the animal or name of the field that
#' stores the animal names.
#' @param relocations String. Name of the field that contains the
#' relocations in relocations_table.
#' @param bursts String. Name of the burst or name of the field that
#' stores the burst names.
#' @param rids String. Name of the field in relocations_table that
#' contains the numeric IDs of relocations.
#' @param epsg Numeric. The EPSG code of the Coordinate Reference
#' System of the relocation coordinates in the ltraj. Defaults to 0.
#' @return nothing
#'
#' @author Balázs Dukai \email{balazs.dukai@@gmail.com}
#' @keywords internal
test_input <- function(pgtrajs = NULL, animals = NULL, relocations = NULL,
bursts = NULL, rids = NULL, epsg = NULL) {
test_pa <- function(x) {
testthat::test_that("arguments 'pgtrajs', 'animals' and 'rids' have correct inputs",
{
testthat::expect_that(length(x) == 1, testthat::is_true())
testthat::expect_that(all(!is.na(x)), testthat::is_true())
testthat::expect_that(all(is.character(x)), testthat::is_true())
})
}
if (!is.null(pgtrajs)) {
test_pa(pgtrajs)
}
if (!is.null(animals)) {
test_pa(animals)
}
if (!is.null(rids)) {
test_pa(rids)
}
if (!is.null(bursts)) {
testthat::test_that("argument 'bursts' has a correct input",
{
testthat::expect_that(length(bursts) == 1, testthat::is_true())
})
}
if (!is.null(relocations)) {
testthat::test_that("argument 'relocations' has a correct input",
{
testthat::expect_that(all(!is.na(relocations)),
testthat::is_true())
testthat::expect_that(length(relocations) >=
1, testthat::is_true())
testthat::expect_that(length(relocations) <=
2, testthat::is_true())
testthat::expect_that(all(is.character(relocations)),
testthat::is_true())
})
}
if (!is.null(epsg)) {
testthat::test_that("argument 'epsg' has a correct input",
{
testthat::expect_that(is.numeric(epsg), testthat::is_true())
testthat::expect_that(epsg%%1 == 0, testthat::is_true())
})
}
}
# is_blank
#' Test if an argument is either NA, NULL, NaN or empty string.
#'
#' @param x Any object.
#' @return boolean
#' @author Balázs Dukai \email{balazs.dukai@@gmail.com}
#' @keywords internal
is_blank <- function(x, false_triggers=FALSE){
if(is.function(x)) return(FALSE)
return(
is.null(x) ||
length(x) == 0 ||
all(is.na(x)) ||
all(x=="") ||
(false_triggers && all(!x))
)
}
# writeInfoFromLtraj
#' Write infolocs table to database from ltraj in ltraj2pgtraj()
#'
#' @param conn A PostgreSQL connection object.
#' @param ltraj An adehabitatLT ltraj object
#' @param pgtraj String, name of the pgtraj being created
#' @param schema String, name of the schema holding the pgtraj
#' @return TRUE on successful infolocs writing
#'
#' @author David Bucklin \email{dbucklin@@ufl.edu}
#' @keywords internal
writeInfoFromLtraj <- function(conn, ltraj, pgtraj, schema) {
inf <- infolocs(ltraj)
if (is.null(inf)) {
#message("No Infolocs data in ltraj.")
return(FALSE)
}
# table_name
iloc_nm <- paste0("infolocs_", pgtraj)
# query-safe identifier names
iloc_nmq <- dbQuoteIdentifier(conn, iloc_nm)
schemaq <- dbQuoteIdentifier(conn, schema)
burst <- rep(burst(ltraj), sapply(ltraj, nrow))
rnms <- unlist(lapply(ltraj, function(x) rownames(x)))
# bind infolocs data frames
icols <- unlist(lapply(inf, function(x) colnames(x)))
icols <- unique(icols)
for (l in 1:length(inf)) {
missing <- icols[!icols %in% names(inf[[l]])]
inf[[l]][missing] <- NA
}
# bind data frames
iloc_df<-as.data.frame(inf[[1]][FALSE,])
# assuming burst order always matches infolocs order
bursts<-burst(ltraj)
for (b in 1:length(inf)) {
b_nm<-bursts[b]
# get burst dataframe
b_df<-inf[[b]]
# only reserved name is 'step_id'
if ("step_id" %in% names(b_df)) {
fix_df <- data.frame(b_df[1, ], step_id = 1)
fix_nm <- names(fix_df)[length(names(fix_df))]
names(b_df)[names(b_df) == "step_id"] <- fix_nm
#message("Reserved column name 'step_id' found in infolocs and changed to '",
# fix_nm, "'.")
}
##### infolocs definition section #####
types <- unlist(lapply(b_df, function(x) {
class(x)[1]
}))
# handle attribute (time zones)
attr2 <- lapply(b_df[1, ], function(x) {
attr(x, "tzone")[1]
})
badtz <- unlist(lapply(attr2, function(x) {
any(is.null(x), !x %in% OlsonNames())
}))
attr2[badtz] <- "NULL"
attr2 <- unlist(attr2)
# convert non-matching tz time to db tz
pgtz<-dbGetQuery(conn, "SHOW timezone;")[1,1]
tzl<-names(attr2[attr2 != "NULL" & attr2 != pgtz])
for (t in tzl) {
eval(parse(
text = paste0("attributes(b_df$",t,")$tzone <- pgtz")
))
}
# handle attribute (factor levels)
fact <- unlist(lapply(b_df[1, ], function(x) {
paste0("/*/", paste(attr(x, "levels"), collapse = "/*/"),
"/*/")
}))
fact <- gsub(",", "\\,", fact, fixed = TRUE)
attr2[!fact == "/*//*/"] <- fact[!fact == "/*//*/"]
# make array of columns, types, and time zones
info_nm <- paste0("'{{", paste(names(b_df), collapse = ","),
"},{", paste(as.character(types), collapse = ","), "},{",
paste(as.character(attr2), collapse = ","), "}}'")
# write info_nm to animal_burst.info_cols
sql_query <- paste0("UPDATE ", schemaq, ".animal_burst
SET (info_cols) = (",info_nm, ")
FROM ", schemaq, ".pgtraj
WHERE pgtraj.id = animal_burst.pgtraj_id
AND pgtraj.pgtraj_name = ",dbQuoteString(conn, pgtraj),
" AND animal_burst.burst_name = ",dbQuoteString(conn,b_nm),";")
dbExecute(conn, sql_query)
# add to final data frame
iloc_df<-rbind(iloc_df,b_df)
}
##### end infolocs definition section #####
# add original ltraj row and burst names, and step_id rowname
# and burst are just for join, discarded later
iloc_df$r_rowname931bqvz <- as.character(rnms)
iloc_df$burst_931bqvz <- as.character(burst)
iloc_df$step_id <- as.integer(1)
# insert into new table (just columns)
ctq<-dbBuildTableQuery(conn,c(schema, iloc_nm), iloc_df)
invisible(dbExecute(conn, ctq))
tztypes <- unlist(lapply(iloc_df, function(x) {
class(x)[1]
}))
tz <- tztypes %in% c("POSIXct", "POSIXt") #POSIXlt is stored as text
for (n in names(iloc_df)[tz]) {
dbExecute(conn, paste0("ALTER TABLE ", schemaq, ".",
iloc_nmq, " ALTER COLUMN ", dbQuoteIdentifier(conn,
n), " TYPE timestamp;"))
}
suppressMessages(pgInsert(conn, name = c(schema, iloc_nm),
data.obj = iloc_df, alter.names = FALSE))
dbComment(conn,name = c(schema, iloc_nm),type = "table",
comment = paste0("Infolocs (additional information on locations/steps) for the pgtraj ",
dbQuoteIdentifier(conn,pgtraj),"."), display = FALSE)
# update step_id column
sql_query<-paste0("UPDATE ",schemaq,".",iloc_nmq," a SET
step_id = b.step_id FROM
(SELECT s_b_rel.step_id as step_id,
step.r_rowname as r_rowname931bqvz,
animal_burst.burst_name as burst_931bqvz
FROM ",
schemaq,".pgtraj, ",
schemaq,".animal_burst, ",
schemaq,".s_b_rel, ",
schemaq,".step
WHERE
pgtraj.id = animal_burst.pgtraj_id AND
animal_burst.id = s_b_rel.animal_burst_id AND
s_b_rel.step_id = step.id AND
pgtraj_name = ",dbQuoteString(conn,pgtraj),"
ORDER BY step_id) b WHERE
a.r_rowname931bqvz = b.r_rowname931bqvz AND
a.burst_931bqvz = b.burst_931bqvz;")
dbExecute(conn,sql_query)
# drop r_rowname and burst columns
dbColumn(conn, c(schema, iloc_nm), colname = "burst_931bqvz",
action = "drop", display = FALSE)
dbColumn(conn, c(schema, iloc_nm), colname = "r_rowname931bqvz",
action = "drop", display = FALSE)
# add primary key to step_id
dbAddKey(conn, c(schema, iloc_nm), type = "primary", "step_id",
display = FALSE)
# add foreign key to step_id
sql_query <- paste0("ALTER TABLE ", schemaq, ".", iloc_nmq,
" ADD FOREIGN KEY (step_id) REFERENCES ", schemaq, ".step (id)
ON UPDATE NO ACTION ON DELETE CASCADE;")
dbExecute(conn, sql_query)
message(paste0("Infolocs for pgtraj '", pgtraj, "' written to table '",
iloc_nm, "'."))
return(TRUE)
}
# writeInfoFromDB
#' Write infolocs table to database from database in pgtraj2ltraj()
#'
#' @param conn A PostgreSQL connection object.
#' @param pgtraj String, name of the pgtraj
#' @param schema String, name of the schema holding the pgtraj
#' @param info_cols String. Optional character vector of column names of
#' additional information on relocations (replicating "infolocs" from the
#' \code{adehabitatLT} object \code{ltraj}).
#' @param info_table Character vector of \code{c("schema","table")} holding the
#' \code{info_cols}.
#' @param info_rids String. Column name of unique integer ID in \code{info_table}
#' to join with \code{rids} of the original relocations.
#' @return TRUE on successful infolocs writing
#' @author David Bucklin \email{dbucklin@@ufl.edu}
#' @keywords internal
writeInfoFromDB <- function(conn, pgtraj, schema, info_cols,
info_table, info_rids) {
# data goes with rids to zqaqtsn_temp as id; send this id as
# original relocation ids (orig_id) to relocation table
# select orig_id using join step.relocation_id_1 =
# relocation.id where steps in current pgtraj
# check if cols in table
tabl_chk<-rpostgis::dbTableInfo(conn,info_table)$column_name
info_cols<-info_cols[info_cols %in% tabl_chk]
# only reserved name is 'step_id'
fix_df <- make.names(c("step_id",info_cols), unique = TRUE)
fix_df <- fix_df[2:length(fix_df)]
info_repl<-info_cols
info_repl[info_cols=="step_id"]<-fix_df[info_cols=="step_id"]
info_replq<-dbQuoteIdentifier(conn,info_repl)
# query-safe identifier names
info_tableq <- dbQuoteIdentifier(conn, info_table)
info_colsq <- dbQuoteIdentifier(conn, info_cols)
schemaq <- dbQuoteIdentifier(conn, schema)
ins_cols <- paste("info_tab.", info_colsq, " AS ", info_replq, sep = "")
info_ridsq <- dbQuoteIdentifier(conn, info_rids)
iloc_nm <- paste0("infolocs_", pgtraj)
iloc_nmq <- dbQuoteIdentifier(conn, iloc_nm)
# create and populate table
sql_query<-paste0("SELECT step.id as step_id,",
paste(ins_cols,collapse = ","),"
INTO TABLE ",schemaq,".",iloc_nmq," FROM ",
paste(info_tableq,collapse=".")," as info_tab, ",
schemaq,".relocation, ",
schemaq,".pgtraj, ",
schemaq,".animal_burst, ",
schemaq,".s_b_rel, ",
schemaq,".step
WHERE
pgtraj.id = animal_burst.pgtraj_id AND
animal_burst.id = s_b_rel.animal_burst_id AND
s_b_rel.step_id = step.id AND
step.relocation_id_1 = relocation.id AND
relocation.orig_id = info_tab.",info_ridsq," AND
pgtraj_name = ",dbQuoteString(conn,pgtraj),"
ORDER BY step_id;")
dbExecute(conn,sql_query)
dbComment(conn,name = c(schema, iloc_nm),type = "table",
comment = paste0("Infolocs (additional information on locations/steps) for the pgtraj ",
dbQuoteIdentifier(conn,pgtraj),"."), display = FALSE)
# add primary key to step_id
dbAddKey(conn, name = c(schema, iloc_nm), type = "primary",
"step_id", display = FALSE)
# add foreign key to step_id
sql_query <- paste0("ALTER TABLE ", schemaq, ".", iloc_nmq,
" ADD FOREIGN KEY (step_id) REFERENCES ", schemaq, ".step (id)
ON UPDATE NO ACTION ON DELETE CASCADE;")
dbExecute(conn, sql_query)
message(paste0("Infolocs for pgtraj '", pgtraj, "' written to table '",
iloc_nm, "'."))
return(TRUE)
}
# getPgtrajWithInfo
#' Get pgtraj with infolocs as a data frame (used in pgtraj2ltraj)
#'
#' @param conn A PostgreSQL connection object.
#' @param pgtraj String, name of the pgtraj
#' @param schema String, name of the schema holding the pgtraj
#' @author David Bucklin \email{dbucklin@@ufl.edu}
#' @keywords internal
getPgtrajWithInfo <- function(conn, pgtraj, schema) {
# DB safe names
schemaq <- dbQuoteIdentifier(conn, schema)
iloc_nm <- paste0("infolocs_", pgtraj)
iloc_nmq <- dbQuoteIdentifier(conn, iloc_nm)
view <- paste0("parameters_",pgtraj)
viewq <- dbQuoteIdentifier(conn, view)
# get list of bursts (order by id from animal_burst)
sql_query <- paste0("SELECT burst_name as burst FROM
", schemaq, ".animal_burst a, ", schemaq, ".pgtraj b
WHERE a.pgtraj_id = b.id
AND b.pgtraj_name = ",dbQuoteString(conn,pgtraj),"
ORDER BY a.id;")
bursts <- dbGetQuery(conn, sql_query)$burst
# get db tz
pgtz<-dbGetQuery(conn, "SHOW timezone;")[1,1]
getinfo<-list()
for (b in 1:length(bursts)) {
b_nm<-bursts[b]
# check if defs exist
sql_query <- paste0("SELECT 1 as test FROM ",schemaq,".animal_burst a, ",schemaq,".pgtraj b
WHERE a.pgtraj_id = b.id
AND pgtraj_name = ",dbQuoteString(conn,pgtraj),
" AND burst_name = ",dbQuoteString(conn,b_nm),
" AND a.info_cols IS NOT NULL;")
check <- dbGetQuery(conn, sql_query)$test
if (!is.null(check)) {
sql_query <- paste0("SELECT unnest(info_cols[1:1]) as nms,
unnest(info_cols[2:2]) as defs,
unnest(info_cols[3:3]) as atts FROM "
,schemaq,".animal_burst a, ",schemaq,".pgtraj b WHERE a.pgtraj_id = b.id
AND pgtraj_name = ",dbQuoteString(conn,pgtraj),
" AND burst_name = ",dbQuoteString(conn,b_nm),";")
defs <- dbGetQuery(conn, sql_query)
sql_query <- paste0("SELECT * FROM ", schemaq, ".", iloc_nmq, " WHERE step_id IN
(SELECT s.step_id FROM
", schemaq, ".s_b_rel s, ", schemaq, ".animal_burst, ", schemaq, ".pgtraj
WHERE pgtraj.id = animal_burst.pgtraj_id AND
animal_burst.id = s.animal_burst_id AND
pgtraj.pgtraj_name = ",dbQuoteString(conn,pgtraj), " AND
animal_burst.burst_name = ",dbQuoteString(conn,b_nm),")
ORDER BY step_id;")
# also modify same query below in else{}
allinfo <- dbGetQuery(conn, sql_query)
# remove step_id
justinfo <- allinfo[!names(allinfo) == "step_id"]
# assign types
for (i in names(justinfo)) {
att <- defs[defs$nms == i, ]
if (length(att[, 1]) == 0) {
next
}
if (!is.na(att$atts)) {
# handle factors
if (att$defs %in% c("factor", "ordered")) {
levs <- unlist(strsplit(att$atts, "/*/", fixed = TRUE))
ordered <- ifelse(att$defs == "ordered", TRUE,
FALSE)
justinfo[, i] <- factor(as.character(justinfo[,
i]), levels = levs[levs != ""], ordered = ordered)
}
if (att$defs %in% c("POSIXct","POSIXt")) {
justinfo[, i] <- list(eval(parse(text = paste0("as.",
att$defs, "(as.character(justinfo[,i]),
tz='",
pgtz, "')"))))
# assign R tz
eval(parse(
text = paste0("attributes(justinfo$",i,")$tzone <- att$atts")
))
}
if (att$defs == "POSIXlt") {
justinfo[, i] <- list(eval(parse(text = paste0("as.",
att$defs, "(as.character(justinfo[,i]),
tz=att$atts)"))))
}
} else {
justinfo[, i] <- do.call(paste0("as.", att$defs),
list(justinfo[, i]))
}
}
getinfo[[b]]<-justinfo
} else {
sql_query <- paste0("SELECT * FROM ", schemaq, ".", iloc_nmq, " WHERE step_id IN
(SELECT s.step_id FROM
", schemaq, ".s_b_rel s, ", schemaq, ".animal_burst, ", schemaq, ".pgtraj
WHERE pgtraj.id = animal_burst.pgtraj_id AND
animal_burst.id = s.animal_burst_id AND
pgtraj.pgtraj_name = ",dbQuoteString(conn,pgtraj), " AND
animal_burst.burst_name = ",dbQuoteString(conn,b_nm),")
ORDER BY step_id;")
allinfo <- dbGetQuery(conn, sql_query)
# remove step_id
justinfo <- allinfo[!names(allinfo) == "step_id"]
getinfo[[b]]<-justinfo
}
}
return(getinfo)
}
# trajSummaryViews
#' Create views that summarize all pgtrajes (and pgtraj bursts) in a schema.
#' @param conn A PostgreSQL connection object
#' @param schema String, name of the schema
#' @author David Bucklin \email{dbucklin@@ufl.edu}
#' @keywords internal
trajSummaryViews<- function(conn, schema) {
#pgtraj summary
sql_query<-paste0("CREATE OR REPLACE VIEW all_pgtraj_summary AS
WITH p AS (
SELECT p_1.id,
p_1.pgtraj_name,
p_1.proj4string,
p_1.time_zone,
p_1.note,
p_1.insert_timestamp,
a.table_name
FROM pgtraj p_1
LEFT JOIN ( SELECT tables.table_name
FROM information_schema.tables
WHERE tables.table_schema::text = ",dbQuoteString(conn,schema),
" AND tables.table_name::text ~~ 'infolocs_%'::text) a
ON p_1.pgtraj_name = substring(a.table_name::text, 10)
)
SELECT p.id AS pgtraj_id,
p.pgtraj_name,
p.insert_timestamp AS last_update,
count(DISTINCT ab.burst_name) AS num_bursts,
count(r.id) AS num_relocations,
min(r.relocation_time) AS earliest_date,
max(r.relocation_time) AS latest_date,
p.table_name::text AS infolocs_table
FROM p,
animal_burst ab,
relocation r,
s_b_rel sb,
step s
WHERE p.id = ab.pgtraj_id
AND ab.id = sb.animal_burst_id
AND sb.step_id = s.id
AND s.relocation_id_1 = r.id
GROUP BY p.id, p.pgtraj_name, p.insert_timestamp, p.table_name
ORDER BY p.id;")
dbExecute(conn, sql_query)
# burst summary
sql_query<-"CREATE OR REPLACE VIEW all_burst_summary AS
SELECT p.id AS pgtraj_id,
p.pgtraj_name,
ab.animal_name,
ab.burst_name,
count(r.id) AS num_relocations,
count(r.id) - count(r.geom) AS num_na,
min(r.relocation_time) AS date_begin,
max(r.relocation_time) AS date_end
FROM pgtraj p,
animal_burst ab,
relocation r,
s_b_rel sb,
step s
WHERE p.id = ab.pgtraj_id AND
ab.id = sb.animal_burst_id AND
sb.step_id = s.id AND
s.relocation_id_1 = r.id
GROUP BY p.id, p.pgtraj_name, ab.id, ab.animal_name, ab.burst_name
ORDER BY p.id, ab.id;"
dbExecute(conn, sql_query)
return(invisible())
}
# from rpostgis ------------------------
## dbTableNameFix
##' Format input for database schema/table names.
##'
##' Internal rpostgis function to return common (length = 2) schema
##' and table name vector from various table and schema + table name
##' inputs.
##'
##' @param conn A connection object. Must be provided but can be set NULL,
##' where a dummy connection will be used.
##' @param t.nm Table name string, length 1-2.
##' @param as.identifier Boolean whether to return (schema,table) name as database
##' sanitized identifiers (TRUE) or as regular character (FALSE)
##' @return character vector of length 2. Each character element is in
##' (escaped) double-quotes when as.identifier = TRUE.
##' @keywords internal
##' @author David Bucklin
##' @importFrom DBI dbQuoteIdentifier
##' @importFrom DBI dbQuoteString
##' @examples
##' \dontrun{
##' name<-c("schema","table")
##' dbTableNameFix(conn,name)
##'
##' #current search path schema is added to single-length character object (if only table is given)
##' name<-"table"
##' dbTableNameFix(conn,name)
##'
##' #schema or table names with double quotes should be given exactly as they are
##' (make sure to wrap in single quotes in R):
##' name<-c('sch"ema','"table"')
##' dbTableNameFix(conn,name)
##' }
dbTableNameFix <- function(conn=NULL, t.nm, as.identifier = TRUE) {
## case of no schema provided
if (length(t.nm) == 1 && !is.null(conn) && !inherits(conn, what = "AnsiConnection")) {
schemalist<-dbGetQuery(conn,"select nspname as s from pg_catalog.pg_namespace;")$s
user<-dbGetQuery(conn,"SELECT current_user as user;")$user
schema<-dbGetQuery(conn,"SHOW search_path;")$search_path
schema<-gsub(" ","",unlist(strsplit(schema,",",fixed=TRUE)),fixed=TRUE)
# use user schema if available
if ("\"$user\"" == schema[1] && user %in% schemalist) {
sch<-user
} else {
sch<-schema[!schema=="\"$user\""][1]
}
t.nm <- c(sch, t.nm)
}
if (length(t.nm) > 2)
{
stop("Invalid PostgreSQL table/view name. Must be provided as one ('table') or two-length c('schema','table') character vector.")
}
if (is.null(conn)) {conn<-DBI::ANSI()}
if (!as.identifier) {return(t.nm)} else {
t.nm<-DBI::dbQuoteIdentifier(conn, t.nm)
return(t.nm)
}
}
## dbBuildTableQuery
##' Builds CREATE TABLE query for a data frame object.
##'
##' @param conn A PostgreSQL connection
##' @param name Table name string, length 1-2.
##' @param obj A data frame object.
##' @param field.types optional named list of the types for each field in \code{obj}
##' @param row.names logical, should row.name of \code{obj} be exported as a row_names field? Default is FALSE
##'
##' @note Adapted from RPostgreSQL::postgresqlBuildTableDefinition
##' @keywords internal
##' @author David Bucklin
dbBuildTableQuery <- function (conn = NULL, name, obj, field.types = NULL, row.names = FALSE) {
if (is.null(conn)) {
conn <- DBI::ANSI()
nameque <- dbQuoteIdentifier(conn,name)
} else {
nameque<-paste(dbTableNameFix(conn, name),collapse = ".")
}
if (!is.data.frame(obj))
obj <- as.data.frame(obj)
if (!is.null(row.names) && row.names) {
obj <- cbind(row.names(obj), obj)
names(obj)[1] <- "row_names"
}
if (is.null(field.types)) {
field.types <- sapply(obj, dbDataType, dbObj = conn)
}
i <- match("row_names", names(field.types), nomatch = 0)
if (i > 0)
field.types[i] <- dbDataType(conn, row.names(obj))
flds <- paste(dbQuoteIdentifier(conn ,names(field.types)), field.types)
paste("CREATE TABLE ", nameque , "\n(", paste(flds,
collapse = ",\n\t"), "\n);")
}
## dbVersion
##' Returns major.minor version of PostgreSQL (for version checking)
##'
##' @param conn A PostgreSQL connection
##' @return numeric vector of length 3 of major,minor,bug version.
##' @keywords internal
##' @author David Bucklin
dbVersion<- function (conn) {
pv<-dbGetQuery(conn,"SHOW server_version;")$server_version
nv<-unlist(strsplit(pv,".",fixed=TRUE))
return(as.numeric(nv))
}
## dbExistsTable
##' Check if a PostgreSQL table/view exists
##'
##' @param conn A PostgreSQL connection
##' @param name Table/view name string, length 1-2.
##'
##' @keywords internal
##' @author David Bucklin
dbExistsTable <- function (conn, name, table.only = FALSE) {
if (!table.only) to<-NULL else to<-" AND table_type = 'BASE TABLE'"
full.name<-dbTableNameFix(conn,name, as.identifier = FALSE)
chk<-dbGetQuery(conn, paste0("SELECT 1 FROM information_schema.tables
WHERE table_schema = ",dbQuoteString(conn,full.name[1]),
" AND table_name = ",dbQuoteString(conn,full.name[2]),to,";"))[1,1]
if (is.null(chk)) {
exists.t <- FALSE
# check version (matviews >= 9.3)
ver<-dbVersion(conn)
if (!table.only & !(ver[1] < 9 | (ver[1] == 9 && ver[2] < 3))) {
# matview case - not in information_schema
chk2<-dbGetQuery(conn, paste0("SELECT oid::regclass::text, relname
FROM pg_class
WHERE relkind = 'm'
AND relname = ",dbQuoteString(conn,full.name[2]),";"))
if (length(names(chk2)) > 0) {
sch<-gsub(paste0(".",chk2[1,2]),"",chk2[,1])
if (full.name[1] %in% sch) exists.t<-TRUE else exists.t<-FALSE
} else {
exists.t<-FALSE
}
}
} else {
exists.t<-TRUE
}
return(exists.t)
}
## dbConnCheck
##' Check if a supported PostgreSQL connection
##'
##' @param conn A PostgreSQL connection
##'
##' @keywords internal
##' @author David Bucklin
dbConnCheck <- function(conn) {
if (inherits(conn, c("PostgreSQLConnection"))) {
return(TRUE)
} else {
return(stop("'conn' must be a <PostgreSQLConnection> object."))
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.