# -*- R -*-
# $RCSfile: io.R,v $
# $Date: 2000/07/29 22:03:24 $
# $Revision: 1.4 $
# Copyright (C) 1999 Timothy H. Keitt
# Licence: GPL
db.ls <- function(pattern=NULL, all=F) {
  if (!db.connection.open()) stop("No database connection")
  query <- paste("SELECT relname FROM pg_class WHERE relkind='r'")
  if (!is.null(pattern))
    query <- paste(query, "AND relname ~", single.quote(pattern))
  if (!all)
    query <- paste(query, "AND NOT relname ~ '^pg_'")
  on.exit(db.clear.result())
  db.execute(query, clear=F)
  tables <- db.read.column(as.is=T)
  tables <- make.names(tables)
  return(tables)
}

db.rm <- function(..., pattern=NULL, ask=T) {
  table.list <- list(...)
  if (!is.null(pattern))
    table.list <- append(table.list, db.ls(pattern=pattern))
  table.list <- make.names(table.list)
  for (i in seq(along=table.list)) {
    name <- table.list[[i]]
    if (db.table.exists(name)) {
      if (ask) {
        ans <- readline(paste(sep="", "Destroy table ", name, "? "))
        if (pmatch(ans, "y", nomatch=F))
          db.execute("DROP TABLE", double.quote(make.db.names(name)))
      } else {
        db.execute("DROP TABLE", double.quote(make.db.names(name)))
      }
    } else {
      warning(paste("Table", name, "does not exist in database"))
    }
  }
  return(invisible())
}

db.table.exists <- function(name) {
  name <- make.db.names(name)
  db.execute("SELECT relname FROM pg_class WHERE relname =",
             single.quote(name), clear=F)
  return(db.result.rows() > 0)
}

db.read.table <- function(name, row.names=NULL,
                          col.names=NULL, as.is=F) {
  on.exit(db.clear.result())
  db.execute("SELECT * FROM", format.table.name(name), clear=F)
  out <- db.fetch.result(row.names, col.names, as.is)
  return(out)
}

db.fetch.result <- function(row.names=NULL, col.names=NULL, as.is=F) {
  cols <- db.result.columns()
  data <- vector(mode="list", length=cols)
  # This is taken verbatim from read.table (v 1.1.0)
  if (is.logical(as.is)) {
    as.is <- rep(as.is, length = cols)
  }
  else if (is.numeric(as.is)) {
    if (any(as.is < 1 | as.is > cols)) 
      stop("invalid numeric as.is expression")
    i <- rep(FALSE, cols)
    i[as.is] <- TRUE
    as.is <- i
  }
  else if (length(as.is) != cols) 
    stop(paste("as.is has the wrong length", length(as.is), 
               "!= cols =", cols))
  # End borrowed code
  for (col in seq(1, length=cols))
    data[[col]] <- db.read.column(col, as.is=as.is[col])
  class(data) <- "data.frame"
  if (is.null(col.names)) {
    names(data) <- make.names(db.result.column.names(), unique=T)
  } else {
    names(data) <- make.names(col.names, unique=T)
  }
  if (is.null(row.names)) {
    if ("rpgsql.row.names" %in% names(data)) {
      row.names(data) <- data$rpgsql.row.names
      data$rpgsql.row.names <- NULL
    } else {
      row.names(data) <-
        as.character(seq(from=1, length=db.result.rows()))
    }
  } else {
    row.names(data) <- as.character(row.names)
  }
  return(data)
}

db.read.column <- function(column=1, as.is=F) {
  if (is.character(column))
    column <- match(column, db.result.column.names())
  data.col <- vector(length=db.result.rows())
  for (row in seq(along=data.col))
    data.col[row] <- db.result.get.value(row, column)
  if (!as.is)
    class(data.col) <- as.character(db.result.column.type(col=column))
  data.col <- rpgsql.cast.values(data.col)
  return(data.col)
}

db.write.table <- function(data, name=deparse(substitute(data)),
                           no.clobber=T, write.row.names=F) {
  name <- make.db.names(name)
  if (no.clobber) {
    if (db.table.exists(name))
      stop(paste("Table", name, "already in database"))
  } else {
    if (db.table.exists(name)) db.rm(name, ask=F)
  }
  if (!inherits(data, "data.frame")) data <- data.frame(I(data))
  if (write.row.names) data$rpgsql.row.names <- row.names(data)
  query <- paste("CREATE TABLE", double.quote(name))
  column.names <- lapply(make.db.names(names(data)), double.quote)
  data.types <- lapply(data, rpgsql.data.type)
  table.columns <- vector(mode="character")
  for (col in 1:ncol(data)) {
    column.def <- paste(column.names[col], data.types[col])
    table.columns <- append(table.columns, column.def)
  }
  query <- paste(query, "(", list.to.csv(table.columns), ")")
  db.execute(query)
  sql.insert(into=name, values=data)
  db.execute("VACUUM ANALYZE", double.quote(name))
  return(invisible())
}









