Nothing
R/TSsql.R
In TSsql: Generic SQL Helper Functions for 'TSdbi' SQL Plugins
Defines functions
TSdescriptionSQL
TSdocSQL
TSlabelSQL
TSsourceSQL
TSputSQL
TSdeleteSQL
TSgetSQL
TSdatesSQL
createTSdbTables
removeTSdbTables
tbNm
realVintage
realPanel
setWhere
Documented in
createTSdbTables
realPanel
realVintage
removeTSdbTables
setWhere
TSdatesSQL
TSdeleteSQL
TSdescriptionSQL
TSdocSQL
TSgetSQL
TSlabelSQL
TSputSQL
TSsourceSQL
TSdescriptionSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
r <- dbGetQuery(con, paste("SELECT description", lang,
" FROM Meta ", setWhere(con, x,
realVintage(con, vintage, x),
realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
}
TSdocSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
if(1 < length(x)) stop("One series only for TSdoc")
r <- dbGetQuery(con, paste("SELECT documentation", lang,
" FROM Meta ", setWhere(con, x,
realVintage(con, vintage, x),
realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
}
TSlabelSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
if(1 < length(x)) stop("One series only for TSlabel")
# NOT YET
#r <- dbGetQuery(con, paste("SELECT label", lang,
# " FROM Meta ", setWhere(con, x,
# realVintage(con, vintage, x),
# realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
#if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
NA
}
TSsourceSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
if(1 < length(x)) stop("One series only for TSsource")
# NOT YET
#r <- dbGetQuery(con, paste("SELECT source", lang,
# " FROM Meta ", setWhere(con, x,
# realVintage(con, vintage, x),
# realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
#if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
NA
}
TSputSQL <- function(x, serIDs=seriesNames(x), con, Table=NULL,
TSdescription.=TSdescription(x), TSdoc.=TSdoc(x), TSlabel.=TSlabel(x),
TSsource.=TSsource(x),
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
# so far I think this is generic to all SQL, but not extensively tested.
# should rollback meta when data put fails
# (reversing order of M and P would mean data can change and
# then meta fail, which seems worse.)
panel <- realPanel(con,panel)
# vintage <- realVintage(con,vintage, x) No. To put, vintage must already be real.
# M does the write to Meta, P writes values to data table.
# Column order could be specified after Meta, but this assumes order
#([vintage,] [ panel,] id, tbl, refperiod, description, documentation )
M <- function(v, p, table, id, rP, desc, doc) {
if(is.null(rP)) rP <- "NA"
if(is.null(desc)) desc <- "NA"
if(is.null(doc)) doc <- "NA"
q <- "INSERT INTO Meta VALUES ('"
if(!is.null(v)) q <- paste(q,v, "', '", sep="")
if(!is.null(p)) q <- paste(q,p, "', '", sep="")
q <- paste(q, id, "', '", table, "', '",
rP, "', '", desc, "', '", doc, "') ;", sep="")
dbGetQuery(con, q)
# next if is RSQLite BUG work around
if(is(con, "SQLiteConnection")) return(TRUE)
0 == dbGetException(con)$errorNum
}
P <- function(p, tableV, columns, id, ...) {
x <- list(...)
vl <- id
if(!is.null(p)) {
vl <- paste(p,vl, sep=",")
columns <- paste("panel,",columns, sep="")
}
for (i in 1:length(x)) vl <- paste(vl, x[[i]], sep="', '")
# SQL wants NULL (not 'NULL') for NA
vl <- gsub("'NA'", "NULL", paste(vl,"'", sep=""))
dbGetQuery(con, paste("DELETE FROM ",tableV,
setWhere(con,id[1],NULL,panel), ";", sep=""))
for (i in seq(length(vl))){
q <- paste("INSERT INTO ",tableV, " (", columns,
") VALUES ('", vl[i], ") ", sep="")
dbGetQuery(con, q)
}
# next if is RSQLite BUG work around
if(is(con, "SQLiteConnection")) return(TRUE)
0 == dbGetException(con)$errorNum
}
if (con@hasVintages) {
hV <- TRUE
vintage <- realVintage(con,vintage, serIDs)
}
else hV <- FALSE
# as.matrix(x) clobbers seriesNames(x)
ids <- serIDs
#ids <- gsub(" ", "", serIDs ) # remove spaces in id
#if(! all( ids == serIDs)) warning("spaces removed from series names.")
rP <- TSrefperiod(x)
#N <- NROW(x) # could be periods() (or Tobs())
# SHOULD PROBABLY HAVE METHODS FOR TS, ZOO, ITS, ... HERE
if(is.ts(x)) {
fr <-frequency(x)
y <- floor(time(x))
p <- 1 + round(frequency(x) * (time(x) %% 1 ))
x <- as.matrix(x)
if(1==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "A", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "A", vintage), "id, year, v", ids[i], y, x[,i])
}
else if(2==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "S", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "S", vintage), "id, year, period, v", ids[i], y, p, x[,i])
}
else if(4==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "Q", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "Q", vintage), "id, year, period, v", ids[i], y, p, x[,i])
}
else if(12==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "M", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "M", vintage), "id, year, period, v", ids[i], y, p, x[,i])
}
else stop("ts frequency not supported.")
}
else if (inherits(x, "zoo")) {
##require("zoo")
# might do better than this
if (is.null(Table)) stop("Table must be specified for zoo series.")
d <- time(x)
p <- as.POSIXlt(d)
x <- as.matrix(x)
# STILL NEED A S Q M FOR ZOO
if("W" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "W", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
# period should be week of the year 1-52/3
ok <- P(panel, tbNm(hV, "W", vintage), "id, date, period, v", ids[i], d, p$mday, x[,i])
}
else if("B" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "B", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
# period should be business day of the year 1- ~260
# but need to map holidays
ok <- P(panel, tbNm(hV, "B", vintage), "id, date, period, v", ids[i], d, p$yday, x[,i])
}
else if("D" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "D", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
# period should be day of the year 1- 365/6
ok <- P(panel, tbNm(hV, "D", vintage), "id, date, period, v", ids[i], d, p$yday, x[,i])
}
else if("U" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "U", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
tz <- attr(p, "tzone")
ok <- P(panel, tbNm(hV, "U", vintage), "id, date, period, v", ids[i], d, tz, p$mday,x[,i])
}
else if("T" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "T", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "T", vintage), "id, date, v", ids[i], d, x[,i])
}
else if("I" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "I", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "I", vintage), "id, date, v", ids[i], d, x[,i])
}
else stop("Table specification not supported.")
}
else stop("Time series type not recognized.")
new("logicalId", ok & okM,
TSid=new("TSid", serIDs=serIDs, dbname=con@dbname,
conType=class(con), hasVintages=con@hasVintages, hasPanels=con@hasPanels,
DateStamp=NA))
}
TSdeleteSQL <- function(serIDs, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
for (i in seq(length(serIDs))) {
rv <- realVintage(con, vintage, i)
rp <- realPanel(con,panel)
where <- setWhere(con, serIDs[i], rv, rp)
whereT <- setWhere(con, serIDs[i], NULL, rp)
q <- dbGetQuery(con, paste("SELECT tbl FROM Meta ",where, ";"))
tbl <- tbNm(con@hasVintages, q$tbl, rv)
if(0 != length(q)) {
dbGetQuery(con, paste("DELETE FROM ", tbl, whereT, ";"))
dbGetQuery(con, paste("DELETE FROM Meta ", where, ";"))
}
}
# could do better checking here
new("logicalId", TRUE,
TSid=new("TSid", serIDs=serIDs, dbname=con@dbname,
conType=class(con), hasVintages=con@hasVintages, hasPanels=con@hasPanels,
DateStamp=NA ))
}
TSgetSQL <- function(serIDs, con, TSrepresentation=getOption("TSrepresentation"),
tf=NULL, start=tfstart(tf), end=tfend(tf),
names=NULL,
TSdescription=FALSE, TSdoc=FALSE, TSlabel=FALSE, TSsource=TRUE,
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
# so far I think this is generic to all SQL.
# default is ts if the table is in c("A", "Q", "M","S") and zoo otherwise.
# default is used for retrieval and any conversion is done after.
if ( 1 < sum(c(length(serIDs), length(panel), length(vintage)) > 1))
stop("Only one of serIDs, panel, or vintage can have length greater than 1.")
if(is.null(names)) names <-
if ( length(panel) > 1 ) panel else
if ( length(vintage) > 1 ) vintage else serIDs
panel <- realPanel(con,panel)
# if vintage is a vector then serIDs needs to be expanded
if ( 1 < length(vintage)) serIDs <- rep(serIDs, length(vintage))
# next returns a vector of length equal serIDs
if (con@hasVintages) {
hV <- TRUE
vintage <- realVintage(con,vintage, serIDs)
}
else hV <- FALSE
Q <- function(q) {# local function
res <- dbGetQuery(con, q)
if(any(dim(res) == 0)) stop("empty query result.")
as.matrix(res)
}
mat <- desc <- doc <- label <- source <- rp <- NULL
# if series are in "A", "Q", "M","S" use ts otherwise zoo.
for (i in seq(length(serIDs))) {
where <- setWhere(con, serIDs[i], vintage[i], panel)
whereT <- setWhere(con, serIDs[i], NULL, panel)
for (j in seq(length(where))) {
qq <- paste("SELECT tbl, refperiod FROM Meta ",where[j], ";")
q <- dbGetQuery(con, qq)
if(0 == NROW(q$tbl))
stop("Meta lookup for series ", serIDs[i],
" failed. (Result empty for query: ",
qq, ") Series does not exist on database.")
if(1 < NROW(q$tbl)){
warning("Meta lookup for series ", serIDs[i],
" returned multiple table entries ", q$tbl, ". query: ",
qq, ") Possible database corruption. Using the first table.")
q <- q[1,]
}
if (i == 1) tbl <- q$tbl
else if(q$tbl != tbl)
stop("Series must all have the same frequency or time representation.")
rp <- c(rp, q$refperiod)
if (tbl=="A")
{res <- Q(paste("SELECT year, v FROM ", tbNm(hV, "A", vintage[i]),
whereT[j], " order by year;"))
r <- ts(res[,2], start=c(res[1,1], 1), frequency=1)
}
else if (tbl=="Q")
{res <- Q(paste("SELECT year, period, v FROM ", tbNm(hV, "Q", vintage[i]),
whereT[j], " order by year, period;"))
r <- ts(res[,3], start=c(res[1,1:2]), frequency=4)
}
else if (tbl=="M")
{res <- Q(paste("SELECT year, period, v FROM ", tbNm(hV, "M", vintage[i]),
whereT[j], " order by year, period;"))
r <- ts(res[,3], start=c(res[1,1:2]), frequency=12)
}
else if (tbl=="W")
{res <- Q(paste("SELECT date, period, v FROM ", tbNm(hV, "W", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,3]), as.Date(res[,1]))
# period is as.int(res[,2])
}
else if (tbl=="B")
{res <- Q(paste("SELECT date, period, v FROM ", tbNm(hV, "B", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,3]), as.Date(res[,1]))
# period is as.int(res[,2])
}
else if (tbl=="D")
{res <- Q(paste("SELECT date, period, v FROM ", tbNm(hV, "D", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,3]), as.Date(res[,1]))
# period is as.int(res[,2])
}
else if (tbl=="S")
{res <- Q(paste("SELECT year, period, v FROM ", tbNm(hV, "S", vintage[i]),
whereT[j], " order by year, period;"))
r <- ts(res[,3], start=c(res[1,1:2]), frequency=2)
}
else if (tbl=="U")
{res <- Q(paste("SELECT date, tz, period, v FROM U ",tbNm(hV,"U",vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,4]), as.Date(res[,1]))
# tz ? period is as.int(res[,3])
}
else if (tbl=="I")
{res <- Q(paste("SELECT date, v FROM ", tbNm(hV, "I", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,2]), as.Date(res[,1]))
}
else if (tbl=="T")
{res <- Q(paste("SELECT date, v FROM ", tbNm(hV, "T", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,2]), as.POSIXct(res[,1]))
}
else stop("Specified table not found.",
" (Internal TSdbi or database error likely.)",
" looking for series ", serIDs[i],
" could not find tbl ", tbl)
if(TSdescription) desc <- c(desc, TSdescription(serIDs[i],con) ) # where?
if(TSdoc) doc <- c(doc, TSdoc(serIDs[i],con) ) # where?
if(TSlabel) label<- c(label, TSlabel(serIDs[i],con) ) # where?
if(TSsource) source<- c(source,TSsource(serIDs[i],con) ) # where?
mat <- tbind(mat, r)
} # where[j]
} # serID[i]
mat <- tfwindow(mat, tf=tf, start=start, end=end)
mat <- tframePlus::changeTSrepresentation(mat, TSrepresentation)
if( (!all(is.na(rp))) && !all(rp == " " ) ) TSrefperiod(mat) <- rp
seriesNames(mat) <- names
TSmeta(mat) <- new("TSmeta", serIDs=serIDs, dbname=con@dbname,
conType=class(con), hasVintages=con@hasVintages, hasPanels=con@hasPanels,
DateStamp=NA, # bug in 2.7.0 =Sys.time(),
TSdescription=if(TSdescription) desc else NA,
TSdoc =if(TSdoc) doc else NA,
TSlabel =if(TSlabel) label else NA,
TSsource =if(TSsource) source else NA)
mat
}
TSdatesSQL <- function(serIDs, con,
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
# so far I think this is generic to all SQL, but untested.
r <- av <- tb <- rP <- NULL
st <- en <- list()
vintage <- realVintage(con, vintage, serIDs)
panel <- realPanel(con,panel)
for (i in seq(length(serIDs))) {
qq <- paste("SELECT id, tbl, refperiod FROM Meta ",
setWhere(con, serIDs[i], vintage[i], panel), ";", sep="")
q <- dbGetQuery(con, qq)
if(is.null(q) || NROW(q) == 0) {
av <- c(av, FALSE)
st <- append(st, list(NA))
en <- append(en, list(NA))
tb <- rbind(tb, NA)
rP <- rbind(rP, NA)
}
else if(NROW(q) > 1){
warning("More than one series with the same identifier. Possible database corruption.",
" Meta lookup for series ", serIDs[i], " vintage ", vintage[i],
" returned multiple entries ", q, " for query: ",
qq, " Possible database corruption. Using the first table.")
q <- q[1,]
}
else {
q2 <- TSget(serIDs=serIDs[i], con, vintage=vintage, panel=panel)
av <- c(av, TRUE)
# paste(start(q2), collapse="-")
st <- append(st, list(start(q2)))
en <- append(en, list(end(q2)))
tb <- rbind(tb, q$tb)
rP <- rbind(rP, q$TSrefperiod)
}
}
r <- serIDs
attr(r, "TSdates") <- av
attr(r, "start") <- st
attr(r, "end") <- en
attr(r, "tbl") <- tb
attr(r, "TSrefperiod") <- rP
class(r) <- "TSdates"
r
}
#####################################
# these methods will generally not be needed by users, but is used in the test
# database setup.
createTSdbTables <- function(con, index=FALSE){
Texists <- function(a){
if(dbExistsTable(con,a)) {
warning("table ",a," exists. Not replacing it."); return(TRUE)}
if(dbExistsTable(con,toupper(a))) {
warning("table ",toupper(a)," exists. Not replacing it."); return(TRUE)}
if(dbExistsTable(con,tolower(a))) {
warning("table ",tolower(a)," exists. Not replacing it."); return(TRUE)}
FALSE
}
if (!Texists("Meta")) {
# Set up Metadata table Meta.
dbGetQuery(con, "create table Meta (
id VARCHAR(40) NOT NULL,
tbl CHAR(1),
refperiod VARCHAR(10) default NULL,
description TEXT,
documentation TEXT
);")
dbGetQuery(con, "CREATE UNIQUE INDEX Metaindex_id ON Meta (id);")
dbGetQuery(con, "CREATE INDEX Metaindex_tbl ON Meta (tbl);")
}
if (!Texists("A")) {
# Set up annual table A.
dbGetQuery(con, "create table A (
id VARCHAR(40),
year INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Aindex_id ON A (id);")
if (index) dbGetQuery(con, "CREATE INDEX Aindex_year ON A (year);")
}
if (!Texists("B")) {
# Set up business table B .
dbGetQuery(con, "create table B (
id VARCHAR(40),
date DATE,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Bindex_id ON B (id);")
if (index) dbGetQuery(con, "CREATE INDEX Bindex_date ON B (date);")
if (index) dbGetQuery(con, "CREATE INDEX Bindex_period ON B (period);")
}
if (!Texists("D")) {
# Set up daily table D .
dbGetQuery(con, "create table D (
id VARCHAR(40),
date DATE,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Dindex_id ON D (id);")
if (index) dbGetQuery(con, "CREATE INDEX Dindex_date ON D (date);")
if (index) dbGetQuery(con, "CREATE INDEX Dindex_period ON D (period);")
}
if (!Texists("M")) {
# Set up monthly table M.
dbGetQuery(con, "create table M (
id VARCHAR(40),
year INT,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Mindex_id ON M (id);")
if (index) dbGetQuery(con, "CREATE INDEX Mindex_year ON M (year);")
if (index) dbGetQuery(con, "CREATE INDEX Mindex_period ON M (period);")
}
if (!Texists("U")) {
# Set up minutely table U .
# tz not tested yet. Not sure about period.
dbGetQuery(con, "create table U (
id VARCHAR(40),
date TIMESTAMP,
tz VARCHAR(4),
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Uindex_id ON U (id);")
if (index) dbGetQuery(con, "CREATE INDEX Uindex_date ON U (date);")
if (index) dbGetQuery(con, "CREATE INDEX Uindex_period ON U (period);")
}
if (!Texists("Q")) {
# Set up quarterly table Q.
dbGetQuery(con, "create table Q (
id VARCHAR(40),
year INT,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Qindex_id ON Q (id);")
if (index) dbGetQuery(con, "CREATE INDEX Qindex_year ON Q (year);")
if (index) dbGetQuery(con, "CREATE INDEX Qindex_period ON Q (period);")
}
if (!Texists("S")) {
# Set up semiannual table S .
dbGetQuery(con, "create table S (
id VARCHAR(40),
year INT,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Sindex_id ON S (id);")
if (index) dbGetQuery(con, "CREATE INDEX Sindex_year ON S (year);")
if (index) dbGetQuery(con, "CREATE INDEX Sindex_period ON S (period);")
}
if (!Texists("W")) {
# Set up weekly table W .
dbGetQuery(con, "create table W (
id VARCHAR(40),
date DATE,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Windex_id ON W (id);")
if (index) dbGetQuery(con, "CREATE INDEX Windex_date ON W (date);")
if (index) dbGetQuery(con, "CREATE INDEX Windex_period ON W (period);")
}
if (!Texists("I")) {
# Set up irregular date table I .
dbGetQuery(con, "create table I (
id VARCHAR(40),
date DATE,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Iindex_id ON I (id);")
if (index) dbGetQuery(con, "CREATE INDEX Iindex_date ON I (date);")
}
if (!Texists("T")) {
# Set up irregular date-time table T .
# IT WOULD BE NICE TO HAVE TZ HERE TOO
dbGetQuery(con, "create table T (
id VARCHAR(40),
date TIMESTAMP,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Tindex_id ON T (id);")
if (index) dbGetQuery(con, "CREATE INDEX Tindex_date ON T (date);")
}
# This is generic sql way to get table info. (eg. table A )
# but it requires read privileges on INFORMATION_SCHEMA.Columns
# which the user may not have.
#
#if( "SQLiteConnection" != class(con)) { #SQLite does not seem to support this
# z <- try(
# dbGetQuery(con, "SELECT COLUMN_NAME, COLUMN_DEFAULT, COLLATION_NAME, DATA_TYPE,
# CHARACTER_SET_NAME, CHARACTER_MAXIMUM_LENGTH, NUMERIC_PRECISION
# FROM INFORMATION_SCHEMA.Columns WHERE table_name='A' ;"), silent=TRUE )
# if(inherits(z, "try-error")) cat(
# "INFORMATION_SCHEMA query problem. (User may not have permission.)\n")
# else print(z)
# }
cat(" tables:\n")
dbListTables(con)
}
removeTSdbTables <- function(con, yesIknowWhatIamDoing=FALSE, ToLower=FALSE){
if(!yesIknowWhatIamDoing)
stop("You need to know what you are doing before using this function!!")
# "dropTStable" works around the
# problem that different db engines treat capitalized table names differently.
# e.g. MySQL uses table name Meta while Posgresql converts to meta.
dropTStable <- function(Table){
if (ToLower) Table <- tolower(Table)
if(dbExistsTable(con, Table)) dbRemoveTable(con, Table)
}
dropTStable("Meta")
dropTStable("A")
dropTStable("B")
dropTStable("D")
dropTStable("M")
dropTStable("U")
dropTStable("Q")
dropTStable("S")
dropTStable("W")
dropTStable("I")
dropTStable("T")
invisible(TRUE)
}
########## internal utilities to construct WHERE and table name#########
tbNm <- function(hasVintages, tbl, rV) {
if(hasVintages) tbl <- paste(tbl, rV, sep="_")
# map - to _ in table names
gsub("-", "_",tbl)
}
realVintage <- function(con, vintage, serIDs) {
# replace alias with canonical name if necessary
# assuming if vintage is a vector then serIDs has already been expanded to
# the same length. Otherwise, vintage should be null or a scalar which is
# expanded to the length of serIDs.
if(!con@hasVintages) return(vintage) #usually NULL in this case
if(is.null(vintage)) vintage <- "current"
else if( 1 == length(vintage)) vintage <- rep(vintage, length(serIDs))
rV <- NULL
for (i in seq(length(serIDs))){
q <- paste("SELECT vintage FROM vintageAlias WHERE alias ='",
vintage[i],"' AND id = '",serIDs[i],"';", sep="")
r <- dbGetQuery(con,q )$vintage
# if alias result is empty check null id which applies to all series.
if (0== NROW(r)) {
q <- paste( "SELECT vintage FROM vintageAlias WHERE alias='",
vintage[i],"' ;", sep="")
r <- dbGetQuery(con,q )$vintage
}
# if alias result is still empty assume vintage is already the real one.
if (0== NROW(r)) r <- vintage[i]
rV <- c(rV, r)
}
rV
}
realPanel <- function(con, panel) {
# replace alias with canonical name if necessary
if(!con@hasPanels) return(panel) #usually NULL in this case
if(is.null(panel)) stop("panel must be specified")
for (i in seq(length(panel))){
q <- paste("SELECT panel FROM panelAlias WHERE alias='",
panel[i],"';", sep="")
r <- dbGetQuery(con,q )$panel
# if alias result is empty assume panel is already the real one.
if (0== NROW(r)) r <- panel[i]
rP <- c(rP, r)
}
rP
}
setWhere <- function(con, serIDs, realVintage, realPanel) {
# serIDs must be a scale for this function
# Calls for Meta will pass realVintage, but data tables will set
# realVintage=NULL and append vintage to table name.
where <- paste(" WHERE id = '", serIDs, "'", sep="")
if(!is.null(realVintage))
where <- paste(where, " AND vintage='", realVintage, "'", sep="")
if(!is.null(realPanel))
where <- paste(where, " AND panel='", realPanel, "'", sep="")
where
}
Try the TSsql package in your browser
Any scripts or data that you put into this service are public.
TSsql documentation built on May 2, 2019, 5:20 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions TSdescriptionSQL TSdocSQL TSlabelSQL TSsourceSQL TSputSQL TSdeleteSQL TSgetSQL TSdatesSQL createTSdbTables removeTSdbTables tbNm realVintage realPanel setWhere
Documented in createTSdbTables realPanel realVintage removeTSdbTables setWhere TSdatesSQL TSdeleteSQL TSdescriptionSQL TSdocSQL TSgetSQL TSlabelSQL TSputSQL TSsourceSQL
TSdescriptionSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
r <- dbGetQuery(con, paste("SELECT description", lang,
" FROM Meta ", setWhere(con, x,
realVintage(con, vintage, x),
realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
}
TSdocSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
if(1 < length(x)) stop("One series only for TSdoc")
r <- dbGetQuery(con, paste("SELECT documentation", lang,
" FROM Meta ", setWhere(con, x,
realVintage(con, vintage, x),
realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
}
TSlabelSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
if(1 < length(x)) stop("One series only for TSlabel")
# NOT YET
#r <- dbGetQuery(con, paste("SELECT label", lang,
# " FROM Meta ", setWhere(con, x,
# realVintage(con, vintage, x),
# realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
#if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
NA
}
TSsourceSQL <- function(x=NULL, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel"),
lang=getOption("TSlang")) {
if(1 < length(x)) stop("One series only for TSsource")
# NOT YET
#r <- dbGetQuery(con, paste("SELECT source", lang,
# " FROM Meta ", setWhere(con, x,
# realVintage(con, vintage, x),
# realPanel(con,panel)), ";", sep=""))[[1]]
# odbc converts NA to logical, but other db may return char
#if(is.null(r) || is.na(r)|| ("NA" == r)) NA else r
NA
}
TSputSQL <- function(x, serIDs=seriesNames(x), con, Table=NULL,
TSdescription.=TSdescription(x), TSdoc.=TSdoc(x), TSlabel.=TSlabel(x),
TSsource.=TSsource(x),
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
# so far I think this is generic to all SQL, but not extensively tested.
# should rollback meta when data put fails
# (reversing order of M and P would mean data can change and
# then meta fail, which seems worse.)
panel <- realPanel(con,panel)
# vintage <- realVintage(con,vintage, x) No. To put, vintage must already be real.
# M does the write to Meta, P writes values to data table.
# Column order could be specified after Meta, but this assumes order
#([vintage,] [ panel,] id, tbl, refperiod, description, documentation )
M <- function(v, p, table, id, rP, desc, doc) {
if(is.null(rP)) rP <- "NA"
if(is.null(desc)) desc <- "NA"
if(is.null(doc)) doc <- "NA"
q <- "INSERT INTO Meta VALUES ('"
if(!is.null(v)) q <- paste(q,v, "', '", sep="")
if(!is.null(p)) q <- paste(q,p, "', '", sep="")
q <- paste(q, id, "', '", table, "', '",
rP, "', '", desc, "', '", doc, "') ;", sep="")
dbGetQuery(con, q)
# next if is RSQLite BUG work around
if(is(con, "SQLiteConnection")) return(TRUE)
0 == dbGetException(con)$errorNum
}
P <- function(p, tableV, columns, id, ...) {
x <- list(...)
vl <- id
if(!is.null(p)) {
vl <- paste(p,vl, sep=",")
columns <- paste("panel,",columns, sep="")
}
for (i in 1:length(x)) vl <- paste(vl, x[[i]], sep="', '")
# SQL wants NULL (not 'NULL') for NA
vl <- gsub("'NA'", "NULL", paste(vl,"'", sep=""))
dbGetQuery(con, paste("DELETE FROM ",tableV,
setWhere(con,id[1],NULL,panel), ";", sep=""))
for (i in seq(length(vl))){
q <- paste("INSERT INTO ",tableV, " (", columns,
") VALUES ('", vl[i], ") ", sep="")
dbGetQuery(con, q)
}
# next if is RSQLite BUG work around
if(is(con, "SQLiteConnection")) return(TRUE)
0 == dbGetException(con)$errorNum
}
if (con@hasVintages) {
hV <- TRUE
vintage <- realVintage(con,vintage, serIDs)
}
else hV <- FALSE
# as.matrix(x) clobbers seriesNames(x)
ids <- serIDs
#ids <- gsub(" ", "", serIDs ) # remove spaces in id
#if(! all( ids == serIDs)) warning("spaces removed from series names.")
rP <- TSrefperiod(x)
#N <- NROW(x) # could be periods() (or Tobs())
# SHOULD PROBABLY HAVE METHODS FOR TS, ZOO, ITS, ... HERE
if(is.ts(x)) {
fr <-frequency(x)
y <- floor(time(x))
p <- 1 + round(frequency(x) * (time(x) %% 1 ))
x <- as.matrix(x)
if(1==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "A", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "A", vintage), "id, year, v", ids[i], y, x[,i])
}
else if(2==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "S", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "S", vintage), "id, year, period, v", ids[i], y, p, x[,i])
}
else if(4==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "Q", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "Q", vintage), "id, year, period, v", ids[i], y, p, x[,i])
}
else if(12==fr) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "M", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "M", vintage), "id, year, period, v", ids[i], y, p, x[,i])
}
else stop("ts frequency not supported.")
}
else if (inherits(x, "zoo")) {
##require("zoo")
# might do better than this
if (is.null(Table)) stop("Table must be specified for zoo series.")
d <- time(x)
p <- as.POSIXlt(d)
x <- as.matrix(x)
# STILL NEED A S Q M FOR ZOO
if("W" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "W", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
# period should be week of the year 1-52/3
ok <- P(panel, tbNm(hV, "W", vintage), "id, date, period, v", ids[i], d, p$mday, x[,i])
}
else if("B" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "B", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
# period should be business day of the year 1- ~260
# but need to map holidays
ok <- P(panel, tbNm(hV, "B", vintage), "id, date, period, v", ids[i], d, p$yday, x[,i])
}
else if("D" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "D", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
# period should be day of the year 1- 365/6
ok <- P(panel, tbNm(hV, "D", vintage), "id, date, period, v", ids[i], d, p$yday, x[,i])
}
else if("U" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "U", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
tz <- attr(p, "tzone")
ok <- P(panel, tbNm(hV, "U", vintage), "id, date, period, v", ids[i], d, tz, p$mday,x[,i])
}
else if("T" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "T", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "T", vintage), "id, date, v", ids[i], d, x[,i])
}
else if("I" == Table) for (i in seq(nseries(x))) {
okM <- M(vintage, panel, "I", ids[i], rP[i], TSdescription.[i], TSdoc.[i])
ok <- P(panel, tbNm(hV, "I", vintage), "id, date, v", ids[i], d, x[,i])
}
else stop("Table specification not supported.")
}
else stop("Time series type not recognized.")
new("logicalId", ok & okM,
TSid=new("TSid", serIDs=serIDs, dbname=con@dbname,
conType=class(con), hasVintages=con@hasVintages, hasPanels=con@hasPanels,
DateStamp=NA))
}
TSdeleteSQL <- function(serIDs, con=getOption("TSconnection"),
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
for (i in seq(length(serIDs))) {
rv <- realVintage(con, vintage, i)
rp <- realPanel(con,panel)
where <- setWhere(con, serIDs[i], rv, rp)
whereT <- setWhere(con, serIDs[i], NULL, rp)
q <- dbGetQuery(con, paste("SELECT tbl FROM Meta ",where, ";"))
tbl <- tbNm(con@hasVintages, q$tbl, rv)
if(0 != length(q)) {
dbGetQuery(con, paste("DELETE FROM ", tbl, whereT, ";"))
dbGetQuery(con, paste("DELETE FROM Meta ", where, ";"))
}
}
# could do better checking here
new("logicalId", TRUE,
TSid=new("TSid", serIDs=serIDs, dbname=con@dbname,
conType=class(con), hasVintages=con@hasVintages, hasPanels=con@hasPanels,
DateStamp=NA ))
}
TSgetSQL <- function(serIDs, con, TSrepresentation=getOption("TSrepresentation"),
tf=NULL, start=tfstart(tf), end=tfend(tf),
names=NULL,
TSdescription=FALSE, TSdoc=FALSE, TSlabel=FALSE, TSsource=TRUE,
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
# so far I think this is generic to all SQL.
# default is ts if the table is in c("A", "Q", "M","S") and zoo otherwise.
# default is used for retrieval and any conversion is done after.
if ( 1 < sum(c(length(serIDs), length(panel), length(vintage)) > 1))
stop("Only one of serIDs, panel, or vintage can have length greater than 1.")
if(is.null(names)) names <-
if ( length(panel) > 1 ) panel else
if ( length(vintage) > 1 ) vintage else serIDs
panel <- realPanel(con,panel)
# if vintage is a vector then serIDs needs to be expanded
if ( 1 < length(vintage)) serIDs <- rep(serIDs, length(vintage))
# next returns a vector of length equal serIDs
if (con@hasVintages) {
hV <- TRUE
vintage <- realVintage(con,vintage, serIDs)
}
else hV <- FALSE
Q <- function(q) {# local function
res <- dbGetQuery(con, q)
if(any(dim(res) == 0)) stop("empty query result.")
as.matrix(res)
}
mat <- desc <- doc <- label <- source <- rp <- NULL
# if series are in "A", "Q", "M","S" use ts otherwise zoo.
for (i in seq(length(serIDs))) {
where <- setWhere(con, serIDs[i], vintage[i], panel)
whereT <- setWhere(con, serIDs[i], NULL, panel)
for (j in seq(length(where))) {
qq <- paste("SELECT tbl, refperiod FROM Meta ",where[j], ";")
q <- dbGetQuery(con, qq)
if(0 == NROW(q$tbl))
stop("Meta lookup for series ", serIDs[i],
" failed. (Result empty for query: ",
qq, ") Series does not exist on database.")
if(1 < NROW(q$tbl)){
warning("Meta lookup for series ", serIDs[i],
" returned multiple table entries ", q$tbl, ". query: ",
qq, ") Possible database corruption. Using the first table.")
q <- q[1,]
}
if (i == 1) tbl <- q$tbl
else if(q$tbl != tbl)
stop("Series must all have the same frequency or time representation.")
rp <- c(rp, q$refperiod)
if (tbl=="A")
{res <- Q(paste("SELECT year, v FROM ", tbNm(hV, "A", vintage[i]),
whereT[j], " order by year;"))
r <- ts(res[,2], start=c(res[1,1], 1), frequency=1)
}
else if (tbl=="Q")
{res <- Q(paste("SELECT year, period, v FROM ", tbNm(hV, "Q", vintage[i]),
whereT[j], " order by year, period;"))
r <- ts(res[,3], start=c(res[1,1:2]), frequency=4)
}
else if (tbl=="M")
{res <- Q(paste("SELECT year, period, v FROM ", tbNm(hV, "M", vintage[i]),
whereT[j], " order by year, period;"))
r <- ts(res[,3], start=c(res[1,1:2]), frequency=12)
}
else if (tbl=="W")
{res <- Q(paste("SELECT date, period, v FROM ", tbNm(hV, "W", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,3]), as.Date(res[,1]))
# period is as.int(res[,2])
}
else if (tbl=="B")
{res <- Q(paste("SELECT date, period, v FROM ", tbNm(hV, "B", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,3]), as.Date(res[,1]))
# period is as.int(res[,2])
}
else if (tbl=="D")
{res <- Q(paste("SELECT date, period, v FROM ", tbNm(hV, "D", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,3]), as.Date(res[,1]))
# period is as.int(res[,2])
}
else if (tbl=="S")
{res <- Q(paste("SELECT year, period, v FROM ", tbNm(hV, "S", vintage[i]),
whereT[j], " order by year, period;"))
r <- ts(res[,3], start=c(res[1,1:2]), frequency=2)
}
else if (tbl=="U")
{res <- Q(paste("SELECT date, tz, period, v FROM U ",tbNm(hV,"U",vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,4]), as.Date(res[,1]))
# tz ? period is as.int(res[,3])
}
else if (tbl=="I")
{res <- Q(paste("SELECT date, v FROM ", tbNm(hV, "I", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,2]), as.Date(res[,1]))
}
else if (tbl=="T")
{res <- Q(paste("SELECT date, v FROM ", tbNm(hV, "T", vintage[i]),
whereT[j], " order by date;"))
r <- zoo::zoo(as.numeric(res[,2]), as.POSIXct(res[,1]))
}
else stop("Specified table not found.",
" (Internal TSdbi or database error likely.)",
" looking for series ", serIDs[i],
" could not find tbl ", tbl)
if(TSdescription) desc <- c(desc, TSdescription(serIDs[i],con) ) # where?
if(TSdoc) doc <- c(doc, TSdoc(serIDs[i],con) ) # where?
if(TSlabel) label<- c(label, TSlabel(serIDs[i],con) ) # where?
if(TSsource) source<- c(source,TSsource(serIDs[i],con) ) # where?
mat <- tbind(mat, r)
} # where[j]
} # serID[i]
mat <- tfwindow(mat, tf=tf, start=start, end=end)
mat <- tframePlus::changeTSrepresentation(mat, TSrepresentation)
if( (!all(is.na(rp))) && !all(rp == " " ) ) TSrefperiod(mat) <- rp
seriesNames(mat) <- names
TSmeta(mat) <- new("TSmeta", serIDs=serIDs, dbname=con@dbname,
conType=class(con), hasVintages=con@hasVintages, hasPanels=con@hasPanels,
DateStamp=NA, # bug in 2.7.0 =Sys.time(),
TSdescription=if(TSdescription) desc else NA,
TSdoc =if(TSdoc) doc else NA,
TSlabel =if(TSlabel) label else NA,
TSsource =if(TSsource) source else NA)
mat
}
TSdatesSQL <- function(serIDs, con,
vintage=getOption("TSvintage"), panel=getOption("TSpanel")) {
# so far I think this is generic to all SQL, but untested.
r <- av <- tb <- rP <- NULL
st <- en <- list()
vintage <- realVintage(con, vintage, serIDs)
panel <- realPanel(con,panel)
for (i in seq(length(serIDs))) {
qq <- paste("SELECT id, tbl, refperiod FROM Meta ",
setWhere(con, serIDs[i], vintage[i], panel), ";", sep="")
q <- dbGetQuery(con, qq)
if(is.null(q) || NROW(q) == 0) {
av <- c(av, FALSE)
st <- append(st, list(NA))
en <- append(en, list(NA))
tb <- rbind(tb, NA)
rP <- rbind(rP, NA)
}
else if(NROW(q) > 1){
warning("More than one series with the same identifier. Possible database corruption.",
" Meta lookup for series ", serIDs[i], " vintage ", vintage[i],
" returned multiple entries ", q, " for query: ",
qq, " Possible database corruption. Using the first table.")
q <- q[1,]
}
else {
q2 <- TSget(serIDs=serIDs[i], con, vintage=vintage, panel=panel)
av <- c(av, TRUE)
# paste(start(q2), collapse="-")
st <- append(st, list(start(q2)))
en <- append(en, list(end(q2)))
tb <- rbind(tb, q$tb)
rP <- rbind(rP, q$TSrefperiod)
}
}
r <- serIDs
attr(r, "TSdates") <- av
attr(r, "start") <- st
attr(r, "end") <- en
attr(r, "tbl") <- tb
attr(r, "TSrefperiod") <- rP
class(r) <- "TSdates"
r
}
#####################################
# these methods will generally not be needed by users, but is used in the test
# database setup.
createTSdbTables <- function(con, index=FALSE){
Texists <- function(a){
if(dbExistsTable(con,a)) {
warning("table ",a," exists. Not replacing it."); return(TRUE)}
if(dbExistsTable(con,toupper(a))) {
warning("table ",toupper(a)," exists. Not replacing it."); return(TRUE)}
if(dbExistsTable(con,tolower(a))) {
warning("table ",tolower(a)," exists. Not replacing it."); return(TRUE)}
FALSE
}
if (!Texists("Meta")) {
# Set up Metadata table Meta.
dbGetQuery(con, "create table Meta (
id VARCHAR(40) NOT NULL,
tbl CHAR(1),
refperiod VARCHAR(10) default NULL,
description TEXT,
documentation TEXT
);")
dbGetQuery(con, "CREATE UNIQUE INDEX Metaindex_id ON Meta (id);")
dbGetQuery(con, "CREATE INDEX Metaindex_tbl ON Meta (tbl);")
}
if (!Texists("A")) {
# Set up annual table A.
dbGetQuery(con, "create table A (
id VARCHAR(40),
year INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Aindex_id ON A (id);")
if (index) dbGetQuery(con, "CREATE INDEX Aindex_year ON A (year);")
}
if (!Texists("B")) {
# Set up business table B .
dbGetQuery(con, "create table B (
id VARCHAR(40),
date DATE,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Bindex_id ON B (id);")
if (index) dbGetQuery(con, "CREATE INDEX Bindex_date ON B (date);")
if (index) dbGetQuery(con, "CREATE INDEX Bindex_period ON B (period);")
}
if (!Texists("D")) {
# Set up daily table D .
dbGetQuery(con, "create table D (
id VARCHAR(40),
date DATE,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Dindex_id ON D (id);")
if (index) dbGetQuery(con, "CREATE INDEX Dindex_date ON D (date);")
if (index) dbGetQuery(con, "CREATE INDEX Dindex_period ON D (period);")
}
if (!Texists("M")) {
# Set up monthly table M.
dbGetQuery(con, "create table M (
id VARCHAR(40),
year INT,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Mindex_id ON M (id);")
if (index) dbGetQuery(con, "CREATE INDEX Mindex_year ON M (year);")
if (index) dbGetQuery(con, "CREATE INDEX Mindex_period ON M (period);")
}
if (!Texists("U")) {
# Set up minutely table U .
# tz not tested yet. Not sure about period.
dbGetQuery(con, "create table U (
id VARCHAR(40),
date TIMESTAMP,
tz VARCHAR(4),
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Uindex_id ON U (id);")
if (index) dbGetQuery(con, "CREATE INDEX Uindex_date ON U (date);")
if (index) dbGetQuery(con, "CREATE INDEX Uindex_period ON U (period);")
}
if (!Texists("Q")) {
# Set up quarterly table Q.
dbGetQuery(con, "create table Q (
id VARCHAR(40),
year INT,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Qindex_id ON Q (id);")
if (index) dbGetQuery(con, "CREATE INDEX Qindex_year ON Q (year);")
if (index) dbGetQuery(con, "CREATE INDEX Qindex_period ON Q (period);")
}
if (!Texists("S")) {
# Set up semiannual table S .
dbGetQuery(con, "create table S (
id VARCHAR(40),
year INT,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Sindex_id ON S (id);")
if (index) dbGetQuery(con, "CREATE INDEX Sindex_year ON S (year);")
if (index) dbGetQuery(con, "CREATE INDEX Sindex_period ON S (period);")
}
if (!Texists("W")) {
# Set up weekly table W .
dbGetQuery(con, "create table W (
id VARCHAR(40),
date DATE,
period INT,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Windex_id ON W (id);")
if (index) dbGetQuery(con, "CREATE INDEX Windex_date ON W (date);")
if (index) dbGetQuery(con, "CREATE INDEX Windex_period ON W (period);")
}
if (!Texists("I")) {
# Set up irregular date table I .
dbGetQuery(con, "create table I (
id VARCHAR(40),
date DATE,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Iindex_id ON I (id);")
if (index) dbGetQuery(con, "CREATE INDEX Iindex_date ON I (date);")
}
if (!Texists("T")) {
# Set up irregular date-time table T .
# IT WOULD BE NICE TO HAVE TZ HERE TOO
dbGetQuery(con, "create table T (
id VARCHAR(40),
date TIMESTAMP,
v double precision DEFAULT NULL
);")
if (index) dbGetQuery(con, "CREATE INDEX Tindex_id ON T (id);")
if (index) dbGetQuery(con, "CREATE INDEX Tindex_date ON T (date);")
}
# This is generic sql way to get table info. (eg. table A )
# but it requires read privileges on INFORMATION_SCHEMA.Columns
# which the user may not have.
#
#if( "SQLiteConnection" != class(con)) { #SQLite does not seem to support this
# z <- try(
# dbGetQuery(con, "SELECT COLUMN_NAME, COLUMN_DEFAULT, COLLATION_NAME, DATA_TYPE,
# CHARACTER_SET_NAME, CHARACTER_MAXIMUM_LENGTH, NUMERIC_PRECISION
# FROM INFORMATION_SCHEMA.Columns WHERE table_name='A' ;"), silent=TRUE )
# if(inherits(z, "try-error")) cat(
# "INFORMATION_SCHEMA query problem. (User may not have permission.)\n")
# else print(z)
# }
cat(" tables:\n")
dbListTables(con)
}
removeTSdbTables <- function(con, yesIknowWhatIamDoing=FALSE, ToLower=FALSE){
if(!yesIknowWhatIamDoing)
stop("You need to know what you are doing before using this function!!")
# "dropTStable" works around the
# problem that different db engines treat capitalized table names differently.
# e.g. MySQL uses table name Meta while Posgresql converts to meta.
dropTStable <- function(Table){
if (ToLower) Table <- tolower(Table)
if(dbExistsTable(con, Table)) dbRemoveTable(con, Table)
}
dropTStable("Meta")
dropTStable("A")
dropTStable("B")
dropTStable("D")
dropTStable("M")
dropTStable("U")
dropTStable("Q")
dropTStable("S")
dropTStable("W")
dropTStable("I")
dropTStable("T")
invisible(TRUE)
}
########## internal utilities to construct WHERE and table name#########
tbNm <- function(hasVintages, tbl, rV) {
if(hasVintages) tbl <- paste(tbl, rV, sep="_")
# map - to _ in table names
gsub("-", "_",tbl)
}
realVintage <- function(con, vintage, serIDs) {
# replace alias with canonical name if necessary
# assuming if vintage is a vector then serIDs has already been expanded to
# the same length. Otherwise, vintage should be null or a scalar which is
# expanded to the length of serIDs.
if(!con@hasVintages) return(vintage) #usually NULL in this case
if(is.null(vintage)) vintage <- "current"
else if( 1 == length(vintage)) vintage <- rep(vintage, length(serIDs))
rV <- NULL
for (i in seq(length(serIDs))){
q <- paste("SELECT vintage FROM vintageAlias WHERE alias ='",
vintage[i],"' AND id = '",serIDs[i],"';", sep="")
r <- dbGetQuery(con,q )$vintage
# if alias result is empty check null id which applies to all series.
if (0== NROW(r)) {
q <- paste( "SELECT vintage FROM vintageAlias WHERE alias='",
vintage[i],"' ;", sep="")
r <- dbGetQuery(con,q )$vintage
}
# if alias result is still empty assume vintage is already the real one.
if (0== NROW(r)) r <- vintage[i]
rV <- c(rV, r)
}
rV
}
realPanel <- function(con, panel) {
# replace alias with canonical name if necessary
if(!con@hasPanels) return(panel) #usually NULL in this case
if(is.null(panel)) stop("panel must be specified")
for (i in seq(length(panel))){
q <- paste("SELECT panel FROM panelAlias WHERE alias='",
panel[i],"';", sep="")
r <- dbGetQuery(con,q )$panel
# if alias result is empty assume panel is already the real one.
if (0== NROW(r)) r <- panel[i]
rP <- c(rP, r)
}
rP
}
setWhere <- function(con, serIDs, realVintage, realPanel) {
# serIDs must be a scale for this function
# Calls for Meta will pass realVintage, but data tables will set
# realVintage=NULL and append vintage to table name.
where <- paste(" WHERE id = '", serIDs, "'", sep="")
if(!is.null(realVintage))
where <- paste(where, " AND vintage='", realVintage, "'", sep="")
if(!is.null(realPanel))
where <- paste(where, " AND panel='", realPanel, "'", sep="")
where
}
Try the TSsql package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.