# -*- R -*-
# $RCSfile: libpq.R,v $
# $Date: 2000/12/12 23:21:56 $
# $Revision: 1.6 $
# Copyright (C) 1999 Timothy H. Keitt
# Licence: GPL
db.connect <- function(host=NULL, hostaddr=NULL, port=NULL,
                       dbname=NULL, user=NULL, password=NULL,
                       options=NULL, tty=NULL, verbose=T) {
  conninfo <- character(1)
  if (!is.null(host)) conninfo <- paste(conninfo, "host =", host)
  if (!is.null(hostaddr)) conninfo <- paste(conninfo, "hostaddr =", hostaddr)
  if (!is.null(port)) conninfo <- paste(conninfo, "port =", port)
  if (!is.null(dbname)) conninfo <- paste(conninfo, "dbname =", dbname)
  if (!is.null(user)) conninfo <- paste(conninfo, "user =", user)
  if (!is.null(password)) conninfo <- paste(conninfo, "password =", password)
  if (!is.null(options)) conninfo <- paste(conninfo, "options =", options)
  if (!is.null(tty)) conninfo <- paste(conninfo, "tty =", tty)
  .C("rpgsql_connect", conninfo)
  if (db.connection.open()) {
    if (verbose) {
      host.name <- db.host.name()
      if (host.name == "") host.name <- "localhost"
      cat("Connected to database", double.quote(db.name()),
          "on", double.quote(host.name), "\n")
    }
  } else {
    stop("Connection failed\n")
  }
  db.execute("SET DATESTYLE TO 'Postgres, US'");
  return(invisible())
}

db.disconnect <- function() {
  .C("rpgsql_connection_finish")
  return(invisible())
}

db.connection.status <- function()
  return(.C("rpgsql_connection_status", status=integer(1))$status)

db.connection.open <- function()
  return(db.connection.status() == 0)

db.error.message <- function()
  return(.C("rpgsql_error_message", message=character(1))$message)

db.name <- function()
  return(.C("rpgsql_db_name", name=character(1))$name)

db.host.name <- function()
  .C("rpgsql_host_name", name=character(1))$name

db.connection.options <- function()
  return(.C("rpgsql_db_options", options=character(1))$options)

db.user.name <- function()
  return(.C("rpgsql_user_name", name=character(1))$name)

db.password <- function()
  return(.C("rpgsql_password", password=character(1))$password)

db.connection.port <- function()
  return(.C("rpgsql_port", port=character(1))$port)

db.debug.tty <- function()
  return(.C("rpgsql_tty", tty=character(1))$tty)

db.execute <- function(..., clear=T, report.errors=T) {
  if (clear) on.exit(db.clear.result())
  .C("rpgsql_exec", paste(...))
  result.status <- db.result.status()
  if (report.errors) {
    if (result.status == 6) warning(db.error.message())
    if (result.status == 7) stop(db.error.message())
  }
  return(invisible(result.status))
}

db.clear.result <- function() {
  .C("rpgsql_clear_result")
  return(invisible())
}

db.result.columns <- function()
  return(.C("rpgsql_result_nfields", columns=integer(1))$columns)

db.result.rows <- function()
  return(.C("rpgsql_result_ntuples", rows=integer(1))$rows)

db.result.column.number <- function(col.name) {
  return(.C("rpgsql_result_fnumber", as.character(col.name),
            index=integer(1))$index + 1)
}

db.result.column.type <- function(col=1)
  return(.C("rpgsql_result_ftype", as.integer(col), type=integer(1))$type)

db.result.status <- function()
  return(.C("rpgsql_result_status", status=integer(1))$status)

db.result.column.names <- function() {
  names <- vector(mode="character")
  for (i in seq(from=1, length=db.result.columns()))
    names[i] <- .C("rpgsql_result_fname", as.integer(i),
                   name=character(1))$name
  return(names)
}

db.result.get.value <- function(row=1, col=1) {
  null.value.flag <- .C("rpgsql_get_is_null", as.integer(row),
                        as.integer(col), flag=integer(1))$flag
  if (null.value.flag == 0)
    return(.C("rpgsql_get_value", as.integer(row), as.integer(col),
              value=character(1))$value)
  else
    return(NA)
}

db.toggle.echo <- function() {
  .C("rpgsql_toggle_echo")
  return(invisible())
}

# -*- R -*-
# $RCSfile: proxy.R,v $
# $Date: 2000/12/12 23:21:56 $
# $Revision: 1.10 $
# Copyright (C) 1999, 2000 Timothy H. Keitt

# The vacuum function is postgresql specific
bind.db.proxy <- function(table.names, vacuum=F) {
  table.names <- make.names(table.names)
  for (i in seq(along=table.names)) {
    proxy <- list(table.name=table.names[i], host=db.host.name(),
                  port=db.connection.port(), dbname=db.name(),
                  user=db.user.name(), password=db.password())
    class(proxy) <- c("db.proxy", "data.frame")
    if (vacuum) db.execute("VACUUM ANALYZE", table.names[i])
    assign(table.names[i], proxy, envir=sys.frame(sys.parent()))
  }
  return(invisible())
}

# This may break some other packages, but there is no other option,
# and row.names really should be generic
#
# row.names <- function(x) UseMethod("row.names")
# row.names.default <- function(x) attr(x, "row.names")
#
# row.names has been made generic in R 1.2
row.names.db.proxy <- function(x) {
  if (db.has.row.names(x)) {
    return(row.names(sql.select("rpgsql.row.names", from=x)))
  } else {
    return(as.character(seq(from=1, length=nrow(x))))
  }
}

dimnames.db.proxy <- function(x) list(row.names(x), names(x))

as.list.db.proxy <- function(x) as.list(as.data.frame(x))

as.matrix.db.proxy <- function(proxy) return(as.matrix(db.read.table(proxy)))

as.data.frame.db.proxy <- function(x) return(db.read.table(x))

db.has.row.names <- function(proxy)
  return("rpgsql.row.names" %in% names(proxy))

names.db.proxy <- function(proxy) {
  on.exit(db.clear.result())
  db.execute("SELECT * FROM", db.table.name(proxy), "LIMIT 1", clear=F)
  return(make.names(db.result.column.names()))
}

dim.db.proxy <- function(proxy) {
  on.exit(db.clear.result())
  name <- make.db.names(db.table.name(proxy))
  db.execute("SELECT reltuples, relnatts FROM pg_class",
             "WHERE relname =", single.quote(name), clear=F)
  return(as.integer(c(db.result.get.value(), db.result.get.value(col=2))))
}

summary.db.proxy <- function(proxy) {
  cat("Table name:", db.table.name(proxy), "\n")
  cat("Database:", unclass(proxy)$dbname, "\n")
  cat("Host:", unclass(proxy)$host, "\n")
  cat("Dimensions:", ncol(proxy), "(columns)",
      nrow(proxy), "(rows)\n\n")
}

print.db.proxy <- function(proxy, max.rows=10, max.columns=10, ...) {
  dimension <- dim(proxy)
  rows <- dimension[1]
  columns <- dimension[2]
  if (rows > max.rows && columns > max.columns) {
    print(proxy[1:max.rows, 1:max.columns], ...)
    cat("Continues for", rows-max.rows, "more rows and",
        columns-max.columns, "more cols...\n")
  } else if (rows > max.rows) {
    print(proxy[1:max.rows, ], ...)
    cat("Continues for", rows-max.rows, "more rows...\n")
  } else if (columns > max.columns) {
    print(proxy[ , 1:max.columns], ...)
    cat("Continues for", columns-max.columns, "more cols...\n")
  } else {
    print(proxy[], ...)
  }
  return(invisible())
}

db.table.name <- function(proxy)
  return(make.db.names(unclass(proxy)$table.name))

"$.db.proxy" <- function(proxy, col) return(proxy[[col]])

"[[.db.proxy" <- function(proxy, i, j) {
  if (missing(i)) stop("no subscript")
  if (length(i) > 1) stop("invalid subscript")
  if (nargs() > 2) {
    if (is.character(i)) i <- match(i, row.names(proxy))
    if (length(j) > 1) stop("invalid subscript")
    if (mode(j) == "numeric") j <- names(proxy)[j]
    return(sql.select(j, from=proxy, limit=1, offset=i-1)[[1,1]])
  }
  if (is.numeric(i)) i <- names(proxy)[i]
  return(sql.select(columns=i, from=proxy)[[1]])
}

"[.db.proxy" <- function(proxy, rows, cols) {
  if (nargs() < 2) return(db.read.table(proxy))
  if (!missing(rows)) {
    if (mode(rows) == "character") {
      rows <- match(rows, row.names(proxy))
    } else {
      if (any(rows < 0)) {
        if (any(rows > 0))
          stop("cannot mix negative and positive indices")
        rows <- seq(from=1, length=nrow(proxy))[rows]
      }
    }
  }
  if (!missing(cols)) {
    if (mode(cols) == "character") {
      columns <- cols
    } else {
      if (any(cols < 0)) {
        if (any(cols > 0))
          stop("cannot mix negative and positive indices")
        cols <- (1:ncol(proxy))[cols]
      }
      columns <- names(proxy)[cols]
    }
  } else {
    columns <- "*"
  }
  if (missing(rows)) {
    return(sql.select(columns, from=proxy))
  } else {
    # This needs to be generalized to allow extraction
    # of non-contiguous rows of data
    first.row <- min(rows)
    n <- max(rows) - first.row + 1
    data <- sql.select(columns, from=proxy, limit=n,
                       offset=first.row-1)
    row.names(data) <- seq(from=first.row, length=n)
    return(data)
  }
}

"row.names<-.db.proxy" <- function(...) stop("Object is read-only")
"dimnames<-.db.proxy" <- function(...) stop("Object is read-only")
"names<-.db.proxy" <- function(...) stop("Object is read-only")
"$<-.db.proxy" <- function(...) stop("Object is read-only")
"[<-.db.proxy" <- function(...) stop("Object is read-only")
"[[<-.db.proxy" <- function(...) stop("Object is read-only")















# -*- R -*-
# $RCSfile: sql.R,v $
# $Date: 2000/07/14 20:54:46 $
# $Revision: 1.3 $
# Copyright (C) 1999 Timothy H. Keitt

# You can't use this function to do joins
sql.select <- function(columns="*", into, from, where, group.by, having,
                       order.by, limit, offset, distinct=F, exec=T) {
  preamble <- ifelse(distinct, "SELECT DISTINCT", "SELECT")
  if (columns != "*")
    columns <- sapply(make.db.names(columns), double.quote)
  query <- paste(preamble, list.to.csv(columns))
  if (!missing(into))
    query <- paste(query, "INTO", format.table.name(into))
  query <- paste(query, "FROM", format.table.name(from))
  if (!missing(where))
    query <- paste(query, "WHERE", list.to.csv(where))
  if (!missing(group.by)) {
    group.by <- sapply(make.db.names(group.by), double.quote)
    query <- paste(query, "GROUP BY", list.to.csv(group.by))
  }
  if (!missing(limit))
    query <- paste(query, "LIMIT", limit)
  if (!missing(offset))
    query <- paste(query, "OFFSET", offset)
  if (exec) {
    on.exit(db.clear.result())
    db.execute(query, clear=F)
    if (missing(into))
      return(db.fetch.result())
    else
      return(invisible())
  } else {
    return(query)
  }
}

sql.insert <- function(into, column.names, values, query) {
  if (missing(values) && missing(query))
    stop("Nothing to append to table")
  preamble <- paste("INSERT INTO", format.table.name(into))
  db.execute("BEGIN TRANSACTION")
  on.exit(db.execute("ROLLBACK TRANSACTION"))
  if (!missing(values)) {
    if (missing(column.names)) column.names <- names(values)
    column.names <- sapply(make.db.names(column.names), double.quote)
    formatted.data <- matrix(nrow=nrow(values), ncol=ncol(values))
    for (i in seq(along=column.names))
      formatted.data[,i] <- rpgsql.format.values(values[[i]])
    boiler <- paste(preamble, "(", list.to.csv(column.names), ")")
    for (i in 1:nrow(values)) {
      insert.values <- list.to.csv(formatted.data[i,])
      db.execute(boiler, "VALUES (", insert.values, ")")
    }
  } else {
    if (!missing(column.names)) {
      column.names <- sapply(make.db.names(column.names), single.quote)
      boiler <- paste(preamble, list.to.csv(column.names))
    } else {
      boiler <- preamble
    }
    db.execute(boiler, query)
  }
  on.exit(db.execute("COMMIT TRANSACTION"))
  return(invisible())
}
  







# -*- R -*-
# $RCSfile: types.R,v $
# $Date: 2000/12/12 23:21:56 $
# $Revision: 1.3 $
# Copyright (C) 1999 Timothy H. Keitt

rpgsql.data.type <- function(x) UseMethod("rpgsql.data.type")

rpgsql.data.type.default <- function(x) {
  if(is.factor(x)) return("TEXT")
  if(is.integer(x)) return("INTEGER")
  if(is.double(x)) return("REAL")
  if(is.logical(x)) return("BOOL")
  if(is.complex(x)) warning("Complex data stored as text")
  return("TEXT")
}

rpgsql.data.type.dates <- function(x) return("DATE")
rpgsql.data.type.times <- function(x) return("TIME")

rpgsql.format.values <- function(x) UseMethod("rpgsql.format.values")

rpgsql.format.values.default <- function(x)
  return(format.null.values(single.quote(x)))

rpgsql.format.values.dates <- function(x) {
  attr(x, "format") <- "day mon year"
  return(rpgsql.format.values.default(x))
}

rpgsql.format.values.times <- function(x) {
  attr(x, "format") <- "h:m:s"
  return(rpgsql.format.values.default(x))
}

rpgsql.cast.values <- function(x) UseMethod("rpgsql.cast.values")

rpgsql.cast.values.default <- function(x) {
  if(!is.null(class(x)))
    warning(paste("Coercing PGSQL type", class(x), "to character"))
  return(as.character(x))
}

rpgsql.cast.values.16 <- function(x) return(x == "t")
rpgsql.cast.values.19 <- function(x) return(as.factor(x))
rpgsql.cast.values.20 <- function(x) return(as.integer(x))
rpgsql.cast.values.21 <- function(x) return(as.integer(x))
rpgsql.cast.values.23 <- function(x) return(as.integer(x))
rpgsql.cast.values.25 <- function(x) return(as.factor(x))
rpgsql.cast.values.700 <- function(x) return(as.double(x))
rpgsql.cast.values.701 <- function(x) return(as.double(x))
rpgsql.cast.values.1042 <- function(x) return(as.factor(x))
rpgsql.cast.values.1043 <- function(x) return(as.factor(x))
rpgsql.cast.values.1082 <- function(x) return(dates(x, format='m-d-y'))
rpgsql.cast.values.1083 <- function(x) return(times(x))
rpgsql.cast.values.1700 <- function(x) return(as.double(x))





# -*- R -*-
# $RCSfile: util.R,v $
# $Date: 2000/07/25 16:03:45 $
# $Revision: 1.3 $
# Copyright (C) 1999 Timothy H. Keitt
format.table.name <- function(table.name) {
  if (inherits(table.name, "db.proxy"))
    name <- make.db.names(db.table.name(table.name))
  else
    name <- make.db.names(as.character(table.name))
  name <- double.quote(name)
}

check.table.name <- function(table.name) {
  name <- format.table.name(table.name)
  if (!db.table.exists(name)) stop(paste(name, "is not in database"))
  return(name)
}

make.db.names <- function(name)
  return(gsub("\\.", "_", as.character(name)))

list.to.csv <- function(...)
  return(paste(collapse=", ", ...))

single.quote <- function(...) {
  text <- gsub("'", "\\\\'", as.character(...))
  return(paste("'", unlist(text), "'", sep = ""))
}
         
double.quote <- function(...)
  return(paste('"', unlist(as.character(...)), '"', sep=""))

format.null.values <- function(...) {
  pattern <- "' *NA'|' *NaN'|' *Inf'|' *-Inf'"
  return(gsub(pattern, "NULL", as.character(...)))
}

psql <- function(dbname=NULL, host=NULL, port=NULL) {
  if (db.connection.open()) {
    if (is.null(dbname)) dbname <- db.name()
    if (is.null(host)) host <- db.host.name()
    if (is.null(port)) port <- db.connection.port()
  }
  command <- "psql"
  if (!is.null(dbname)) command <- paste(command, "-d", dbname)
  if (!is.null(host) && length(host) > 1)
    command <- paste(command, "-h", host)
  if (!is.null(port)) command <- paste(command, "-p", port)
  system(command)
}
## -*- R -*-
## $RCSfile: zzz.R,v $
## $Date: 2000/07/10 23:17:33 $
## $Revision: 1.2 $
## Copyright (C) 1999 Timothy H. Keitt
.First.lib <- function(lib, pkg) {
  library.dynam("RPgSQL", pkg, lib)
  autoload("times", "chron")
  autoload("dates", "chron")
  return(invisible())
}

